diff --git a/Bytecodes.h b/Bytecodes.h --- a/Bytecodes.h +++ b/Bytecodes.h @@ -34,6 +34,7 @@ #define bci_PUSH16_W 9 #define bci_PUSH32_W 10 #define bci_PUSH_G 11 +#define bci_PUSH_ALTS 12 #define bci_PUSH_ALTS_P 13 #define bci_PUSH_ALTS_N 14 #define bci_PUSH_ALTS_F 15 @@ -80,6 +81,7 @@ #define bci_CCALL 56 #define bci_SWIZZLE 57 #define bci_ENTER 58 +#define bci_RETURN 59 #define bci_RETURN_P 60 #define bci_RETURN_N 61 #define bci_RETURN_F 62 diff --git a/ClosureTypes.h b/ClosureTypes.h --- a/ClosureTypes.h +++ b/ClosureTypes.h @@ -87,4 +87,5 @@ #define SMALL_MUT_ARR_PTRS_FROZEN_DIRTY 61 #define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62 #define COMPACT_NFDATA 63 -#define N_CLOSURE_TYPES 64 +#define CONTINUATION 64 +#define N_CLOSURE_TYPES 65 diff --git a/CodeGen.Platform.h b/CodeGen.Platform.h --- a/CodeGen.Platform.h +++ b/CodeGen.Platform.h @@ -377,6 +377,74 @@ # define ft10 62 # define ft11 63 +#elif defined(MACHREGS_loongarch64) + +# define zero 0 +# define ra 1 +# define tp 2 +# define sp 3 +# define a0 4 +# define a1 5 +# define a2 6 +# define a3 7 +# define a4 8 +# define a5 9 +# define a6 10 +# define a7 11 +# define t0 12 +# define t1 13 +# define t2 14 +# define t3 15 +# define t4 16 +# define t5 17 +# define t6 18 +# define t7 19 +# define t8 20 +# define u0 21 +# define fp 22 +# define s0 23 +# define s1 24 +# define s2 25 +# define s3 26 +# define s4 27 +# define s5 28 +# define s6 29 +# define s7 30 +# define s8 31 + +# define fa0 32 +# define fa1 33 +# define fa2 34 +# define fa3 35 +# define fa4 36 +# define fa5 37 +# define fa6 38 +# define fa7 39 +# define ft0 40 +# define ft1 41 +# define ft2 42 +# define ft3 43 +# define ft4 44 +# define ft5 45 +# define ft6 46 +# define ft7 47 +# define ft8 48 +# define ft9 49 +# define ft10 50 +# define ft11 51 +# define ft12 52 +# define ft13 53 +# define ft14 54 +# define ft15 55 +# define fs0 56 +# define fs1 57 +# define fs2 58 +# define fs3 59 +# define fs4 60 +# define fs5 61 +# define fs6 62 +# define fs7 63 + #endif callerSaves :: GlobalReg -> Bool @@ -664,7 +732,10 @@ #if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ || defined(MACHREGS_powerpc) \ || defined(MACHREGS_arm) || defined(MACHREGS_aarch64) \ - || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64) + || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64) \ + || defined(MACHREGS_wasm32) \ + || defined(MACHREGS_loongarch64) + # if defined(REG_Base) globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) # endif diff --git a/GHC.hs b/GHC.hs --- a/GHC.hs +++ b/GHC.hs @@ -27,7 +27,8 @@ handleSourceError, -- * Flags and settings - DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt, + DynFlags(..), GeneralFlag(..), Severity(..), Backend, gopt, + ncgBackend, llvmBackend, viaCBackend, interpreterBackend, noBackend, GhcMode(..), GhcLink(..), parseDynamicFlags, parseTargetFiles, getSessionDynFlags, @@ -96,12 +97,12 @@ modInfoSafe, lookupGlobalName, findGlobalAnns, - mkPrintUnqualifiedForModule, + mkNamePprCtxForModule, ModIface, ModIface_(..), SafeHaskellMode(..), -- * Printing - PrintUnqualified, alwaysQualify, + NamePprCtx, alwaysQualify, -- * Interactive evaluation @@ -118,7 +119,7 @@ setGHCiMonad, getGHCiMonad, -- ** Inspecting the current context - getBindings, getInsts, getPrintUnqual, + getBindings, getInsts, getNamePprCtx, findModule, lookupModule, findQualifiedModule, lookupQualifiedModule, renamePkgQualM, renameRawPkgQualM, @@ -175,7 +176,6 @@ -- ** Modules Module, mkModule, pprModule, moduleName, moduleUnit, - ModuleName, mkModuleName, moduleNameString, -- ** Names Name, @@ -197,7 +197,7 @@ TyCon, tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon, - isPrimTyCon, isFunTyCon, + isPrimTyCon, isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon, tyConClass_maybe, synTyConRhs_maybe, synTyConDefn_maybe, tyConKind, @@ -352,9 +352,6 @@ import GHC.Tc.Instance.Family import GHC.Utils.TmpFs -import GHC.SysTools -import GHC.SysTools.BaseDir - import GHC.Utils.Error import GHC.Utils.Monad import GHC.Utils.Misc @@ -370,8 +367,7 @@ import GHC.Core.TyCo.Ppr ( pprForAll ) import GHC.Core.Class import GHC.Core.DataCon -import GHC.Core.FVs ( orphNamesOfFamInst ) -import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts ) +import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts, orphNamesOfFamInst ) import GHC.Core.InstEnv import GHC.Core @@ -561,57 +557,16 @@ -- . initGhcMonad :: GhcMonad m => Maybe FilePath -> m () -initGhcMonad mb_top_dir - = do { -- 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. - !keep_cafs <- liftIO $ c_keepCAFsForGHCi - ; massert keep_cafs - ; env <- liftIO $ - do { top_dir <- findTopDir mb_top_dir - ; mySettings <- initSysTools top_dir - ; myLlvmConfig <- lazyInitLlvmConfig top_dir - ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig) - ; hsc_env <- newHscEnv dflags - ; checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags - ; setUnsafeGlobalDynFlags dflags - -- c.f. DynFlags.parseDynamicFlagsFull, which - -- creates DynFlags and sets the UnsafeGlobalDynFlags - ; return hsc_env } - ; setSession 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 :: MonadIO m => Logger -> DynFlags -> m () -checkBrokenTablesNextToCode logger dflags - = do { broken <- checkBrokenTablesNextToCode' logger dflags - ; when broken - $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr - ; liftIO $ fail "unsupported linker" - } - } - where - invalidLdErr = text "Tables-next-to-code not supported on ARM" <+> - text "when using binutils ld (please see:" <+> - text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)" - -checkBrokenTablesNextToCode' :: MonadIO m => Logger -> DynFlags -> m Bool -checkBrokenTablesNextToCode' logger dflags - | not (isARM arch) = return False - | ways dflags `hasNotWay` WayDyn = return False - | not tablesNextToCode = return False - | otherwise = do - linkerInfo <- liftIO $ getLinkerInfo logger dflags - case linkerInfo of - GnuLD _ -> return True - _ -> return False - where platform = targetPlatform dflags - arch = platformArch platform - tablesNextToCode = platformTablesNextToCode platform +initGhcMonad mb_top_dir = setSession =<< liftIO ( do + -- 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 + initHscEnv mb_top_dir + ) -- %************************************************************************ -- %* * @@ -640,7 +595,7 @@ -- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' -- retrieves the program @DynFlags@ (for backwards compatibility). --- This is a compatability function which sets dynflags for the top session +-- This is a compatibility function which sets dynflags for the top session -- as well as the unit. setSessionDynFlags :: (HasCallStack, GhcMonad m) => DynFlags -> m () setSessionDynFlags dflags0 = do @@ -651,7 +606,7 @@ case S.toList all_uids of [uid] -> do setUnitDynFlagsNoCheck uid dflags - modifySession (hscSetActiveUnitId (homeUnitId_ dflags)) + modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ dflags)) dflags' <- getDynFlags setTopSessionDynFlags dflags' [] -> panic "nohue" @@ -983,7 +938,8 @@ -- See Note [DynFlags consistency] let (dflags', warnings) = makeDynFlagsConsistent dflags let diag_opts = initDiagOpts dflags - liftIO $ handleFlagWarnings logger diag_opts (map (Warn WarningWithoutFlag) warnings) + print_config = initPrintConfig dflags + liftIO $ handleFlagWarnings logger print_config diag_opts (map (Warn WarningWithoutFlag) warnings) return dflags' checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags @@ -993,7 +949,8 @@ if xopt LangExt.StaticPointers dflags0 then do let diag_opts = initDiagOpts dflags0 - liftIO $ printOrThrowDiagnostics logger diag_opts $ singleMessage + print_config = initPrintConfig dflags0 + liftIO $ printOrThrowDiagnostics logger print_config diag_opts $ singleMessage $ fmap GhcDriverMessage $ mkPlainMsgEnvelope diag_opts interactiveSrcSpan DriverStaticPointersNotSupported return $ xopt_unset dflags0 LangExt.StaticPointers @@ -1174,7 +1131,7 @@ instance DesugaredMod DesugaredModule where coreModule m = dm_core_module m -type ParsedSource = Located HsModule +type ParsedSource = Located (HsModule GhcPs) type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], Maybe (LHsDoc GhcRn)) type TypecheckedSource = LHsBinds GhcTc @@ -1398,9 +1355,9 @@ let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env) in return (instEnvElts inst_env, fam_env) -getPrintUnqual :: GhcMonad m => m PrintUnqualified -getPrintUnqual = withSession $ \hsc_env -> do - return $ icPrintUnqual (hsc_unit_env hsc_env) (hsc_IC hsc_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 { @@ -1494,12 +1451,14 @@ modInfoIsExportedName :: ModuleInfo -> Name -> Bool modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) -mkPrintUnqualifiedForModule :: GhcMonad m => - ModuleInfo - -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X -mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do - let mk_print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) - return (fmap mk_print_unqual (minf_rdr_env 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 @@ -1835,7 +1794,7 @@ parser :: String -- ^ Haskell module source text (full Unicode is supported) -> DynFlags -- ^ the flags -> FilePath -- ^ the filename (for source locations) - -> (WarningMessages, Either ErrorMessages (Located HsModule)) + -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs))) parser str dflags filename = let @@ -2000,5 +1959,7 @@ mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) +-- foreign import ccall unsafe "keepCAFsForGHCi" c_keepCAFsForGHCi :: IO Bool + diff --git a/GHC/Builtin/Names.hs b/GHC/Builtin/Names.hs --- a/GHC/Builtin/Names.hs +++ b/GHC/Builtin/Names.hs @@ -50,7 +50,7 @@ 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 the + 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. @@ -119,7 +119,6 @@ -} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Builtin.Names ( Unique, Uniquable(..), hasKey, -- Re-exported for convenience @@ -136,7 +135,6 @@ import GHC.Prelude import GHC.Unit.Types -import GHC.Unit.Module.Name import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Types.Unique @@ -144,7 +142,11 @@ 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 + {- ************************************************************************ * * @@ -153,10 +155,14 @@ ************************************************************************ -} -allNameStrings :: [String] +allNameStrings :: Infinite String -- Infinite list of a,b,c...z, aa, ab, ac, ... etc -allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ] +allNameStrings = Inf.allListsOf ['a'..'z'] +allNameStringList :: [String] +-- Infinite list of a,b,c...z, aa, ab, ac, ... etc +allNameStringList = Inf.toList allNameStrings + {- ************************************************************************ * * @@ -257,6 +263,7 @@ starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName, + constraintKindRepName, -- WithDict withDictClassName, @@ -318,7 +325,6 @@ newStablePtrName, -- GHC Extensions - groupWithName, considerAccessibleName, -- Strings and lists @@ -333,6 +339,9 @@ fromListNName, toListName, + -- Non-empty lists + nonEmptyTyConName, + -- Overloaded record dot, record update getFieldName, setFieldName, @@ -341,7 +350,7 @@ zipName, foldrName, buildName, augmentName, appendName, -- FFI primitive types that are not wired-in. - stablePtrTyConName, ptrTyConName, funPtrTyConName, + stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName, int8TyConName, int16TyConName, int32TyConName, int64TyConName, word8TyConName, word16TyConName, word32TyConName, word64TyConName, @@ -427,7 +436,7 @@ rationalToDoubleName, -- Other classes - randomClassName, randomGenClassName, monadPlusClassName, + monadPlusClassName, -- Type-level naturals knownNatClassName, knownSymbolClassName, knownCharClassName, @@ -532,13 +541,13 @@ pRELUDE :: Module pRELUDE = mkBaseModule_ pRELUDE_NAME -gHC_PRIM, gHC_PRIM_PANIC, gHC_PRIM_EXCEPTION, +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, dATA_EITHER, dATA_VOID, dATA_LIST, dATA_STRING, + 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, @@ -548,11 +557,10 @@ 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 :: Module + 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_PRIM_EXCEPTION = mkPrimModule (fsLit "GHC.Prim.Exception") gHC_TYPES = mkPrimModule (fsLit "GHC.Types") gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") gHC_MAGIC_DICT = mkPrimModule (fsLit "GHC.Magic.Dict") @@ -573,8 +581,8 @@ 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_VOID = mkBaseModule (fsLit "Data.Void") dATA_LIST = mkBaseModule (fsLit "Data.List") dATA_STRING = mkBaseModule (fsLit "Data.String") dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") @@ -618,6 +626,7 @@ 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") @@ -954,7 +963,7 @@ rightDataConName = dcQual dATA_EITHER (fsLit "Right") rightDataConKey voidTyConName :: Name -voidTyConName = tcQual dATA_VOID (fsLit "Void") voidTyConKey +voidTyConName = tcQual gHC_BASE (fsLit "Void") voidTyConKey -- Generics (types) v1TyConName, u1TyConName, par1TyConName, rec1TyConName, @@ -1113,8 +1122,7 @@ -- Functions for GHC extensions -groupWithName, considerAccessibleName :: Name -groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey +considerAccessibleName :: Name considerAccessibleName = varQual gHC_EXTS (fsLit "considerAccessible") considerAccessibleIdKey -- Random GHC.Base functions @@ -1402,15 +1410,20 @@ trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey -- Typeable KindReps for some common cases -starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName :: Name -starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey -starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey -starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey +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 +withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey +nonEmptyTyConName :: Name +nonEmptyTyConName = tcQual gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey + -- Custom type errors errorMessageTypeErrorFamName , typeErrorTextDataConName @@ -1576,11 +1589,8 @@ toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey -- Other classes, needed for type defaulting -monadPlusClassName, randomClassName, randomGenClassName, - isStringClassName :: Name +monadPlusClassName, isStringClassName :: Name monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey -randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey -randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey -- Type-level naturals @@ -1655,6 +1665,10 @@ fingerprintDataConName = dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey +constPtrConName :: Name +constPtrConName = + tcQual fOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey + {- ************************************************************************ * * @@ -1787,7 +1801,7 @@ addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, - doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey, + doubleTyConKey, floatPrimTyConKey, floatTyConKey, fUNTyConKey, intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey, @@ -1798,7 +1812,8 @@ ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, stablePtrTyConKey, eqTyConKey, heqTyConKey, ioPortPrimTyConKey, smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey, - stringTyConKey :: Unique + stringTyConKey, + ccArrowTyConKey, ctArrowTyConKey, tcArrowTyConKey :: Unique addrPrimTyConKey = mkPreludeTyConUnique 1 arrayPrimTyConKey = mkPreludeTyConUnique 3 boolTyConKey = mkPreludeTyConUnique 4 @@ -1810,7 +1825,7 @@ doubleTyConKey = mkPreludeTyConUnique 10 floatPrimTyConKey = mkPreludeTyConUnique 11 floatTyConKey = mkPreludeTyConUnique 12 -funTyConKey = mkPreludeTyConUnique 13 +fUNTyConKey = mkPreludeTyConUnique 13 intPrimTyConKey = mkPreludeTyConUnique 14 intTyConKey = mkPreludeTyConUnique 15 int8PrimTyConKey = mkPreludeTyConUnique 16 @@ -1841,6 +1856,10 @@ eqTyConKey = mkPreludeTyConUnique 40 heqTyConKey = mkPreludeTyConUnique 41 +ctArrowTyConKey = mkPreludeTyConUnique 42 +ccArrowTyConKey = mkPreludeTyConUnique 43 +tcArrowTyConKey = mkPreludeTyConUnique 44 + statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, mutVarPrimTyConKey, ioTyConKey, wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey, @@ -1850,7 +1869,8 @@ typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, eqReprPrimTyConKey, eqPhantPrimTyConKey, - compactPrimTyConKey, stackSnapshotPrimTyConKey :: Unique + compactPrimTyConKey, stackSnapshotPrimTyConKey, + promptTagPrimTyConKey, constPtrTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 stableNameTyConKey = mkPreludeTyConUnique 52 @@ -1879,6 +1899,7 @@ tVarPrimTyConKey = mkPreludeTyConUnique 79 compactPrimTyConKey = mkPreludeTyConUnique 80 stackSnapshotPrimTyConKey = mkPreludeTyConUnique 81 +promptTagPrimTyConKey = mkPreludeTyConUnique 82 eitherTyConKey :: Unique eitherTyConKey = mkPreludeTyConUnique 84 @@ -1889,16 +1910,21 @@ nonEmptyTyConKey :: Unique nonEmptyTyConKey = mkPreludeTyConUnique 86 +dictTyConKey :: Unique +dictTyConKey = mkPreludeTyConUnique 87 + -- Kind constructors liftedTypeKindTyConKey, unliftedTypeKindTyConKey, - tYPETyConKey, liftedRepTyConKey, unliftedRepTyConKey, + tYPETyConKey, cONSTRAINTTyConKey, + liftedRepTyConKey, unliftedRepTyConKey, constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey, vecCountTyConKey, vecElemTyConKey, zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique liftedTypeKindTyConKey = mkPreludeTyConUnique 88 unliftedTypeKindTyConKey = mkPreludeTyConUnique 89 -tYPETyConKey = mkPreludeTyConUnique 90 -constraintKindTyConKey = mkPreludeTyConUnique 92 +tYPETyConKey = mkPreludeTyConUnique 91 +cONSTRAINTTyConKey = mkPreludeTyConUnique 92 +constraintKindTyConKey = mkPreludeTyConUnique 93 levityTyConKey = mkPreludeTyConUnique 94 runtimeRepTyConKey = mkPreludeTyConUnique 95 vecCountTyConKey = mkPreludeTyConUnique 96 @@ -1920,7 +1946,6 @@ kindRepTyConKey = mkPreludeTyConUnique 107 typeLitSortTyConKey = mkPreludeTyConUnique 108 - -- Generics (Unique keys) v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, @@ -2056,6 +2081,7 @@ typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 414 typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415 typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416 +constPtrTyConKey = mkPreludeTyConUnique 417 {- ************************************************************************ @@ -2069,8 +2095,7 @@ floatDataConKey, intDataConKey, nilDataConKey, ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, word8DataConKey, ioDataConKey, heqDataConKey, - coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey, - nonEmptyDataConKey :: Unique + eqDataConKey, nothingDataConKey, justDataConKey :: Unique charDataConKey = mkPreludeDataConUnique 1 consDataConKey = mkPreludeDataConUnique 2 @@ -2089,7 +2114,6 @@ wordDataConKey = mkPreludeDataConUnique 15 ioDataConKey = mkPreludeDataConUnique 16 heqDataConKey = mkPreludeDataConUnique 18 -nonEmptyDataConKey = mkPreludeDataConUnique 19 -- Generic data constructors crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique @@ -2107,7 +2131,10 @@ ordEQDataConKey = mkPreludeDataConUnique 28 ordGTDataConKey = mkPreludeDataConUnique 29 +mkDictDataConKey :: Unique +mkDictDataConKey = mkPreludeDataConUnique 30 +coercibleDataConKey :: Unique coercibleDataConKey = mkPreludeDataConUnique 32 staticPtrDataConKey :: Unique @@ -2251,52 +2278,51 @@ ************************************************************************ -} -wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey, +wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendIdKey, buildIdKey, foldrIdKey, recSelErrorIdKey, seqIdKey, eqStringIdKey, noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, - runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey, + impossibleErrorIdKey, impossibleConstraintErrorIdKey, + patErrorIdKey, voidPrimIdKey, realWorldPrimIdKey, recConErrorIdKey, unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey, unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, typeErrorIdKey, divIntIdKey, modIntIdKey, - absentSumFieldErrorIdKey, cstringLengthIdKey, - raiseOverflowIdKey, raiseUnderflowIdKey, raiseDivZeroIdKey + absentSumFieldErrorIdKey, cstringLengthIdKey :: Unique -wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] -absentErrorIdKey = mkPreludeMiscIdUnique 1 -augmentIdKey = mkPreludeMiscIdUnique 2 -appendIdKey = mkPreludeMiscIdUnique 3 -buildIdKey = mkPreludeMiscIdUnique 4 -foldrIdKey = mkPreludeMiscIdUnique 6 -recSelErrorIdKey = mkPreludeMiscIdUnique 7 -seqIdKey = mkPreludeMiscIdUnique 8 -absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 -eqStringIdKey = mkPreludeMiscIdUnique 10 -noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 -nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 -runtimeErrorIdKey = mkPreludeMiscIdUnique 13 -patErrorIdKey = mkPreludeMiscIdUnique 14 -realWorldPrimIdKey = mkPreludeMiscIdUnique 15 -recConErrorIdKey = mkPreludeMiscIdUnique 16 +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 17 -unpackCStringAppendUtf8IdKey = mkPreludeMiscIdUnique 18 -unpackCStringFoldrUtf8IdKey = mkPreludeMiscIdUnique 19 +unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 18 +unpackCStringAppendUtf8IdKey = mkPreludeMiscIdUnique 19 +unpackCStringFoldrUtf8IdKey = mkPreludeMiscIdUnique 20 -unpackCStringIdKey = mkPreludeMiscIdUnique 20 -unpackCStringAppendIdKey = mkPreludeMiscIdUnique 21 -unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 22 +unpackCStringIdKey = mkPreludeMiscIdUnique 21 +unpackCStringAppendIdKey = mkPreludeMiscIdUnique 22 +unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 23 -voidPrimIdKey = mkPreludeMiscIdUnique 23 -typeErrorIdKey = mkPreludeMiscIdUnique 24 -divIntIdKey = mkPreludeMiscIdUnique 25 -modIntIdKey = mkPreludeMiscIdUnique 26 -cstringLengthIdKey = mkPreludeMiscIdUnique 27 -raiseOverflowIdKey = mkPreludeMiscIdUnique 28 -raiseUnderflowIdKey = mkPreludeMiscIdUnique 29 -raiseDivZeroIdKey = mkPreludeMiscIdUnique 30 +voidPrimIdKey = mkPreludeMiscIdUnique 24 +typeErrorIdKey = mkPreludeMiscIdUnique 25 +divIntIdKey = mkPreludeMiscIdUnique 26 +modIntIdKey = mkPreludeMiscIdUnique 27 +cstringLengthIdKey = mkPreludeMiscIdUnique 28 concatIdKey, filterIdKey, zipIdKey, bindIOIdKey, returnIOIdKey, newStablePtrIdKey, @@ -2333,17 +2359,20 @@ traceKey :: Unique traceKey = mkPreludeMiscIdUnique 108 -inlineIdKey, noinlineIdKey :: Unique +nospecIdKey :: Unique +nospecIdKey = mkPreludeMiscIdUnique 109 + +inlineIdKey, noinlineIdKey, noinlineConstraintIdKey :: Unique inlineIdKey = mkPreludeMiscIdUnique 120 -- see below -mapIdKey, groupWithIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique +mapIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique mapIdKey = mkPreludeMiscIdUnique 121 -groupWithIdKey = mkPreludeMiscIdUnique 122 dollarIdKey = mkPreludeMiscIdUnique 123 coercionTokenIdKey = mkPreludeMiscIdUnique 124 -noinlineIdKey = mkPreludeMiscIdUnique 125 -considerAccessibleIdKey = mkPreludeMiscIdUnique 126 +considerAccessibleIdKey = mkPreludeMiscIdUnique 125 +noinlineIdKey = mkPreludeMiscIdUnique 126 +noinlineConstraintIdKey = mkPreludeMiscIdUnique 127 integerToFloatIdKey, integerToDoubleIdKey, naturalToFloatIdKey, naturalToDoubleIdKey :: Unique integerToFloatIdKey = mkPreludeMiscIdUnique 128 @@ -2483,14 +2512,15 @@ trLiftedRepKey = mkPreludeMiscIdUnique 516 -- KindReps for common cases -starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique -starKindRepKey = mkPreludeMiscIdUnique 520 -starArrStarKindRepKey = mkPreludeMiscIdUnique 521 +starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey, constraintKindRepKey :: Unique +starKindRepKey = mkPreludeMiscIdUnique 520 +starArrStarKindRepKey = mkPreludeMiscIdUnique 521 starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522 +constraintKindRepKey = mkPreludeMiscIdUnique 523 -- Dynamic toDynIdKey :: Unique -toDynIdKey = mkPreludeMiscIdUnique 523 +toDynIdKey = mkPreludeMiscIdUnique 530 bitIntegerIdKey :: Unique @@ -2784,8 +2814,10 @@ [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey , liftedDataConKey, unliftedDataConKey , tYPETyConKey + , cONSTRAINTTyConKey , runtimeRepTyConKey, boxedRepDataConKey , eqTyConKey + , listTyConKey , oneDataConKey , manyDataConKey - , funTyConKey ] + , fUNTyConKey, unrestrictedFunTyConKey ] 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 @@ -10,7 +10,6 @@ import GHC.Builtin.Names( mk_known_key_name ) import GHC.Unit.Types -import GHC.Unit.Module.Name import GHC.Types.Name( Name ) import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName ) import GHC.Types.Name.Reader( RdrName, nameRdrName ) @@ -18,6 +17,8 @@ import GHC.Builtin.Uniques import GHC.Data.FastString +import Language.Haskell.Syntax.Module.Name + -- To add a name, do three things -- -- 1) Allocate a key @@ -31,7 +32,7 @@ templateHaskellNames = [ returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, - mkNameSName, + mkNameSName, mkNameQName, mkModNameName, liftStringName, unTypeName, unTypeCodeName, @@ -68,7 +69,7 @@ -- Stmt bindSName, letSName, noBindSName, parSName, recSName, -- Dec - funDName, valDName, dataDName, newtypeDName, tySynDName, + funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName, instanceWithOverlapDName, standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName, pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, @@ -215,7 +216,7 @@ returnQName, bindQName, sequenceQName, newNameName, liftName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName, - unsafeCodeCoerceName, liftTypedName, mkModNameName :: Name + unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name returnQName = thFun (fsLit "returnQ") returnQIdKey bindQName = thFun (fsLit "bindQ") bindQIdKey sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey @@ -227,6 +228,7 @@ mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey 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 @@ -353,7 +355,7 @@ recSName = libFun (fsLit "recS") recSIdKey -- data Dec = ... -funDName, valDName, dataDName, newtypeDName, tySynDName, classDName, +funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName, instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName, @@ -365,6 +367,7 @@ valDName = libFun (fsLit "valD") valDIdKey dataDName = libFun (fsLit "dataD") dataDIdKey newtypeDName = libFun (fsLit "newtypeD") newtypeDIdKey +typeDataDName = libFun (fsLit "typeDataD") typeDataDIdKey tySynDName = libFun (fsLit "tySynD") tySynDIdKey classDName = libFun (fsLit "classD") classDIdKey instanceWithOverlapDName = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey @@ -740,7 +743,7 @@ returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey, mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey, mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey, - unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique + unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique returnQIdKey = mkPreludeMiscIdUnique 200 bindQIdKey = mkPreludeMiscIdUnique 201 sequenceQIdKey = mkPreludeMiscIdUnique 202 @@ -757,6 +760,7 @@ liftTypedIdKey = mkPreludeMiscIdUnique 214 mkModNameIdKey = mkPreludeMiscIdUnique 215 unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216 +mkNameQIdKey = mkPreludeMiscIdUnique 217 -- data Lit = ... @@ -887,7 +891,7 @@ newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey, infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey, patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey, - kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey :: Unique + kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, typeDataDIdKey :: Unique funDIdKey = mkPreludeMiscIdUnique 320 valDIdKey = mkPreludeMiscIdUnique 321 dataDIdKey = mkPreludeMiscIdUnique 322 @@ -922,7 +926,8 @@ implicitParamBindDIdKey = mkPreludeMiscIdUnique 351 kiSigDIdKey = mkPreludeMiscIdUnique 352 defaultDIdKey = mkPreludeMiscIdUnique 353 -pragOpaqueDIdKey = mkPreludeMiscIdUnique 354 +pragOpaqueDIdKey = mkPreludeMiscIdUnique 354 +typeDataDIdKey = mkPreludeMiscIdUnique 355 -- type Cxt = ... cxtIdKey :: Unique diff --git a/GHC/Builtin/PrimOps.hs b/GHC/Builtin/PrimOps.hs --- a/GHC/Builtin/PrimOps.hs +++ b/GHC/Builtin/PrimOps.hs @@ -5,19 +5,21 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} module GHC.Builtin.PrimOps ( PrimOp(..), PrimOpVecCat(..), allThePrimOps, primOpType, primOpSig, primOpResultType, primOpTag, maxPrimOpTag, primOpOcc, primOpWrapperId, + pprPrimOp, tagToEnumKey, primOpOutOfLine, primOpCodeSize, primOpOkForSpeculation, primOpOkForSideEffects, primOpIsCheap, primOpFixity, primOpDocs, - primOpIsDiv, + primOpIsDiv, primOpIsReallyInline, getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..), @@ -325,8 +327,8 @@ never throw an exception, so we cannot rewrite to a call to error. 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/app invariant - (see Note [Core let/app invariant] in GHC.Core) which is critical to + 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. @@ -479,7 +481,7 @@ * 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/app invariant. And + exprOkForSpeculation; this is the let-can-float invariant. And exprOkForSpeculation is false of can_fail and has_side_effects. * So can_fail and has_side_effects primops will appear only as the @@ -658,7 +660,7 @@ GHC.ByteCode.Linker.primopToCLabel). TODO: Perhaps this should be changed? Note that these wrappers aren't *quite* as expressive as their unwrapped -breathren, in that they may exhibit less representation polymorphism. +brethren, in that they may exhibit less representation polymorphism. For instance, consider the case of mkWeakNoFinalizer#, which has type: mkWeakNoFinalizer# :: forall (r :: RuntimeRep) (k :: TYPE r) (v :: Type). @@ -788,8 +790,10 @@ -- Output stuff: -pprPrimOp :: PrimOp -> SDoc +pprPrimOp :: IsLine doc => PrimOp -> doc pprPrimOp other_op = pprOccName (primOpOcc other_op) +{-# SPECIALIZE pprPrimOp :: PrimOp -> SDoc #-} +{-# SPECIALIZE pprPrimOp :: PrimOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable {- ************************************************************************ @@ -804,3 +808,12 @@ instance Outputable PrimCall where ppr (PrimCall lbl pkgId) = 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 +-- hence induce thread/stack/heap changes. +primOpIsReallyInline :: PrimOp -> Bool +primOpIsReallyInline = \case + SeqOp -> False + DataToTagOp -> False + p -> not (primOpOutOfLine p) 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 @@ -9,7 +9,7 @@ -- primop rules are attached to primop ids import {-# SOURCE #-} GHC.Core.Opt.ConstantFold (primOpRules) -import GHC.Core.Type (mkForAllTys, mkVisFunTysMany) +import GHC.Core.Type (mkForAllTys, mkVisFunTysMany, argsHaveFixedRuntimeRep ) import GHC.Core.FVs (mkRuleInfo) import GHC.Builtin.PrimOps @@ -38,7 +38,8 @@ name = mkWiredInName gHC_PRIM (primOpOcc prim_op) (mkPrimOpIdUnique (primOpTag prim_op)) (AnId id) UserSyntax - id = mkGlobalId (PrimOpId prim_op) name ty info + id = mkGlobalId (PrimOpId prim_op lev_poly) name ty info + lev_poly = not (argsHaveFixedRuntimeRep ty) -- PrimOps don't ever construct a product, but we want to preserve bottoms cpr @@ -51,7 +52,6 @@ `setDmdSigInfo` strict_sig `setCprSigInfo` mkCprSig arity cpr `setInlinePragInfo` neverInlinePragma - `setLevityInfoWithType` res_ty -- We give PrimOps a NOINLINE pragma so that we don't -- get silly warnings from Desugar.dsRule (the inline_shadows_rule -- test) about a RULE conflicting with a possible inlining diff --git a/GHC/Builtin/Types.hs b/GHC/Builtin/Types.hs --- a/GHC/Builtin/Types.hs +++ b/GHC/Builtin/Types.hs @@ -18,7 +18,7 @@ mkWiredInIdName, -- used in GHC.Types.Id.Make -- * All wired in things - wiredInTyCons, isBuiltInOcc_maybe, + wiredInTyCons, isBuiltInOcc_maybe, isPunOcc_maybe, -- * Bool boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, @@ -34,7 +34,7 @@ promotedLTDataCon, promotedEQDataCon, promotedGTDataCon, -- * Boxing primitive types - boxingDataCon_maybe, + boxingDataCon, BoxingInfo(..), -- * Char charTyCon, charDataCon, charTyCon_RDR, @@ -63,10 +63,6 @@ promotedNilDataCon, promotedConsDataCon, mkListTy, mkPromotedListTy, - -- * NonEmpty - nonEmptyTyCon, nonEmptyTyConName, - nonEmptyDataCon, nonEmptyDataConName, - -- * Maybe maybeTyCon, maybeTyConName, nothingDataCon, nothingDataConName, promotedNothingDataCon, @@ -83,7 +79,7 @@ unboxedUnitTy, unboxedUnitTyCon, unboxedUnitDataCon, unboxedTupleKind, unboxedSumKind, - filterCTuple, + filterCTuple, mkConstraintTupleTy, -- ** Constraint tuples cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName, @@ -105,6 +101,8 @@ isLiftedTypeKindTyConName, typeToTypeKind, liftedRepTyCon, unliftedRepTyCon, + tYPETyCon, tYPETyConName, tYPEKind, + cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind, constraintKind, liftedTypeKind, unliftedTypeKind, zeroBitTypeKind, constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon, constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName, @@ -116,15 +114,17 @@ coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass, -- * RuntimeRep and friends - runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon, + runtimeRepTyCon, vecCountTyCon, vecElemTyCon, boxedRepDataConTyCon, - runtimeRepTy, levityTy, liftedRepTy, unliftedRepTy, zeroBitRepTy, + runtimeRepTy, liftedRepTy, unliftedRepTy, zeroBitRepTy, vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, + -- * Levity + levityTyCon, levityTy, liftedDataConTyCon, unliftedDataConTyCon, - liftedDataConTy, unliftedDataConTy, + liftedDataConTy, unliftedDataConTy, intRepDataConTy, int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, @@ -170,26 +170,32 @@ import GHC.Builtin.Uniques -- others: +import GHC.Core( Expr(Type), mkConApp ) import GHC.Core.Coercion.Axiom -import GHC.Types.Id -import GHC.Types.TyThing -import GHC.Types.SourceText -import GHC.Types.Var (VarBndr (Bndr)) -import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) -import GHC.Unit.Module ( Module ) import GHC.Core.Type -import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp)) -import GHC.Types.RepType +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 ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF ) +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 ) @@ -201,6 +207,7 @@ import qualified Data.ByteString.Char8 as BS +import Data.Foldable import Data.List ( elemIndex, intersperse ) alpha_tyvar :: [TyVar] @@ -273,7 +280,8 @@ -- See also Note [Known-key names] wiredInTyCons :: [TyCon] -wiredInTyCons = [ -- Units are not treated like other tuples, because they +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 @@ -281,7 +289,7 @@ unitTyCon , unboxedUnitTyCon - -- Solo (i.e., the bosed 1-tuple) is also not treated + -- 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 @@ -317,7 +325,6 @@ , unliftedRepTyCon , zeroBitRepTyCon , zeroBitTypeTyCon - , nonEmptyTyCon ] mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name @@ -372,14 +379,10 @@ trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon listTyConName, nilDataConName, consDataConName :: Name -listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon +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 -nonEmptyTyConName, nonEmptyDataConName :: Name -nonEmptyTyConName = mkWiredInTyConName UserSyntax gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey nonEmptyTyCon -nonEmptyDataConName = mkWiredInDataConName UserSyntax gHC_BASE (fsLit ":|") nonEmptyDataConKey nonEmptyDataCon - maybeTyConName, nothingDataConName, justDataConName :: Name maybeTyConName = mkWiredInTyConName UserSyntax gHC_MAYBE (fsLit "Maybe") maybeTyConKey maybeTyCon @@ -508,81 +511,7 @@ typeSymbolKindConName :: Name typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon -constraintKindTyConName :: Name -constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon -liftedTypeKindTyConName, unliftedTypeKindTyConName, zeroBitTypeTyConName :: Name -liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon -unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType") unliftedTypeKindTyConKey unliftedTypeKindTyCon -zeroBitTypeTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType") zeroBitTypeTyConKey zeroBitTypeTyCon - -liftedRepTyConName, unliftedRepTyConName, zeroBitRepTyConName :: Name -liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep") liftedRepTyConKey liftedRepTyCon -unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep") unliftedRepTyConKey unliftedRepTyCon -zeroBitRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep") zeroBitRepTyConKey zeroBitRepTyCon - -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 - -runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name -runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon -vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon -tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon -sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon -boxedRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon - -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 - - --- See Note [Wiring in RuntimeRep] -runtimeRepSimpleDataConNames :: [Name] -runtimeRepSimpleDataConNames - = zipWith3Lazy mk_special_dc_name - [ fsLit "IntRep" - , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep" - , fsLit "WordRep" - , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep" - , fsLit "AddrRep" - , fsLit "FloatRep", fsLit "DoubleRep" - ] - runtimeRepSimpleDataConKeys - runtimeRepSimpleDataCons - -vecCountTyConName :: Name -vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon - --- See Note [Wiring in RuntimeRep] -vecCountDataConNames :: [Name] -vecCountDataConNames = zipWith3Lazy mk_special_dc_name - [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8" - , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ] - vecCountDataConKeys - vecCountDataCons - -vecElemTyConName :: Name -vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon - --- See Note [Wiring in RuntimeRep] -vecElemDataConNames :: [Name] -vecElemDataConNames = zipWith3Lazy mk_special_dc_name - [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep" - , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep" - , fsLit "Word32ElemRep", fsLit "Word64ElemRep" - , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] - vecElemDataConKeys - vecElemDataCons - -mk_special_dc_name :: FastString -> Unique -> DataCon -> Name -mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc - boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR, intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName boolTyCon_RDR = nameRdrName boolTyConName @@ -608,7 +537,7 @@ pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon pcTyCon name cType tyvars cons = mkAlgTyCon name - (mkAnonTyConBinders VisArg tyvars) + (mkAnonTyConBinders tyvars) liftedTypeKind (map (const Representational) tyvars) cType @@ -618,24 +547,41 @@ False -- Not in GADT syntax pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon -pcDataCon n univs tys = pcDataConW n univs (map linear tys) - -pcDataConW :: Name -> [TyVar] -> [Scaled Type] -> TyCon -> DataCon -pcDataConW n univs tys = pcDataConWithFixity False n univs +pcDataCon n univs tys + = pcDataConWithFixity False n univs [] -- no ex_tvs univs -- the univs are precisely the user-written tyvars - tys + [] -- 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)) - NoRRI +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" @@ -643,9 +589,9 @@ -- To support this the mkPreludeDataConUnique function "allocates" -- one DataCon unique per pair of Ints. -pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo +pcDataConWithFixity' :: Bool -> Name -> Unique -> PromDataConInfo -> [TyVar] -> [TyCoVar] -> [TyCoVar] - -> [Scaled Type] -> TyCon -> DataCon + -> ThetaType -> [Scaled Type] -> TyCon -> DataCon -- The Name should be in the DataName name space; it's the name -- of the DataCon itself. -- @@ -657,7 +603,7 @@ -- to regret doing so (we do). pcDataConWithFixity' declared_infix dc_name wrk_key rri - tyvars ex_tyvars user_tyvars arg_tys tycon + tyvars ex_tyvars user_tyvars theta arg_tys tycon = data_con where tag_map = mkTyConTagMap tycon @@ -673,7 +619,7 @@ tyvars ex_tyvars (mkTyVarBinders SpecifiedSpec user_tyvars) [] -- No equality spec - [] -- No theta + theta arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) rri tycon @@ -699,16 +645,11 @@ dc_occ = nameOccName dc_name wrk_occ = mkDataConWorkerOcc dc_occ --- used for RuntimeRep and friends -pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon -pcSpecialDataCon dc_name arg_tys tycon rri - = pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri - [] [] [] (map linear arg_tys) tycon {- ************************************************************************ * * - Kinds + Symbol * * ************************************************************************ -} @@ -720,14 +661,7 @@ typeSymbolKind :: Kind typeSymbolKind = mkTyConTy typeSymbolKindCon -constraintKindTyCon :: TyCon --- 'TyCon.isConstraintKindCon' assumes that this is an AlgTyCon! -constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] -typeToTypeKind, constraintKind :: Kind -typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind -constraintKind = mkTyConTy constraintKindTyCon - {- ************************************************************************ * * @@ -808,7 +742,7 @@ 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 = Solo a + 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. @@ -831,7 +765,7 @@ -- Wrinkle: Make boxed one-tuple names have known keys ----- -We make boxed one-tuple names have known keys so that `data Solo a = Solo a`, +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: @@ -867,7 +801,7 @@ ":" -> Just consDataConName -- function tycon - "FUN" -> Just funTyConName + "FUN" -> Just fUNTyConName "->" -> Just unrestrictedFunTyConName -- boxed tuple data/tycon @@ -925,22 +859,38 @@ = 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 ar) +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 -> Arity -> String +mkTupleStr :: Boxity -> NameSpace -> Arity -> String mkTupleStr Boxed = mkBoxedTupleStr -mkTupleStr Unboxed = mkUnboxedTupleStr +mkTupleStr Unboxed = const mkUnboxedTupleStr -mkBoxedTupleStr :: Arity -> String -mkBoxedTupleStr 0 = "()" -mkBoxedTupleStr 1 = "Solo" -- See Note [One-tuples] -mkBoxedTupleStr ar = '(' : commas ar ++ ")" +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 = "(##)" @@ -1088,12 +1038,11 @@ mk_tuple :: Boxity -> Int -> (TyCon,DataCon) mk_tuple Boxed arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con BoxedTuple flavour tc_binders = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind) tc_res_kind = liftedTypeKind - tc_arity = arity flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) dc_tvs = binderVars tc_binders @@ -1101,7 +1050,7 @@ tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon boxity = Boxed - modu = gHC_TUPLE + 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 @@ -1111,7 +1060,7 @@ mk_tuple Unboxed arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con UnboxedTuple flavour -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon @@ -1120,8 +1069,6 @@ (\ks -> map mkTYPEapp ks) tc_res_kind = unboxedTupleKind rr_tys - - tc_arity = arity * 2 flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) dc_tvs = binderVars tc_binders @@ -1145,7 +1092,7 @@ (mkPrelTyConRepName tc_name) klass = mk_ctuple_class tycon sc_theta sc_sel_ids - tuple_con = pcDataConW dc_name tvs (map unrestricted sc_theta) tycon + tuple_con = pcDataConConstraint dc_name tvs sc_theta tycon binders = mkTemplateAnonTyConBinders (replicate arity constraintKind) roles = replicate arity Nominal @@ -1203,7 +1150,6 @@ unboxedUnitDataCon :: DataCon unboxedUnitDataCon = tupleDataCon Unboxed 0 - {- ********************************************************************* * * Unboxed sums @@ -1275,7 +1221,7 @@ mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon) mk_sum arity = (tycon, sum_cons) where - tycon = mkSumTyCon tc_name tc_binders tc_res_kind (arity * 2) tyvars (elems sum_cons) + tycon = mkSumTyCon tc_name tc_binders tc_res_kind (elems sum_cons) UnboxedSumTyCon tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) @@ -1332,7 +1278,7 @@ rhs klass (mkPrelTyConRepName eqTyConName) klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataConW eqDataConName tvs [unrestricted sc_pred] tycon + datacon = pcDataConConstraint eqDataConName tvs [sc_pred] tycon -- Kind: forall k. k -> k -> Constraint binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) @@ -1350,7 +1296,7 @@ rhs klass (mkPrelTyConRepName heqTyConName) klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataConW heqDataConName tvs [unrestricted sc_pred] tycon + datacon = pcDataConConstraint heqDataConName tvs [sc_pred] tycon -- Kind: forall k1 k2. k1 -> k2 -> Constraint binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id @@ -1368,7 +1314,7 @@ rhs klass (mkPrelTyConRepName coercibleTyConName) klass = mk_class tycon sc_pred sc_sel_id - datacon = pcDataConW coercibleDataConName tvs [unrestricted sc_pred] tycon + datacon = pcDataConConstraint coercibleDataConName tvs [sc_pred] tycon -- Kind: forall k. k -> k -> Constraint binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) @@ -1402,12 +1348,20 @@ 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] oneDataCon, manyDataCon :: DataCon oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon @@ -1433,19 +1387,21 @@ where binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy] -unrestrictedFunTy :: Type -unrestrictedFunTy = functionWithMultiplicity manyDataConTy - +------------------------ +-- type (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). +-- TYPE rep1 -> TYPE rep2 -> Type +-- type (->) = FUN 'Many unrestrictedFunTyCon :: TyCon -unrestrictedFunTyCon = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] unrestrictedFunTy - where arrowKind = mkTyConKind binders liftedTypeKind - -- See also funTyCon - binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred) - , Bndr runtimeRep2TyVar (NamedTCB Inferred) - ] - ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty - , mkTYPEapp runtimeRep2Ty - ] +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 "->") @@ -1456,91 +1412,94 @@ * * Type synonyms (all declared in ghc-prim:GHC.Types) - type Type = TYPE LiftedRep -- liftedTypeKind - type UnliftedType = TYPE UnliftedRep -- unliftedTypeKind - type LiftedRep = BoxedRep Lifted -- liftedRepTy - type UnliftedRep = BoxedRep Unlifted -- unliftedRepTy + 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 RuntimeRep] in GHC.Builtin.Types.Prim, and +-- 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 Type = TYPE ('BoxedRep 'Lifted)@ +-- 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] -liftedTypeKind :: Type +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)@ +-- 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 ----------------------- --- @type ZeroBitType = TYPE ZeroBitRep -zeroBitTypeTyCon :: TyCon -zeroBitTypeTyCon - = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs - where - rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy] -zeroBitTypeKind :: Type -zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon - ----------------------- --- | @type LiftedRep = 'BoxedRep 'Lifted@ -liftedRepTyCon :: TyCon -liftedRepTyCon - = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs - where - rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy] - -liftedRepTy :: Type -liftedRepTy = mkTyConTy liftedRepTyCon - ----------------------- --- | @type UnliftedRep = 'BoxedRep 'Unlifted@ -unliftedRepTyCon :: TyCon -unliftedRepTyCon - = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs - where - rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy] - -unliftedRepTy :: Type -unliftedRepTy = mkTyConTy unliftedRepTyCon - ----------------------- --- | @type ZeroBitRep = 'Tuple '[] -zeroBitRepTyCon :: TyCon -zeroBitRepTyCon - = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs - where - rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] - -zeroBitRepTy :: Type -zeroBitRepTy = mkTyConTy zeroBitRepTyCon - - {- ********************************************************************* * * 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] @@ -1549,9 +1508,9 @@ liftedDataCon, unliftedDataCon :: DataCon liftedDataCon = pcSpecialDataCon liftedDataConName - [] levityTyCon LiftedInfo + [] levityTyCon (Levity Lifted) unliftedDataCon = pcSpecialDataCon unliftedDataConName - [] levityTyCon UnliftedInfo + [] levityTyCon (Levity Unlifted) liftedDataConTyCon :: TyCon liftedDataConTyCon = promoteDataCon liftedDataCon @@ -1591,21 +1550,35 @@ runtimeRepTyCon :: TyCon runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] + -- Here we list all the data constructors + -- of the RuntimeRep data type (vecRepDataCon : tupleRepDataCon : - sumRepDataCon : boxedRepDataCon : runtimeRepSimpleDataCons) + 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 tyConRuntimeRepInfo (tyConAppTyCon lev) of - LiftedInfo -> [LiftedRep] - UnliftedInfo -> [UnliftedRep] + = case tyConPromDataConInfo (tyConAppTyCon lev) of + Levity Lifted -> [LiftedRep] + Levity Unlifted -> [UnliftedRep] _ -> pprPanic "boxedRepDataCon" (ppr lev) prim_rep_fun args = pprPanic "boxedRepDataCon" (ppr args) @@ -1614,23 +1587,6 @@ boxedRepDataConTyCon :: TyCon boxedRepDataConTyCon = promoteDataCon boxedRepDataCon -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 <- tyConRuntimeRepInfo (tyConAppTyCon count) - , VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem) - = [VecRep n e] - prim_rep_fun args - = pprPanic "vecRepDataCon" (ppr args) - -vecRepDataConTyCon :: TyCon -vecRepDataConTyCon = promoteDataCon vecRepDataCon - tupleRepDataCon :: DataCon tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun) @@ -1653,7 +1609,7 @@ where -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType prim_rep_fun [rr_ty_list] - = map slotPrimRep (ubxSumRepType prim_repss) + = map slotPrimRep (toList (ubxSumRepType prim_repss)) where rr_tys = extractPromotedList rr_ty_list doc = text "sumRepDataCon" <+> ppr rr_tys @@ -1668,18 +1624,27 @@ -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType runtimeRepSimpleDataCons :: [DataCon] runtimeRepSimpleDataCons - = zipWithLazy mk_runtime_rep_dc - [ IntRep - , Int8Rep, Int16Rep, Int32Rep, Int64Rep - , WordRep - , Word8Rep, Word16Rep, Word32Rep, Word64Rep - , AddrRep - , FloatRep, DoubleRep - ] - runtimeRepSimpleDataConNames + = 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 primrep name - = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) + 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, @@ -1687,7 +1652,7 @@ wordRepDataConTy, word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy :: Type + floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType [intRepDataConTy, int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy, wordRepDataConTy, @@ -1697,17 +1662,108 @@ ] = 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 = zipWithLazy mk_vec_count_dc - [ 2, 4, 8, 16, 32, 64 ] - vecCountDataConNames +vecCountDataCons = zipWith mk_vec_count_dc [1..6] vecCountDataConKeys where - mk_vec_count_dc n name - = pcSpecialDataCon name [] vecCountTyCon (VecCount n) + 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, @@ -1720,14 +1776,19 @@ -- See Note [Wiring in RuntimeRep] vecElemDataCons :: [DataCon] -vecElemDataCons = zipWithLazy mk_vec_elem_dc - [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep - , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep - , FloatElemRep, DoubleElemRep ] - vecElemDataConNames +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 elem name - = pcSpecialDataCon name [] vecElemTyCon (VecElem elem) + 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, @@ -1746,30 +1807,6 @@ * * ********************************************************************* -} -boxingDataCon_maybe :: TyCon -> Maybe DataCon --- boxingDataCon_maybe Char# = C# --- boxingDataCon_maybe Int# = I# --- ... etc ... --- See Note [Boxing primitive types] -boxingDataCon_maybe tc - = lookupNameEnv boxing_constr_env (tyConName tc) - -boxing_constr_env :: NameEnv DataCon -boxing_constr_env - = mkNameEnv [(charPrimTyConName , charDataCon ) - ,(intPrimTyConName , intDataCon ) - ,(wordPrimTyConName , wordDataCon ) - ,(floatPrimTyConName , floatDataCon ) - ,(doublePrimTyConName, doubleDataCon) ] - -{- Note [Boxing primitive types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a handful of primitive types (Int, Char, Word, Float, Double), -we can readily box and an unboxed version (Int#, Char# etc) using -the corresponding data constructor. This is useful in a couple -of places, notably let-floating -} - - charTy :: Type charTy = mkTyConTy charTyCon @@ -1846,6 +1883,140 @@ 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 + {- ************************************************************************ * * @@ -1952,23 +2123,14 @@ consDataCon :: DataCon consDataCon = pcDataConWithFixity True {- Declared infix -} consDataConName - alpha_tyvar [] alpha_tyvar - (map linear [alphaTy, mkTyConApp listTyCon alpha_ty]) listTyCon + 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) --- NonEmpty lists (used for 'ProjectionE') -nonEmptyTyCon :: TyCon -nonEmptyTyCon = pcTyCon nonEmptyTyConName Nothing [alphaTyVar] [nonEmptyDataCon] - -nonEmptyDataCon :: DataCon -nonEmptyDataCon = pcDataConWithFixity True {- Declared infix -} - nonEmptyDataConName - alpha_tyvar [] alpha_tyvar - (map linear [alphaTy, mkTyConApp listTyCon alpha_ty]) - nonEmptyTyCon - -- Wired-in type Maybe maybeTyCon :: TyCon @@ -2058,7 +2220,7 @@ 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) + (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]. @@ -2067,6 +2229,18 @@ 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 + {- ********************************************************************* * * 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 @@ -1,7 +1,7 @@ module GHC.Builtin.Types where import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) -import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind) +import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, RuntimeRepType) import {-# SOURCE #-} GHC.Core.DataCon ( DataCon ) import GHC.Types.Basic (Arity, TupleSort, Boxity, ConTag) @@ -16,8 +16,8 @@ unitTy :: Type - liftedTypeKindTyConName :: Name +constraintKindTyConName :: Name liftedTypeKind, unliftedTypeKind, zeroBitTypeKind :: Kind @@ -33,7 +33,7 @@ boxedRepDataConTyCon, liftedDataConTyCon :: TyCon vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon -liftedRepTy, unliftedRepTy, zeroBitRepTy :: Type +liftedRepTy, unliftedRepTy, zeroBitRepTy :: RuntimeRepType liftedDataConTy, unliftedDataConTy :: Type intRepDataConTy, @@ -41,7 +41,7 @@ wordRepDataConTy, word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy, addrRepDataConTy, - floatRepDataConTy, doubleRepDataConTy :: Type + floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, vec64DataConTy :: Type @@ -64,7 +64,7 @@ multMulTyCon :: TyCon tupleTyConName :: TupleSort -> Arity -> Name - +tupleDataConName :: Boxity -> Arity -> Name integerTy, naturalTy :: Type 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 @@ -29,12 +29,12 @@ import GHC.Core.Type import GHC.Data.Pair -import GHC.Tc.Utils.TcType ( TcType, tcEqType ) 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 @@ -630,7 +630,7 @@ | tc1 == promotedGTDataCon -> return GT | otherwise -> Nothing -known :: (Integer -> Bool) -> TcType -> Bool +known :: (Integer -> Bool) -> Type -> Bool known p x = case isNumLitTy x of Just a -> p a Nothing -> False 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 @@ -30,6 +30,8 @@ levity1TyVarInf, levity2TyVarInf, levity1Ty, levity2Ty, + alphaConstraintTyVar, alphaConstraintTy, + openAlphaTyVar, openBetaTyVar, openGammaTyVar, openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec, openAlphaTy, openBetaTy, openGammaTy, @@ -41,13 +43,16 @@ multiplicityTyVar1, multiplicityTyVar2, -- Kind constructors... - tYPETyCon, tYPETyConName, + tYPETyCon, tYPETyConName, tYPEKind, + cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind, - -- Kinds - mkTYPEapp, + -- Arrows + funTyFlagTyCon, isArrowTyCon, + fUNTyCon, fUNTyConName, + ctArrowTyCon, ctArrowTyConName, + ccArrowTyCon, ccArrowTyConName, + tcArrowTyCon, tcArrowTyConName, - functionWithMultiplicity, - funTyCon, funTyConName, unexposedPrimTyCons, exposedPrimTyCons, primTyCons, charPrimTyCon, charPrimTy, charPrimTyConName, @@ -80,6 +85,7 @@ weakPrimTyCon, mkWeakPrimTy, threadIdPrimTyCon, threadIdPrimTy, stackSnapshotPrimTyCon, stackSnapshotPrimTy, + promptTagPrimTyCon, mkPromptTagPrimTy, int8PrimTyCon, int8PrimTy, int8PrimTyConName, word8PrimTyCon, word8PrimTy, word8PrimTyConName, @@ -105,7 +111,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types - ( runtimeRepTy, levityTy, unboxedTupleKind, liftedTypeKind + ( runtimeRepTy, levityTy, unboxedTupleKind, liftedTypeKind, unliftedTypeKind , boxedRepDataConTyCon, vecRepDataConTyCon , liftedRepTy, unliftedRepTy, zeroBitRepTy , intRepDataConTy @@ -120,45 +126,134 @@ , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy , doubleElemRepDataConTy - , multiplicityTy ) + , multiplicityTy + , constraintKind ) -import GHC.Types.Var ( TyVarBinder, TyVar +import {-# SOURCE #-} GHC.Types.TyThing( mkATyCon ) +import {-# SOURCE #-} GHC.Core.Type ( mkTyConApp, getLevity ) + +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid + -- import loops which show up if you import Type instead + +import GHC.Types.Var ( TyVarBinder, TyVar,binderVar, binderVars , mkTyVar, mkTyVarBinder, mkTyVarBinders ) import GHC.Types.Name -import {-# SOURCE #-} GHC.Types.TyThing -import GHC.Core.TyCon import GHC.Types.SrcLoc import GHC.Types.Unique + import GHC.Builtin.Uniques import GHC.Builtin.Names -import GHC.Data.FastString import GHC.Utils.Misc ( changeLast ) -import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid - -- import loops which show up if you import Type instead -import {-# SOURCE #-} GHC.Core.Type ( mkTyConTy, mkTyConApp, mkTYPEapp, getLevity ) +import GHC.Utils.Panic ( assertPpr ) +import GHC.Utils.Outputable +import GHC.Data.FastString import Data.Char -{- -************************************************************************ +{- ********************************************************************* * * -\subsection{Primitive type constructors} + Building blocks * * -************************************************************************ +********************************************************************* -} + +mk_TYPE_app :: Type -> Type +mk_TYPE_app rep = mkTyConApp tYPETyCon [rep] + +mk_CONSTRAINT_app :: Type -> Type +mk_CONSTRAINT_app rep = mkTyConApp cONSTRAINTTyCon [rep] + +mkPrimTc :: FastString -> Unique -> TyCon -> Name +mkPrimTc = mkGenPrimTc UserSyntax + +mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name +mkBuiltInPrimTc = mkGenPrimTc BuiltInSyntax + +mkGenPrimTc :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name +mkGenPrimTc built_in_syntax occ key tycon + = mkWiredInName gHC_PRIM (mkTcOccFS occ) + key + (mkATyCon tycon) + built_in_syntax + +-- | Create a primitive 'TyCon' with the given 'Name', +-- arguments of kind 'Type` with the given 'Role's, +-- and the given result kind representation. +-- +-- Only use this in "GHC.Builtin.Types.Prim". +pcPrimTyCon :: Name + -> [Role] -> RuntimeRepType -> TyCon +pcPrimTyCon name roles res_rep + = mkPrimTyCon name binders result_kind roles + where + bndr_kis = liftedTypeKind <$ roles + binders = mkTemplateAnonTyConBinders bndr_kis + result_kind = mk_TYPE_app res_rep + +-- | Create a primitive nullary 'TyCon' with the given 'Name' +-- and result kind representation. +-- +-- Only use this in "GHC.Builtin.Types.Prim". +pcPrimTyCon0 :: Name -> RuntimeRepType -> TyCon +pcPrimTyCon0 name res_rep + = pcPrimTyCon name [] res_rep + +-- | Create a primitive 'TyCon' like 'pcPrimTyCon', except the last +-- argument is levity-polymorphic, where the levity argument is +-- implicit and comes before other arguments +-- +-- Only use this in "GHC.Builtin.Types.Prim". +pcPrimTyCon_LevPolyLastArg :: Name + -> [Role] -- ^ roles of the arguments (must be non-empty), + -- not including the implicit argument of kind 'Levity', + -- which always has 'Nominal' role + -> RuntimeRepType -- ^ representation of the fully-applied type + -> TyCon +pcPrimTyCon_LevPolyLastArg name roles res_rep + = mkPrimTyCon name binders result_kind (Nominal : roles) + where + result_kind = mk_TYPE_app res_rep + lev_bndr = mkNamedTyConBinder Inferred levity1TyVar + binders = lev_bndr : mkTemplateAnonTyConBinders anon_bndr_kis + lev_tv = mkTyVarTy (binderVar lev_bndr) + + -- [ Type, ..., Type, TYPE (BoxedRep l) ] + anon_bndr_kis = changeLast (liftedTypeKind <$ roles) $ + mk_TYPE_app $ + mkTyConApp boxedRepDataConTyCon [lev_tv] + + +{- ********************************************************************* +* * + Primitive type constructors +* * +********************************************************************* -} + +{- Note Note [Unexposed TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A few primitive TyCons are "unexposed", meaning: +* We don't want users to be able to write them (see #15209); + i.e. they aren't in scope, ever. In particular they do not + appear in the exports of GHC.Prim: see GHC.Builtin.Utils.ghcPrimExports + +* We don't want users to see them in GHCi's @:browse@ output (see #12023). -} primTyCons :: [TyCon] primTyCons = unexposedPrimTyCons ++ exposedPrimTyCons --- | Primitive 'TyCon's that are defined in GHC.Prim but not exposed. --- It's important to keep these separate as we don't want users to be able to --- write them (see #15209) or see them in GHCi's @:browse@ output --- (see #12023). +-- | Primitive 'TyCon's that are defined in GHC.Prim but not "exposed". +-- See Note [Unexposed TyCons] unexposedPrimTyCons :: [TyCon] unexposedPrimTyCons - = [ eqPrimTyCon - , eqReprPrimTyCon - , eqPhantPrimTyCon + = [ eqPrimTyCon -- (~#) + , eqReprPrimTyCon -- (~R#) + , eqPhantPrimTyCon -- (~P#) + + -- These arrows are un-exposed for now + , ctArrowTyCon -- (=>) + , ccArrowTyCon -- (==>) + , tcArrowTyCon -- (-=>) ] -- | Primitive 'TyCon's that are defined in, and exported from, GHC.Prim. @@ -198,28 +293,15 @@ , word32PrimTyCon , word64PrimTyCon , stackSnapshotPrimTyCon + , promptTagPrimTyCon + , fUNTyCon , tYPETyCon - , funTyCon + , cONSTRAINTTyCon #include "primop-vector-tycons.hs-incl" ] -mkPrimTc :: FastString -> Unique -> TyCon -> Name -mkPrimTc fs unique tycon - = mkWiredInName gHC_PRIM (mkTcOccFS fs) - unique - (mkATyCon tycon) -- Relevant TyCon - UserSyntax - -mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name -mkBuiltInPrimTc fs unique tycon - = mkWiredInName gHC_PRIM (mkTcOccFS fs) - unique - (mkATyCon tycon) -- Relevant TyCon - BuiltInSyntax - - charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, @@ -231,7 +313,7 @@ stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, - stackSnapshotPrimTyConName :: Name + stackSnapshotPrimTyConName, promptTagPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int8PrimTyConName = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon @@ -269,14 +351,15 @@ bcoPrimTyConName = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon +promptTagPrimTyConName = mkPrimTc (fsLit "PromptTag#") promptTagPrimTyConKey promptTagPrimTyCon -{- -************************************************************************ +{- ********************************************************************* * * -\subsection{Support code} + Type variables * * -************************************************************************ +********************************************************************* -} +{- alphaTyVars is a list of type variables for use in templates: ["a", "b", ..., "z", "t1", "t2", ... ] -} @@ -363,13 +446,16 @@ mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder] -- Makes named, Specified binders -mkTemplateKindTyConBinders kinds = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds] +mkTemplateKindTyConBinders kinds + = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds] mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder] -mkTemplateAnonTyConBinders kinds = mkAnonTyConBinders VisArg (mkTemplateTyVars kinds) +mkTemplateAnonTyConBinders kinds + = mkAnonTyConBinders (mkTemplateTyVars kinds) mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder] -mkTemplateAnonTyConBindersFrom n kinds = mkAnonTyConBinders VisArg (mkTemplateTyVarsFrom n kinds) +mkTemplateAnonTyConBindersFrom n kinds + = mkAnonTyConBinders (mkTemplateTyVarsFrom n kinds) alphaTyVars :: [TyVar] alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind @@ -380,13 +466,22 @@ alphaTyVarSpec, betaTyVarSpec, gammaTyVarSpec, deltaTyVarSpec :: TyVarBinder (alphaTyVarSpec:betaTyVarSpec:gammaTyVarSpec:deltaTyVarSpec:_) = mkTyVarBinders Specified alphaTyVars +alphaConstraintTyVars :: [TyVar] +alphaConstraintTyVars = mkTemplateTyVars $ repeat constraintKind + +alphaConstraintTyVar :: TyVar +(alphaConstraintTyVar:_) = alphaConstraintTyVars + +alphaConstraintTy :: Type +alphaConstraintTy = mkTyVarTy alphaConstraintTyVar + alphaTys :: [Type] alphaTys = mkTyVarTys alphaTyVars alphaTy, betaTy, gammaTy, deltaTy :: Type (alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys alphaTyVarsUnliftedRep :: [TyVar] -alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (mkTYPEapp unliftedRepTy) +alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat unliftedTypeKind alphaTyVarUnliftedRep :: TyVar (alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep @@ -404,7 +499,7 @@ runtimeRep1TyVarInf = mkTyVarBinder Inferred runtimeRep1TyVar runtimeRep2TyVarInf = mkTyVarBinder Inferred runtimeRep2TyVar -runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty :: Type +runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty :: RuntimeRepType runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar runtimeRep3Ty = mkTyVarTy runtimeRep3TyVar @@ -413,7 +508,9 @@ -- beta :: TYPE r2 -- gamma :: TYPE r3 [openAlphaTyVar,openBetaTyVar,openGammaTyVar] - = mkTemplateTyVars [mkTYPEapp runtimeRep1Ty, mkTYPEapp runtimeRep2Ty, mkTYPEapp runtimeRep3Ty] + = mkTemplateTyVars [ mk_TYPE_app runtimeRep1Ty + , mk_TYPE_app runtimeRep2Ty + , mk_TYPE_app runtimeRep3Ty] openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec :: TyVarBinder openAlphaTyVarSpec = mkTyVarBinder Specified openAlphaTyVar @@ -442,8 +539,8 @@ levPolyAlphaTyVar, levPolyBetaTyVar :: TyVar [levPolyAlphaTyVar, levPolyBetaTyVar] = mkTemplateTyVars - [mkTYPEapp (mkTyConApp boxedRepDataConTyCon [levity1Ty]) - ,mkTYPEapp (mkTyConApp boxedRepDataConTyCon [levity2Ty])] + [ mk_TYPE_app (mkTyConApp boxedRepDataConTyCon [levity1Ty]) + , mk_TYPE_app (mkTyConApp boxedRepDataConTyCon [levity2Ty])] -- alpha :: TYPE ('BoxedRep l) -- beta :: TYPE ('BoxedRep k) @@ -468,80 +565,280 @@ ************************************************************************ -} -funTyConName :: Name -funTyConName = mkPrimTcName UserSyntax (fsLit "FUN") funTyConKey funTyCon +{- Note [Function type constructors and FunTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have four distinct function type constructors, and a type synonym + FUN :: forall (m :: Multiplicity) -> + forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. + TYPE rep1 -> TYPE rep2 -> Type + + (=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. + CONSTRAINT rep1 -> TYPE rep2 -> Type + + (==>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. + CONSTRAINT rep1 -> CONSTRAINT rep2 -> Constraint + + (-=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. + TYPE rep1 -> CONSTRAINT rep2 -> Constraint + + type (->) = FUN Many + +For efficiency, all four are always represented by + FunTy { ft_af :: FunTyFlag, ft_mult :: Mult + , ft_arg :: Type, ft_res :: Type } +rather than by using a TyConApp. + +* The four TyCons FUN, (=>), (==>), (-=>) are all wired in. + But (->) is just a regular synonym, with no special treatment; + in particular it is not wired-in. + +* The ft_af :: FunTyFlag distinguishes the four cases. + See Note [FunTyFlag] in GHC.Types.Var. + +* The ft_af field is redundant: it can always be gleaned from + the kinds of ft_arg and ft_res. See Note [FunTyFlag] in GHC.Types.Var. + +* The ft_mult :: Mult field gives the first argument for FUN + For the other three cases ft_mult is redundant; it is always Many. + Note that of the four type constructors, only `FUN` takes a Multiplicity. + +* Functions in GHC.Core.Type help to build and decompose `FunTy`. + * funTyConAppTy_maybe + * funTyFlagTyCon + * tyConAppFun_maybe + * splitFunTy_maybe + Use them! +-} + +funTyFlagTyCon :: FunTyFlag -> TyCon +-- `anonArgTyCon af` gets the TyCon that corresponds to the `FunTyFlag` +-- But be careful: fUNTyCon has a different kind to the others! +-- See Note [Function type constructors and FunTy] +funTyFlagTyCon FTF_T_T = fUNTyCon +funTyFlagTyCon FTF_T_C = tcArrowTyCon +funTyFlagTyCon FTF_C_T = ctArrowTyCon +funTyFlagTyCon FTF_C_C = ccArrowTyCon + +isArrowTyCon :: TyCon -> Bool +-- We don't bother to look for plain (->), because this function +-- should only be used after unwrapping synonyms +isArrowTyCon tc + = assertPpr (not (isTypeSynonymTyCon tc)) (ppr tc) + getUnique tc `elem` + [fUNTyConKey, ctArrowTyConKey, ccArrowTyConKey, tcArrowTyConKey] + +fUNTyConName, ctArrowTyConName, ccArrowTyConName, tcArrowTyConName :: Name +fUNTyConName = mkPrimTc (fsLit "FUN") fUNTyConKey fUNTyCon +ctArrowTyConName = mkBuiltInPrimTc (fsLit "=>") ctArrowTyConKey ctArrowTyCon +ccArrowTyConName = mkBuiltInPrimTc (fsLit "==>") ccArrowTyConKey ccArrowTyCon +tcArrowTyConName = mkBuiltInPrimTc (fsLit "-=>") tcArrowTyConKey tcArrowTyCon + -- | The @FUN@ type constructor. -- -- @ -- FUN :: forall (m :: Multiplicity) -> -- forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. --- TYPE rep1 -> TYPE rep2 -> * +-- TYPE rep1 -> TYPE rep2 -> Type -- @ -- -- The runtime representations quantification is left inferred. This -- means they cannot be specified with @-XTypeApplications@. -- -- This is a deliberate choice to allow future extensions to the --- function arrow. To allow visible application a type synonym can be --- defined: --- --- @ --- type Arr :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). --- TYPE rep1 -> TYPE rep2 -> Type --- type Arr = FUN 'Many --- @ --- -funTyCon :: TyCon -funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm +-- function arrow. +fUNTyCon :: TyCon +fUNTyCon = mkPrimTyCon fUNTyConName tc_bndrs liftedTypeKind tc_roles where -- See also unrestrictedFunTyCon tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar1 , mkNamedTyConBinder Inferred runtimeRep1TyVar , mkNamedTyConBinder Inferred runtimeRep2TyVar ] - ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty - , mkTYPEapp runtimeRep2Ty - ] - tc_rep_nm = mkPrelTyConRepName funTyConName + ++ mkTemplateAnonTyConBinders [ mk_TYPE_app runtimeRep1Ty + , mk_TYPE_app runtimeRep2Ty ] + tc_roles = [Nominal, Nominal, Nominal, Representational, Representational] +-- (=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. +-- CONSTRAINT rep1 -> TYPE rep2 -> Type +ctArrowTyCon :: TyCon +ctArrowTyCon = mkPrimTyCon ctArrowTyConName tc_bndrs liftedTypeKind tc_roles + where + -- See also unrestrictedFunTyCon + tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar + , mkNamedTyConBinder Inferred runtimeRep2TyVar ] + ++ mkTemplateAnonTyConBinders [ mk_CONSTRAINT_app runtimeRep1Ty + , mk_TYPE_app runtimeRep2Ty ] + tc_roles = [Nominal, Nominal, Representational, Representational] + +-- (==>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. +-- CONSTRAINT rep1 -> CONSTRAINT rep2 -> Constraint +ccArrowTyCon :: TyCon +ccArrowTyCon = mkPrimTyCon ccArrowTyConName tc_bndrs constraintKind tc_roles + where + -- See also unrestrictedFunTyCon + tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar + , mkNamedTyConBinder Inferred runtimeRep2TyVar ] + ++ mkTemplateAnonTyConBinders [ mk_CONSTRAINT_app runtimeRep1Ty + , mk_CONSTRAINT_app runtimeRep2Ty ] + tc_roles = [Nominal, Nominal, Representational, Representational] + +-- (-=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}. +-- TYPE rep1 -> CONSTRAINT rep2 -> Constraint +tcArrowTyCon :: TyCon +tcArrowTyCon = mkPrimTyCon tcArrowTyConName tc_bndrs constraintKind tc_roles + where + -- See also unrestrictedFunTyCon + tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar + , mkNamedTyConBinder Inferred runtimeRep2TyVar ] + ++ mkTemplateAnonTyConBinders [ mk_TYPE_app runtimeRep1Ty + , mk_CONSTRAINT_app runtimeRep2Ty ] + tc_roles = [Nominal, Nominal, Representational, Representational] + {- ************************************************************************ * * - Kinds + Type and Constraint * * ************************************************************************ -Note [TYPE and RuntimeRep] +Note [TYPE and CONSTRAINT] aka Note [Type vs Constraint] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -All types that classify values have a kind of the form (TYPE rr), where +GHC distinguishes Type from Constraint throughout the compiler. +See GHC Proposal #518, and tickets #21623 and #11715. - data RuntimeRep -- Defined in ghc-prim:GHC.Types +All types that classify values have a kind of the form + (TYPE rr) or (CONSTRAINT rr) +where the `RuntimeRep` parameter, rr, tells us how the value is represented +at runtime. TYPE and CONSTRAINT are primitive type constructors. + +See Note [RuntimeRep polymorphism] about the `rr` parameter. + +There are a bunch of type synonyms and data types defined in the +library ghc-prim:GHC.Types. All of them are also wired in to GHC, in +GHC.Builtin.Types + + type Constraint = CONSTRAINT LiftedRep :: Type + + type Type = TYPE LiftedRep :: Type + type UnliftedType = TYPE UnliftedRep :: Type + + type LiftedRep = BoxedRep Lifted :: RuntimeRep + type UnliftedRep = BoxedRep Unlifted :: RuntimeRep + + data RuntimeRep -- Defined in ghc-prim:GHC.Types = BoxedRep Levity | IntRep | FloatRep .. etc .. - data Levity = Lifted | Unlifted - - rr :: RuntimeRep + data Levity = Lifted | Unlifted - TYPE :: RuntimeRep -> TYPE 'LiftedRep -- Built in +We abbreviate '*' specially (with -XStarIsType), as if we had this: + type * = Type So for example: - Int :: TYPE ('BoxedRep 'Lifted) - Array# Int :: TYPE ('BoxedRep 'Unlifted) - Int# :: TYPE 'IntRep - Float# :: TYPE 'FloatRep - Maybe :: TYPE ('BoxedRep 'Lifted) -> TYPE ('BoxedRep 'Lifted) + Int :: TYPE (BoxedRep Lifted) + Array# Int :: TYPE (BoxedRep Unlifted) + Int# :: TYPE IntRep + Float# :: TYPE FloatRep + Maybe :: TYPE (BoxedRep Lifted) -> TYPE (BoxedRep Lifted) (# , #) :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2]) -We abbreviate '*' specially: - type LiftedRep = 'BoxedRep 'Lifted - type * = TYPE LiftedRep + Eq Int :: CONSTRAINT (BoxedRep Lifted) + IP "foo" Int :: CONSTRAINT (BoxedRep Lifted) + a ~ b :: CONSTRAINT (BoxedRep Lifted) + a ~# b :: CONSTRAINT (TupleRep []) -The 'rr' parameter tells us how the value is represented at runtime. +Constraints are mostly lifted, but unlifted ones are useful too. +Specifically (a ~# b) :: CONSTRAINT (TupleRep []) -Generally speaking, you can't be polymorphic in 'rr'. E.g +Wrinkles + +(W1) Type and Constraint are considered distinct throughout GHC. But they + 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]. + +(W3) We need a TypeOrConstraint flag in LitRubbish. + +Note [Type and Constraint are not apart] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type and Constraint are not equal (eqType) but they are not /apart/ +either. Reason (c.f. #7451): + +* We want to allow newtype classes, where + class C a where { op :: a -> a } + +* The axiom for such a class will look like + axiom axC a :: (C a :: Constraint) ~# (a->a :: Type) + +* This axiom connects a type of kind Type with one of kind Constraint + That is dangerous: kindCo (axC Int) :: Type ~N Constraint + And /that/ is bad because we could have + type family F a where + F Type = Int + F Constraint = Bool + So now we can prove Int ~N Bool, and all is lost. We prevent this + by saying that Type and Constraint are not Apart, which makes the + above type family instances illegal. + +So we ensure that Type and Constraint are not apart; or, more +precisely, that TYPE and CONSTRAINT are not apart. This +non-apart-ness check is implemented in GHC.Core.Unify.unify_ty: look +for `maybeApart MARTypeVsConstraint`. + +Note that, as before, nothing prevents writing instances like: + + instance C (Proxy @Type a) where ... + +In particular, TYPE and CONSTRAINT (and the synonyms Type, Constraint +etc) are all allowed in instance heads. It's just that TYPE is not +apart from CONSTRAINT, which means that the above instance would +irretrievably overlap with: + + instance C (Proxy @Constraint a) where ... + +Wrinkles + +(W1) In GHC.Core.RoughMap.roughMtchTyConName 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) + appears among the unifiables when we do the lookupRM' in + GHC.Core.FamInstEnv.lookup_fam_inst_env'. So for the RoughMap we + simply pretend that they are the same type constructor. If we + don't, we'll treat them as fully apart, which is unsound. + +(W2) We must extend this treatment to the different arrow types (see + Note [Function type constructors and FunTy]): if we have + FunCo (axC Int) :: (C Int => Int) ~ ((Int -> Int) -> Int), + then we could extract an equality between (=>) and (->). We thus + must ensure that (=>) and (->) (among the other arrow combinations) + 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 + 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 + GHC.Core.Unify.unify_ty. + +(W4) We give a different Typeable instance for Type than for Constraint. + For type classes instances (unlike type family instances) it is not + /unsound/ for Type and Constraint to treated as fully distinct; and + for Typeable is desirable to give them different TypeReps. + Certainly, + - both Type and Constraint must /have/ a TypeRep, and + - they had better not be the same (else eqTypeRep would give us + a proof Type ~N Constraint, which we do not want + So in GHC.Tc.Instance.Class.matchTypeable, Type and Constraint are + treated as separate TyCons; i.e. given no special treatment. + +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). ... This is no good: we could not generate code for 'f', because the @@ -566,85 +863,40 @@ (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a :: TYPE r1) (b :: TYPE r2). a -> b -> TYPE ('TupleRep '[r1, r2]) - -} +---------------------- tYPETyCon :: TyCon -tYPETyConName :: Name - tYPETyCon = mkPrimTyCon tYPETyConName (mkTemplateAnonTyConBinders [runtimeRepTy]) liftedTypeKind [Nominal] --------------------------- --- ... and now their names +tYPETyConName :: Name +tYPETyConName = mkPrimTc (fsLit "TYPE") tYPETyConKey tYPETyCon --- If you edit these, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint -tYPETyConName = mkPrimTcName UserSyntax (fsLit "TYPE") tYPETyConKey tYPETyCon +tYPEKind :: Type +tYPEKind = mkTyConTy tYPETyCon -mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name -mkPrimTcName built_in_syntax occ key tycon - = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (mkATyCon tycon) built_in_syntax +---------------------- +cONSTRAINTTyCon :: TyCon +cONSTRAINTTyCon = mkPrimTyCon cONSTRAINTTyConName + (mkTemplateAnonTyConBinders [runtimeRepTy]) + liftedTypeKind + [Nominal] ------------------------------ +cONSTRAINTTyConName :: Name +cONSTRAINTTyConName = mkPrimTc (fsLit "CONSTRAINT") cONSTRAINTTyConKey cONSTRAINTTyCon --- Given a Multiplicity, applies FUN to it. -functionWithMultiplicity :: Type -> Type -functionWithMultiplicity mul = TyConApp funTyCon [mul] +cONSTRAINTKind :: Type +cONSTRAINTKind = mkTyConTy cONSTRAINTTyCon -{- -************************************************************************ + +{- ********************************************************************* * * - Basic primitive types (@Char#@, @Int#@, etc.) + Basic primitive types (Char#, Int#, etc.) * * -************************************************************************ --} - --- | Create a primitive 'TyCon' with the given 'Name', --- arguments of kind 'Type` with the given 'Role's, --- and the given result kind representation. --- --- Only use this in "GHC.Builtin.Types.Prim". -pcPrimTyCon :: Name - -> [Role] -> RuntimeRepType -> TyCon -pcPrimTyCon name roles res_rep - = mkPrimTyCon name binders result_kind roles - where - bndr_kis = liftedTypeKind <$ roles - binders = mkTemplateAnonTyConBinders bndr_kis - result_kind = mkTYPEapp res_rep - --- | Create a primitive nullary 'TyCon' with the given 'Name' --- and result kind representation. --- --- Only use this in "GHC.Builtin.Types.Prim". -pcPrimTyCon0 :: Name -> RuntimeRepType -> TyCon -pcPrimTyCon0 name res_rep - = pcPrimTyCon name [] res_rep - --- | Create a primitive 'TyCon' like 'pcPrimTyCon', except the last --- argument is levity-polymorphic. --- --- Only use this in "GHC.Builtin.Types.Prim". -pcPrimTyCon_LevPolyLastArg :: Name - -> [Role] -- ^ roles of the arguments (must be non-empty), - -- not including the implicit argument of kind 'Levity', - -- which always has 'Nominal' role - -> RuntimeRepType -- ^ representation of the fully-applied type - -> TyCon -pcPrimTyCon_LevPolyLastArg name roles res_rep - = mkPrimTyCon name binders result_kind (Nominal : roles) - where - result_kind = mkTYPEapp res_rep - lev_bndr = mkNamedTyConBinder Inferred levity1TyVar - binders = lev_bndr : mkTemplateAnonTyConBinders anon_bndr_kis - lev_tv = mkTyVarTy (binderVar lev_bndr) - - -- [ Type, ..., Type, TYPE (BoxedRep l) ] - anon_bndr_kis = changeLast (liftedTypeKind <$ roles) - (mkTYPEapp $ mkTyConApp boxedRepDataConTyCon [lev_tv]) +********************************************************************* -} charPrimTy :: Type charPrimTy = mkTyConTy charPrimTyCon @@ -815,6 +1067,8 @@ * In addition (~) is magical syntax, as ~ is a reserved symbol. It cannot be exported or imported. + * The data constructor of the class is "Eq#", not ":C~" + Within GHC, ~ is called eqTyCon, and it is defined in GHC.Builtin.Types. Historical note: prior to July 18 (~) was defined as a @@ -918,10 +1172,7 @@ realWorldStatePrimTy :: Type realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld --- Note: the ``state-pairing'' types are not truly primitive, --- so they are defined in \tr{GHC.Builtin.Types}, not here. - mkProxyPrimTy :: Type -> Type -> Type mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] @@ -944,9 +1195,9 @@ -- See Note [The equality types story] eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles where - -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[]) + -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id - res_kind = unboxedTupleKind [] + res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy] roles = [Nominal, Nominal, Nominal, Nominal] -- like eqPrimTyCon, but the type for *Representational* coercions @@ -955,9 +1206,9 @@ eqReprPrimTyCon :: TyCon -- See Note [The equality types story] eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles where - -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[]) + -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id - res_kind = unboxedTupleKind [] + res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy] roles = [Nominal, Nominal, Representational, Representational] -- like eqPrimTyCon, but the type for *Phantom* coercions. @@ -966,9 +1217,9 @@ eqPhantPrimTyCon :: TyCon eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles where - -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[]) + -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id - res_kind = unboxedTupleKind [] + res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy] roles = [Nominal, Nominal, Phantom, Phantom] -- | Given a Role, what TyCon is the type of equality predicates at that role? @@ -1170,6 +1421,20 @@ threadIdPrimTy = mkTyConTy threadIdPrimTyCon threadIdPrimTyCon :: TyCon threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName unliftedRepTy + +{- +************************************************************************ +* * + The ``prompt tag'' type +* * +************************************************************************ +-} + +promptTagPrimTyCon :: TyCon +promptTagPrimTyCon = pcPrimTyCon promptTagPrimTyConName [Representational] unliftedRepTy + +mkPromptTagPrimTy :: Type -> Type +mkPromptTagPrimTy v = TyConApp promptTagPrimTyCon [v] {- ************************************************************************ diff --git a/GHC/Builtin/Types/Prim.hs-boot b/GHC/Builtin/Types/Prim.hs-boot deleted file mode 100644 --- a/GHC/Builtin/Types/Prim.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module GHC.Builtin.Types.Prim where - -import GHC.Core.TyCon - -tYPETyCon :: TyCon diff --git a/GHC/Builtin/Uniques.hs b/GHC/Builtin/Uniques.hs --- a/GHC/Builtin/Uniques.hs +++ b/GHC/Builtin/Uniques.hs @@ -13,8 +13,8 @@ -- * Getting the 'Unique's of 'Name's -- ** Anonymous sums - , mkSumTyConUnique - , mkSumDataConUnique + , mkSumTyConUnique, mkSumDataConUnique + -- ** Tuples -- *** Vanilla , mkTupleTyConUnique @@ -37,7 +37,7 @@ , mkBuiltinUnique , mkPseudoUniqueE - -- ** Deriving uniquesc + -- ** Deriving uniques -- *** From TyCon name uniques , tyConRepNameUnique -- *** From DataCon name uniques @@ -45,6 +45,9 @@ , initExitJoinUnique + -- Boxing data types + , mkBoxingTyConUnique, boxingDataConUnique + ) where import GHC.Prelude @@ -60,7 +63,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import Data.Maybe @@ -107,8 +109,9 @@ mkSumTyConUnique :: Arity -> Unique mkSumTyConUnique arity = - assert (arity < 0x3f) $ -- 0x3f since we only have 6 bits to encode the - -- alternative + assertPpr (arity <= 0x3f) (ppr arity) $ + -- 0x3f since we only have 6 bits to encode the + -- alternative mkUnique 'z' (arity `shiftL` 8 .|. 0xfc) mkSumDataConUnique :: ConTagZ -> Arity -> Unique @@ -297,6 +300,7 @@ other a-z: lower case chars for unique supplies. Used so far: a TypeChecking? + b Boxing tycons & datacons c StgToCmm/Renamer d desugarer f AbsC flattener @@ -310,6 +314,27 @@ u Cmm pipeline y GHCi bytecode generator z anonymous sums + +Note [Related uniques for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* All wired in tycons actually use *two* uniques: + * u: the TyCon itself + * u+1: the TyConRepName of the TyCon (for use with TypeRep) + The "+1" is implemented in tyConRepNameUnique. + If this ever changes, make sure to also change the treatment for boxing tycons. + +* All wired in datacons use *three* uniques: + * u: the DataCon itself + * u+1: its worker Id + * u+2: the TyConRepName of the promoted TyCon + No wired-in datacons have wrappers. + The "+1" is implemented in dataConWorkerUnique and the "+2" is in dataConTyRepNameUnique. + If this ever changes, make sure to also change the treatment for boxing tycons. + +* Because boxing tycons (see Note [Boxing constructors] in GHC.Builtin.Types) + come with both a tycon and a datacon, each one takes up five slots, combining + the two cases above. Getting from the tycon to the datacon (by adding 2) + is implemented in boxingDataConUnique. -} mkAlphaTyVarUnique :: Int -> Unique @@ -351,29 +376,48 @@ initExitJoinUnique :: Unique initExitJoinUnique = mkUnique 's' 0 - -------------------------------------------------- -- Wired-in type constructor keys occupy *two* slots: --- * u: the TyCon itself --- * u+1: the TyConRepName of the TyCon +-- See Note [Related uniques for wired-in things] mkPreludeTyConUnique :: Int -> Unique -mkPreludeTyConUnique i = mkUnique '3' (2*i) +mkPreludeTyConUnique i = mkUnique '3' (2*i) tyConRepNameUnique :: Unique -> Unique tyConRepNameUnique u = incrUnique u -------------------------------------------------- -- Wired-in data constructor keys occupy *three* slots: --- * u: the DataCon itself --- * u+1: its worker Id --- * u+2: the TyConRepName of the promoted TyCon --- Prelude data constructors are too simple to need wrappers. +-- See Note [Related uniques for wired-in things] mkPreludeDataConUnique :: Int -> Unique -mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic +mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic --------------------------------------------------- dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique dataConWorkerUnique u = incrUnique u dataConTyRepNameUnique u = stepUnique u 2 + +-------------------------------------------------- +-- The data constructors of RuntimeRep occupy *five* slots: +-- See Note [Related uniques for wired-in things] +-- +-- Example: WordRep +-- +-- * u: the TyCon of the boxing data type WordBox +-- * u+1: the TyConRepName of the boxing data type +-- * u+2: the DataCon for MkWordBox +-- * u+3: the worker id for MkWordBox +-- * u+4: the TyConRepName of the promoted TyCon 'MkWordBox +-- +-- Note carefully that +-- * u,u+1 are in sync with the conventions for +-- wired-in type constructors, above +-- * u+2,u+3,u+4 are in sync with the conventions for +-- wired-in data constructors, above +-- A little delicate! + +mkBoxingTyConUnique :: Int -> Unique +mkBoxingTyConUnique i = mkUnique 'b' (5*i) + +boxingDataConUnique :: Unique -> Unique +boxingDataConUnique u = stepUnique u 2 diff --git a/GHC/Builtin/bytearray-ops.txt.pp b/GHC/Builtin/bytearray-ops.txt.pp --- a/GHC/Builtin/bytearray-ops.txt.pp +++ b/GHC/Builtin/bytearray-ops.txt.pp @@ -51,7 +51,7 @@ primop IndexByteArrayOp_StablePtr "indexStablePtrArray#" GenPrimOp ByteArray# -> Int# -> StablePtr# a - {Read a {\tt StablePtr#} value; offset in machine words.} + {Read a 'StablePtr#' value; offset in machine words.} with can_fail = True primop IndexByteArrayOp_Int8 "indexInt8Array#" GenPrimOp @@ -136,7 +136,7 @@ primop IndexByteArrayOp_Word8AsStablePtr "indexWord8ArrayAsStablePtr#" GenPrimOp ByteArray# -> Int# -> StablePtr# a - {Read a {\tt StablePtr#} value; offset in bytes.} + {Read a 'StablePtr#' value; offset in bytes.} with can_fail = True primop IndexByteArrayOp_Word8AsInt16 "indexWord8ArrayAsInt16#" GenPrimOp @@ -218,7 +218,7 @@ primop ReadByteArrayOp_StablePtr "readStablePtrArray#" GenPrimOp MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #) - {Read a {\tt StablePtr#} value; offset in machine words.} + {Read a 'StablePtr#' value; offset in machine words.} with has_side_effects = True can_fail = True @@ -319,7 +319,7 @@ primop ReadByteArrayOp_Word8AsStablePtr "readWord8ArrayAsStablePtr#" GenPrimOp MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #) - {Read a {\tt StablePtr#} value; offset in bytes.} + {Read a 'StablePtr#' value; offset in bytes.} with has_side_effects = True can_fail = True @@ -408,7 +408,7 @@ primop WriteByteArrayOp_StablePtr "writeStablePtrArray#" GenPrimOp MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s - {Write a {\tt StablePtr#} value; offset in machine words.} + {Write a 'StablePtr#' value; offset in machine words.} with has_side_effects = True can_fail = True @@ -509,7 +509,7 @@ primop WriteByteArrayOp_Word8AsStablePtr "writeWord8ArrayAsStablePtr#" GenPrimOp MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s - {Write a {\tt StablePtr#} value; offset in bytes.} + {Write a 'StablePtr#' value; 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 @@ -98,14 +98,14 @@ -- This file is divided into named sections, each containing or more -- primop entries. Section headers have the format: -- --- section "section-name" {description} +-- section "section-name" {haddock-description} -- -- This information is used solely when producing documentation; it is --- otherwise ignored. The description is optional. +-- 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 {description} attributes +-- 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 @@ -181,10 +181,6 @@ -- prim` can be moved to a small library tailured to the features being -- implemented and dependencies of those features. --- Currently, documentation is produced using latex, so contents of --- description fields should be legal latex. Descriptions can contain --- matched pairs of embedded curly brackets. - -- Note [Levity and representation polymorphic primops] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- In the types of primops in this module, @@ -221,17 +217,16 @@ -- nor `b` and `p`, nor `o` and `v`, etc. section "The word size story." - {Haskell98 specifies that signed integers (type {\tt Int}) - must contain at least 30 bits. GHC always implements {\tt - Int} using the primitive type {\tt Int\#}, whose size equals - the {\tt MachDeps.h} constant {\tt WORD\_SIZE\_IN\_BITS}. - This is normally set based on the {\tt config.h} parameter - {\tt SIZEOF\_HSWORD}, i.e., 32 bits on 32-bit machines, 64 + {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 {\tt - Word\#} which always has the same number of bits as {\tt - Int\#}. + 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 @@ -239,11 +234,11 @@ conversions. Finally, there are strongly deprecated primops for coercing - between {\tt Addr\#}, the primitive type of machine - addresses, and {\tt Int\#}. These are pretty bogus anyway, + 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 {\tt Int\#}, - so are not available in this case. } + are completely bogus when tag bits are used in 'Int#', + so are not available in this case.} ------------------------------------------------------------------------ section "Char#" @@ -725,7 +720,7 @@ If in doubt, return non-zero, but do make an effort to create the correct answer for small args, since otherwise the performance of - \texttt{(*) :: Integer -> Integer -> Integer} will be poor. + @(*) :: Integer -> Integer -> Integer@ will be poor. } with commutable = True @@ -738,7 +733,7 @@ primop IntRemOp "remInt#" GenPrimOp Int# -> Int# -> Int# - {Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}. The + {Satisfies @('quotInt#' x y) '*#' y '+#' ('remInt#' x y) == x@. The behavior is undefined if the second argument is zero. } with can_fail = True @@ -765,25 +760,25 @@ primop IntNegOp "negateInt#" GenPrimOp Int# -> Int# {Unary negation. - Since the negative {\tt Int#} range extends one further than the - positive range, {\tt negateInt#} of the most negative number is an - identity operation. This way, {\tt negateInt#} is always its own inverse.} + 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 {\tt Int#}; - second member is zero if the true sum fits in an {\tt Int#}, + 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 {\tt Int#}).} + 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 {\tt Int#}; - second member is zero if the true difference fits in an {\tt Int#}, + 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 {\tt Int#}).} + or too small to fit in an 'Int#').} with code_size = 2 primop IntGtOp ">#" Compare Int# -> Int# -> Int# @@ -815,22 +810,22 @@ with code_size = 0 primop IntToFloatOp "int2Float#" GenPrimOp Int# -> Float# - {Convert an {\tt Int#} to the corresponding {\tt Float#} with the same + {Convert an 'Int#' to the corresponding 'Float#' with the same integral value (up to truncation due to floating-point precision). e.g. - {\tt int2Float# 1# == 1.0#}} + @'int2Float#' 1# == 1.0#@} primop IntToDoubleOp "int2Double#" GenPrimOp Int# -> Double# - {Convert an {\tt Int#} to the corresponding {\tt Double#} with the same + {Convert an 'Int#' to the corresponding 'Double#' with the same integral value (up to truncation due to floating-point precision). e.g. - {\tt int2Double# 1# == 1.0##}} + @'int2Double#' 1# == 1.0##@} primop WordToFloatOp "word2Float#" GenPrimOp Word# -> Float# - {Convert an {\tt Word#} to the corresponding {\tt Float#} with the same + {Convert an 'Word#' to the corresponding 'Float#' with the same integral value (up to truncation due to floating-point precision). e.g. - {\tt word2Float# 1## == 1.0#}} + @'word2Float#' 1## == 1.0#@} primop WordToDoubleOp "word2Double#" GenPrimOp Word# -> Double# - {Convert an {\tt Word#} to the corresponding {\tt Double#} with the same + {Convert an 'Word#' to the corresponding 'Double#' with the same integral value (up to truncation due to floating-point precision). e.g. - {\tt word2Double# 1## == 1.0##}} + @'word2Double#' 1## == 1.0##@} primop IntSllOp "uncheckedIShiftL#" GenPrimOp Int# -> Int# -> Int# {Shift left. Result undefined if shift amount is not @@ -855,7 +850,7 @@ 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 {\tt plusWord2#}.} + the carry flag, which is nonzero on overflow. See also 'plusWord2#'.} with code_size = 2 commutable = True @@ -868,7 +863,7 @@ 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 {\tt addWordC#}.} + component of the pair. See also 'addWordC#'.} with code_size = 2 commutable = True @@ -1065,9 +1060,9 @@ primop DoubleFabsOp "fabsDouble#" GenPrimOp Double# -> Double# primop DoubleToIntOp "double2Int#" GenPrimOp Double# -> Int# - {Truncates a {\tt Double#} value to the nearest {\tt Int#}. + {Truncates a 'Double#' value to the nearest 'Int#'. Results are undefined if the truncation if truncation yields - a value outside the range of {\tt Int#}.} + a value outside the range of 'Int#'.} primop DoubleToFloatOp "double2Float#" GenPrimOp Double# -> Float# @@ -1176,7 +1171,7 @@ primop DoubleDecode_Int64Op "decodeDouble_Int64#" GenPrimOp Double# -> (# Int64#, Int# #) - {Decode {\tt Double\#} into mantissa and base-2 exponent.} + {Decode 'Double#' into mantissa and base-2 exponent.} with out_of_line = True ------------------------------------------------------------------------ @@ -1219,9 +1214,9 @@ primop FloatFabsOp "fabsFloat#" GenPrimOp Float# -> Float# primop FloatToIntOp "float2Int#" GenPrimOp Float# -> Int# - {Truncates a {\tt Float#} value to the nearest {\tt Int#}. + {Truncates a 'Float#' value to the nearest 'Int#'. Results are undefined if the truncation if truncation yields - a value outside the range of {\tt Int#}.} + a value outside the range of 'Int#'.} primop FloatExpOp "expFloat#" GenPrimOp Float# -> Float# @@ -1322,12 +1317,12 @@ primop FloatDecode_IntOp "decodeFloat_Int#" GenPrimOp Float# -> (# Int#, Int# #) {Convert to integers. - First {\tt Int\#} in result is the mantissa; second is the exponent.} + First 'Int#' in result is the mantissa; second is the exponent.} with out_of_line = True ------------------------------------------------------------------------ section "Arrays" - {Operations on {\tt Array\#}.} + {Operations on 'Array#'.} ------------------------------------------------------------------------ primtype Array# a @@ -1473,9 +1468,9 @@ 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 {\tt casIntArray\#}. All of the difficulties - of using {\tt reallyUnsafePtrEquality\#} correctly apply to - {\tt casArray\#} as well. + to use correctly than 'casIntArray#'. All of the difficulties + of using 'reallyUnsafePtrEquality#' correctly apply to + 'casArray#' as well. } with out_of_line = True @@ -1486,10 +1481,10 @@ ------------------------------------------------------------------------ section "Small Arrays" - {Operations on {\tt SmallArray\#}. A {\tt SmallArray\#} works - just like an {\tt Array\#}, but with different space use and + {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 {\tt SmallArray\#} and {\tt SmallMutableArray#} + 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 @@ -1497,11 +1492,11 @@ 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 {\tt SmallMutableArray#} the whole + 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 {\tt SmallArray\#}. + to become an immutable 'SmallArray#'. } ------------------------------------------------------------------------ @@ -1523,7 +1518,7 @@ 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 {\tt getSizeofSmallMutableArray\#}.} + equal to the current size as reported by 'getSizeofSmallMutableArray#'.} with out_of_line = True has_side_effects = True @@ -1655,7 +1650,7 @@ 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 {\tt casArray\#}.} + See the documentation of 'casArray#'.} with out_of_line = True has_side_effects = True @@ -1663,9 +1658,9 @@ ------------------------------------------------------------------------ section "Byte Arrays" - {A {\tt ByteArray\#} is a region of + {A 'ByteArray#' is a region of raw memory in the garbage-collected heap, which is not - scanned for pointers. + 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 @@ -1683,29 +1678,29 @@ 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. + 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. - + 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 + + 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: +{ A mutable 'ByteAray#'. It can be created in three ways: * 'newByteArray#': Create an unpinned array. * 'newPinnedByteArray#': This will create a pinned array, @@ -1742,13 +1737,13 @@ primop MutableByteArrayIsPinnedOp "isMutableByteArrayPinned#" GenPrimOp MutableByteArray# s -> Int# - {Determine whether a {\tt MutableByteArray\#} is guaranteed not to move + {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 {\tt ByteArray\#} is guaranteed not to move during GC.} + {Determine whether a 'ByteArray#' is guaranteed not to move during GC.} with out_of_line = True primop ByteArrayContents_Char "byteArrayContents#" GenPrimOp @@ -1763,23 +1758,23 @@ 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 {\tt getSizeofMutableByteArray\#}.} + 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 {\tt MutableByteArray\#} is either the original - {\tt MutableByteArray\#} resized in-place or, if not possible, a newly - allocated (unpinned) {\tt MutableByteArray\#} (with the original content + 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 {\tt MutableByteArray\#} shall - not be accessed anymore after a {\tt resizeMutableByteArray\#} has been + 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 {\tt MutableByteArray\#} in - case a new {\tt MutableByteArray\#} had to be allocated.} + 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 @@ -1808,12 +1803,12 @@ primop CompareByteArraysOp "compareByteArrays#" GenPrimOp ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int# - {{\tt compareByteArrays# src1 src1_ofs src2 src2_ofs n} compares - {\tt n} bytes starting at offset {\tt src1_ofs} in the first - {\tt ByteArray#} {\tt src1} to the range of {\tt n} bytes - (i.e. same length) starting at offset {\tt src2_ofs} of the second - {\tt ByteArray#} {\tt src2}. Both arrays must fully contain the - specified ranges, but this is not checked. Returns an {\tt 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.} @@ -1822,10 +1817,10 @@ primop CopyByteArrayOp "copyByteArray#" GenPrimOp ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s - {{\tt copyByteArray# src src_ofs dst dst_ofs n} copies the range - starting at offset {\tt src_ofs} of length {\tt n} from the - {\tt ByteArray#} {\tt src} to the {\tt MutableByteArray#} {\tt dst} - starting at offset {\tt dst_ofs}. Both arrays must fully contain + {@'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.} @@ -1883,8 +1878,8 @@ primop SetByteArrayOp "setByteArray#" GenPrimOp MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s - {{\tt setByteArray# ba off len c} sets the byte range {\tt [off, off+len)} of - the {\tt MutableByteArray#} to the byte {\tt c}.} + {@'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 } @@ -2017,11 +2012,11 @@ primop AddrAddOp "plusAddr#" GenPrimOp Addr# -> Int# -> Addr# primop AddrSubOp "minusAddr#" GenPrimOp Addr# -> Addr# -> Int# - {Result is meaningless if two {\tt Addr\#}s are so far apart that their - difference doesn't fit in an {\tt 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 {\tt Addr\#} arg, treated like an {\tt Int\#}, - is divided by the {\tt Int\#} arg.} + {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 @@ -2431,11 +2426,11 @@ ------------------------------------------------------------------------ primtype MutVar# s a - {A {\tt MutVar\#} behaves like a single-element mutable array.} + {A 'MutVar#' behaves like a single-element mutable array.} primop NewMutVarOp "newMutVar#" GenPrimOp v -> State# s -> (# State# s, MutVar# s v #) - {Create {\tt MutVar\#} with specified initial value in specified state thread.} + {Create 'MutVar#' with specified initial value in specified state thread.} with out_of_line = True has_side_effects = True @@ -2456,14 +2451,14 @@ primop ReadMutVarOp "readMutVar#" GenPrimOp MutVar# s v -> State# s -> (# State# s, v #) - {Read contents of {\tt MutVar\#}. Result is not yet evaluated.} + {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 {\tt MutVar\#}.} + {Write contents of 'MutVar#'.} with -- See Note [Why MutVar# ops can't fail] has_side_effects = True @@ -2483,11 +2478,11 @@ primop AtomicModifyMutVar2Op "atomicModifyMutVar2#" GenPrimOp MutVar# s a -> (a -> c) -> State# s -> (# State# s, a, c #) - { Modify the contents of a {\tt MutVar\#}, returning the previous + { 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 - {\tt MutVar\# s a -> (a -> (a,b)) -> State\# s -> (\# State\# s, a, (a, b) \#)}, + @'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 @@ -2496,7 +2491,7 @@ primop AtomicModifyMutVar_Op "atomicModifyMutVar_#" GenPrimOp MutVar# s a -> (a -> a) -> State# s -> (# State# s, a, a #) - { Modify the contents of a {\tt MutVar\#}, returning the previous + { Modify the contents of a 'MutVar#', returning the previous contents and the result of applying the given function to the previous contents. } with @@ -2508,18 +2503,18 @@ 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 {\tt MutVar\#}. If the pointers are equal, + 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 {\tt MutVar\#}. - The {\tt Int\#} indicates whether a swap took place, - with {\tt 1\#} meaning that we didn't swap, and {\tt 0\#} + 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 - {\tt reallyUnsafePtrEquality\#} correctly apply to - {\tt casMutVar\#} as well. + 'reallyUnsafePtrEquality#' correctly apply to + 'casMutVar#' as well. } with out_of_line = True @@ -2547,6 +2542,12 @@ -> (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 @@ -2572,6 +2573,30 @@ 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 @@ -2584,6 +2609,12 @@ 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 [Strictness for mask/unmask/catch] @@ -2593,6 +2624,12 @@ 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 } out_of_line = True @@ -2601,6 +2638,12 @@ 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 [Strictness for mask/unmask/catch] @@ -2614,6 +2657,198 @@ 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, strictOnceApply1Dmd, topDmd] topDiv } + 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" ------------------------------------------------------------------------ @@ -2672,7 +2907,7 @@ primop NewTVarOp "newTVar#" GenPrimOp v -> State# s -> (# State# s, TVar# s v #) - {Create a new {\tt TVar\#} holding a specified initial value.} + {Create a new 'TVar#' holding a specified initial value.} with out_of_line = True has_side_effects = True @@ -2680,8 +2915,8 @@ primop ReadTVarOp "readTVar#" GenPrimOp TVar# s v -> State# s -> (# State# s, v #) - {Read contents of {\tt TVar\#} inside an STM transaction, - i.e. within a call to {\tt atomically\#}. + {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 @@ -2690,7 +2925,7 @@ primop ReadTVarIOOp "readTVarIO#" GenPrimOp TVar# s v -> State# s -> (# State# s, v #) - {Read contents of {\tt TVar\#} outside an STM transaction. + {Read contents of 'TVar#' outside an STM transaction. Does not force evaluation of the result.} with out_of_line = True @@ -2700,7 +2935,7 @@ TVar# s v -> v -> State# s -> State# s - {Write contents of {\tt TVar\#}.} + {Write contents of 'TVar#'.} with out_of_line = True has_side_effects = True @@ -2708,24 +2943,24 @@ ------------------------------------------------------------------------ section "Synchronized Mutable Variables" - {Operations on {\tt MVar\#}s. } + {Operations on 'MVar#'s. } ------------------------------------------------------------------------ primtype MVar# s a - { A shared mutable variable ({\it not} the same as a {\tt MutVar\#}!). - (Note: in a non-concurrent implementation, {\tt (MVar\# a)} can be - represented by {\tt (MutVar\# (Maybe 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 {\tt MVar\#}; initially empty.} + {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 {\tt MVar\#} is empty, block until it becomes full. + {If 'MVar#' is empty, block until it becomes full. Then remove and return its contents, and set it empty.} with out_of_line = True @@ -2733,15 +2968,15 @@ primop TryTakeMVarOp "tryTakeMVar#" GenPrimOp MVar# s v -> State# s -> (# State# s, Int#, v #) - {If {\tt MVar\#} is empty, immediately return with integer 0 and value undefined. - Otherwise, return with integer 1 and contents of {\tt MVar\#}, and set {\tt MVar\#} empty.} + {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 {\tt MVar\#} is full, block until it becomes empty. + {If 'MVar#' is full, block until it becomes empty. Then store value arg as its new contents.} with out_of_line = True @@ -2749,15 +2984,15 @@ primop TryPutMVarOp "tryPutMVar#" GenPrimOp MVar# s v -> v -> State# s -> (# State# s, Int# #) - {If {\tt MVar\#} is full, immediately return with integer 0. - Otherwise, store value arg as {\tt MVar\#}'s new contents, and return with integer 1.} + {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 {\tt MVar\#} is empty, block until it becomes full. + {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 @@ -2766,15 +3001,15 @@ primop TryReadMVarOp "tryReadMVar#" GenPrimOp MVar# s v -> State# s -> (# State# s, Int#, v #) - {If {\tt MVar\#} is empty, immediately return with integer 0 and value undefined. - Otherwise, return with integer 1 and contents of {\tt MVar\#}.} + {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 {\tt MVar\#} is empty; 0 otherwise.} + {Return 1 if 'MVar#' is empty; 0 otherwise.} with out_of_line = True has_side_effects = True @@ -2782,36 +3017,36 @@ ------------------------------------------------------------------------ section "Synchronized I/O Ports" - {Operations on {\tt IOPort\#}s. } + {Operations on 'IOPort#'s. } ------------------------------------------------------------------------ primtype IOPort# s a - { A shared I/O port is almost the same as a {\tt MVar\#}!). + { 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 {\tt IOPort\#}; initially empty.} + {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 {\tt IOPort\#} is empty, block until it becomes full. + {If 'IOPort#' is empty, block until it becomes full. Then remove and return its contents, and set it empty. - Throws an {\tt IOPortException} if another thread is already - waiting to read this {\tt IOPort\#}.} + 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 {\tt IOPort\#} is full, immediately return with integer 0, - throwing an {\tt IOPortException}. - Otherwise, store value arg as {\tt IOPort\#}'s new contents, + {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 @@ -2847,20 +3082,20 @@ ------------------------------------------------------------------------ primtype State# s - { {\tt State\#} is the primitive, unlifted type of states. It has - one type parameter, thus {\tt State\# RealWorld}, or {\tt 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 - { {\tt RealWorld} is deeply magical. It is {\it primitive}, but it is not - {\it unlifted} (hence {\tt ptrArg}). We never manipulate values of type - {\tt RealWorld}; it's only used in the type system, to parameterise {\tt State\#}. } + { '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 {\tt myThreadId\#}. The + type, whose (unique) value is returned by 'myThreadId#'. The other operations can be omitted.)} primop ForkOp "fork#" GenPrimOp @@ -2900,7 +3135,9 @@ has_side_effects = True primop LabelThreadOp "labelThread#" GenPrimOp - ThreadId# -> Addr# -> State# RealWorld -> State# RealWorld + 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 @@ -2917,12 +3154,42 @@ 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" ------------------------------------------------------------------------ @@ -2935,11 +3202,11 @@ primop MkWeakOp "mkWeak#" GenPrimOp v -> w -> (State# RealWorld -> (# State# RealWorld, c #)) -> State# RealWorld -> (# State# RealWorld, Weak# w #) - { {\tt mkWeak# k v finalizer s} creates a weak reference to value {\tt k}, - with an associated reference to some value {\tt v}. If {\tt k} is still - alive then {\tt v} can be retrieved using {\tt deRefWeak#}. Note that - the type of {\tt k} must be represented by a pointer (i.e. of kind {\tt - TYPE 'LiftedRep} or {\tt TYPE 'UnliftedRep}). } + { @'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 @@ -2953,12 +3220,12 @@ primop AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp Addr# -> Addr# -> Int# -> Addr# -> Weak# w -> State# RealWorld -> (# State# RealWorld, Int# #) - { {\tt addCFinalizerToWeak# fptr ptr flag eptr w} attaches a C - function pointer {\tt fptr} to a weak pointer {\tt w} as a finalizer. If - {\tt flag} is zero, {\tt fptr} will be called with one argument, - {\tt ptr}. Otherwise, it will be called with two arguments, - {\tt eptr} and {\tt ptr}. {\tt addCFinalizerToWeak#} returns - 1 on success, or 0 if {\tt w} is already dead. } + { @'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 @@ -2974,9 +3241,9 @@ (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 {\tt Int#} and a (possibly invalid) finalization - action. An {\tt Int#} of {\tt 1} indicates that the finalizer is valid. The - return value {\tt b} from the finalizer should be ignored. } + 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 @@ -3024,11 +3291,11 @@ ------------------------------------------------------------------------ section "Compact normal form" - {Primitives for working with compact regions. The {\tt ghc\-compact} - library and the {\tt compact} library demonstrate how to use these + {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 {\tt rts\/sm\/CNF.c} + 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 @@ -3082,7 +3349,7 @@ 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 {\tt nullAddr\#} if 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 @@ -3090,12 +3357,12 @@ 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 {\texttt Addr\#} is a pointer - to previous compact block of the CNF or {\texttt nullAddr\#} to create a + 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 - {\texttt compactFixupPointers\#} is called on it, and care must be taken + 'compactFixupPointers#' is called on it, and care must be taken so that the address does not escape or memory will be leaked. } with @@ -3118,10 +3385,10 @@ primop CompactAdd "compactAdd#" GenPrimOp Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #) { Recursively add a closure and its transitive closure to a - {\texttt Compact\#} (a CNF), evaluating any unevaluated components - at the same time. Note: {\texttt compactAdd\#} is not thread-safe, so - only one thread may call {\texttt compactAdd\#} with a particular - {\texttt Compact\#} at any given time. The primop does not + '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 @@ -3130,7 +3397,7 @@ primop CompactAddWithSharing "compactAddWithSharing#" GenPrimOp Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #) - { Like {\texttt compactAdd\#}, but retains sharing and cycles + { Like 'compactAdd#', but retains sharing and cycles during compaction. } with has_side_effects = True @@ -3153,7 +3420,7 @@ -- See Note [Levity and representation polymorphic primops] primop ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp v -> w -> Int# - { Returns {\texttt 1\#} if the given pointers are equal and {\texttt 0\#} otherwise. } + { Returns @1#@ if the given pointers are equal and @0#@ otherwise. } with can_fail = True -- See Note [reallyUnsafePtrEquality# can_fail] @@ -3162,29 +3429,47 @@ -- The primop `reallyUnsafePtrEquality#` does a direct pointer -- equality between two (boxed) values. Several things to note: -- --- * 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] +-- (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] -- --- * It does not evaluate its arguments. The user of the primop is responsible --- for doing so. +-- (PE2) It is hetero-typed; you can compare pointers of different types. +-- This is used in various packages such as containers & unordered-containers. -- --- * 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. -- --- * It is obviously very dangerous, because --- 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). +-- (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). -- --- * reallyUnsafePtrEquality# can't fail, but it is marked as such --- to prevent it from floating out. --- See Note [reallyUnsafePtrEquality# can_fail] +-- (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.Exts provides several less Wild-West functions +-- 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 @@ -3202,7 +3487,7 @@ -- sameIOPort# :: IOPort# s a -> IOPort# s a -> Int# -- eqStableName# :: StableName# a -> StableName# b -> Int# -- --- These operations are all specialisations of reallyUnsafePtrEquality#. +-- These operations are all specialisations of unsafePtrEquality#. -- Note [reallyUnsafePtrEquality# can_fail] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3212,7 +3497,7 @@ -- 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/app invariant failures (see #13027 and the +-- 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 @@ -3269,6 +3554,7 @@ out_of_line = True + ------------------------------------------------------------------------ section "Controlling object lifetime" {Ensuring that objects don't die a premature death.} @@ -3280,11 +3566,12 @@ -- See Note [Levity and representation polymorphic primops] primop KeepAliveOp "keepAlive#" GenPrimOp v -> State# RealWorld -> (State# RealWorld -> p) -> p - { \tt{keepAlive# x s k} keeps the value \tt{x} alive during the execution - of the computation \tt{k}. + { @'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; ticket \#21868 for details. } + 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 } @@ -3298,6 +3585,8 @@ 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 @@ -3318,21 +3607,21 @@ { Primitive bytecode type. } primop AddrToAnyOp "addrToAny#" GenPrimOp - Addr# -> (# a #) - { Convert an {\tt Addr\#} to a followable Any type. } + 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 {\texttt unsafeCoerce\#}, but if implemented as such + 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 {\texttt Addr\#} is not a GC + 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 @@ -3340,24 +3629,24 @@ primop MkApUpd0_Op "mkApUpd0#" GenPrimOp BCO -> (# a #) - { Wrap a BCO in a {\tt AP_UPD} thunk which will be updated with the value of + { 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 #) - { {\tt newBCO\# instrs lits ptrs arity bitmap} creates a new bytecode object. The + { @'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 {\tt instrs}, and a static reference table usage bitmap given by - {\tt bitmap}. } + 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 #) - { {\tt unpackClosure\# closure} copies the closure and pointers in the + { @'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. } @@ -3366,7 +3655,7 @@ primop ClosureSizeOp "closureSize#" GenPrimOp a -> Int# - { {\tt closureSize\# closure} returns the size of the given closure in + { @'closureSize#' closure@ returns the size of the given closure in machine words. } with out_of_line = True @@ -3386,9 +3675,9 @@ primop GetCurrentCCSOp "getCurrentCCS#" GenPrimOp a -> State# s -> (# State# s, Addr# #) - { Returns the current {\tt CostCentreStack} (value is {\tt NULL} if + { Returns the current 'CostCentreStack' (value is @NULL@ if not profiling). Takes a dummy argument which can be used to - avoid the call to {\tt getCurrentCCS\#} being floated out by the + avoid the call to 'getCurrentCCS#' being floated out by the simplifier, which would result in an uninformative stack ("CAF"). } @@ -3405,8 +3694,8 @@ ------------------------------------------------------------------------ primop WhereFromOp "whereFrom#" GenPrimOp a -> State# s -> (# State# s, Addr# #) - { Returns the {\tt InfoProvEnt } for the info table of the given object - (value is {\tt NULL} if the table does not exist or there is no information + { 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 @@ -3417,13 +3706,13 @@ ------------------------------------------------------------------------ primtype FUN m a b - {The builtin function type, written in infix form as {\tt a # m -> b}. - Values of this type are functions taking inputs of type {\tt a} and - producing outputs of type {\tt b}. The multiplicity of the input is - {\tt m}. + {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 {\tt FUN m a b} permits representation polymorphism in both - {\tt a} and {\tt b}, so that types like {\tt Int\# -> Int\#} can still be + 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. } @@ -3431,78 +3720,78 @@ 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 {\tt GHC.Magic.runRW\#}. } + See also 'GHC.Magic.runRW#'. } pseudoop "void#" (# #) { This is an alias for the unboxed unit tuple constructor. - In earlier versions of GHC, {\tt void\#} was a value - of the primitive type {\tt Void\#}, which is now defined to be {\tt (\# \#)}. + 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 {\tt Proxy#} is used to bear witness to some + { 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 {\tt Proxy#} + 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 {\tt Proxy#} value, which has no runtime + { Witness for an unboxed 'Proxy#' value, which has no runtime representation. } pseudoop "seq" a -> b -> b - { The value of {\tt seq a b} is bottom if {\tt a} is bottom, and - otherwise equal to {\tt b}. In other words, it evaluates the first - argument {\tt a} to weak head normal form (WHNF). {\tt seq} is usually + { 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 {\tt seq a b} does - {\it not} guarantee that {\tt a} will be evaluated before {\tt b}. - The only guarantee given by {\tt seq} is that the both {\tt a} - and {\tt b} will be evaluated before {\tt seq} returns a value. - In particular, this means that {\tt b} may be evaluated before - {\tt a}. If you need to guarantee a specific order of evaluation, - you must use the function {\tt pseq} from the "parallel" package. } + 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 {\tt unsafeCoerce\#} allows you to side-step the typechecker entirely. That + { 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 {\tt unsafeCoerce\#} are supposed to work (i.e. not lead to + 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 {\tt Any} + * Casting any lifted type to 'Any' - * Casting {\tt Any} back to the real type + * 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 {\tt GHC.Float} module for functions to do 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 - {\tt Ptr Int} to {\tt Ptr Float}, or {\tt [Int]} to {\tt [Float]} when the list is - known to be empty. Also, a {\tt newtype} of a type {\tt T} has the same representation - at runtime as {\tt T}. + @'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 {\tt unsafeCoerce\#} are undefined. In particular, you should not use - {\tt unsafeCoerce\#} to cast a T to an algebraic data type D, unless T is also - an algebraic data type. For example, do not cast {\tt Int->Int} to {\tt Bool}, even if - you later cast that {\tt Bool} back to {\tt Int->Int} before applying it. The reasons + 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 {\tt Any}, which is not an algebraic data type. + to, use 'Any', which is not an algebraic data type. } with can_fail = True @@ -3519,7 +3808,7 @@ 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 {\tt .eventlog} file, + 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 @@ -3530,7 +3819,7 @@ { 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 {\tt .eventlog} file. } + emitted to the @.eventlog@ file. } with has_side_effects = True out_of_line = True @@ -3539,7 +3828,7 @@ 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 {\tt .eventlog} file, + 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 @@ -3553,9 +3842,9 @@ out_of_line = True primtype StackSnapshot# - { Haskell representation of a {\tt StgStack*} that was created (cloned) - with a function in {\tt GHC.Stack.CloneStack}. Please check the - documentation in this module for more detailed explanations. } + { 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" @@ -3563,7 +3852,7 @@ pseudoop "coerce" Coercible a b => a -> b - { The function {\tt coerce} allows you to safely convert between values of + { 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 @@ -3571,9 +3860,9 @@ concrete types. This function is representation-polymorphic, but the - {\tt RuntimeRep} type argument is marked as {\tt Inferred}, meaning + 'RuntimeRep' type argument is marked as 'Inferred', meaning that it is not available for visible type application. This means - the typechecker will accept {\tt coerce @Int @Age 42}. + the typechecker will accept @'coerce' @'Int' @Age 42@. } ------------------------------------------------------------------------ @@ -3678,7 +3967,7 @@ primop VecRemOp "rem#" GenPrimOp VECTOR -> VECTOR -> VECTOR - { Satisfies \texttt{(quot\# x y) times\# y plus\# (rem\# x y) == x}. } + { Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. } with can_fail = True llvm_only = True vector = INT_VECTOR_TYPES @@ -3819,10 +4108,10 @@ 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 {\tt prefetch*} family of operations has the order of operations - determined by passing around the {\tt State#} token. + 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 {\tt inlinePerformIO} which is quite safe in this context. + 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 @@ -3831,7 +4120,7 @@ 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/app violation, at least with the current design. + results in a let-can-float invariant violation, at least with the current design. } @@ -3908,6 +4197,35 @@ primop PrefetchValueOp0 "prefetchValue0#" GenPrimOp a -> State# s -> State# s with has_side_effects = True + + +-- Note [RuntimeRep polymorphism in continuation-style primops] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- See below. + +section "RuntimeRep polymorphism in continuation-style primops" + { + Several primops provided by GHC accept continuation arguments with highly polymorphic + arguments. For instance, consider the type of `catch#`: + + catch# :: forall (r_rep :: RuntimeRep) (r :: TYPE r_rep) w. + (State# RealWorld -> (# State# RealWorld, r #) ) + -> (w -> State# RealWorld -> (# State# RealWorld, r #) ) + -> State# RealWorld + -> (# State# RealWorld, r #) + + This type suggests that we could instantiate `catch#` continuation argument + (namely, the first argument) with something like, + + f :: State# RealWorld -> (# State# RealWorld, (# Int, String, Int8# #) #) + + However, sadly the type does not capture an important limitation of the + primop. Specifically, due to the operational behavior of `catch#` the result + type must be representable with a single machine word. In a future GHC + release we may improve the precision of this type to capture this limitation. + + See #21868. + } ------------------------------------------------------------------------ --- --- diff --git a/GHC/ByteCode/Asm.hs b/GHC/ByteCode/Asm.hs --- a/GHC/ByteCode/Asm.hs +++ b/GHC/ByteCode/Asm.hs @@ -315,7 +315,7 @@ words = concatMap expand ops expand (SmallOp w) = [w] expand (LabelOp w) = expand (Op (e w)) - expand (Op w) = if largeOps then largeArg platform w else [fromIntegral 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) @@ -358,7 +358,7 @@ largeArgInstr :: Word16 -> Word16 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci -largeArg :: Platform -> Word -> [Word16] +largeArg :: Platform -> Word64 -> [Word16] largeArg platform w = case platformWordSize platform of PW8 -> [fromIntegral (w `shiftR` 48), fromIntegral (w `shiftR` 32), @@ -395,7 +395,10 @@ 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 + PUSH_ALTS proto -> do let ul_bco = assembleBCO platform proto + p <- ioptr (liftM BCOPtrBCO ul_bco) + emit bci_PUSH_ALTS [Op p] + PUSH_ALTS_UNLIFTED proto pk -> do let ul_bco = assembleBCO platform proto p <- ioptr (liftM BCOPtrBCO ul_bco) emit (push_alts pk) [Op p] @@ -501,7 +504,8 @@ 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 -> emit bci_RETURN [] + RETURN_UNLIFTED rep -> emit (return_unlifted 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] @@ -570,16 +574,16 @@ 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" +return_unlifted :: ArgRep -> Word16 +return_unlifted V = bci_RETURN_V +return_unlifted P = bci_RETURN_P +return_unlifted N = bci_RETURN_N +return_unlifted L = bci_RETURN_L +return_unlifted F = bci_RETURN_F +return_unlifted D = bci_RETURN_D +return_unlifted V16 = error "return_unlifted: vector" +return_unlifted V32 = error "return_unlifted: vector" +return_unlifted V64 = error "return_unlifted: vector" {- we can only handle up to a fixed number of words on the stack, diff --git a/GHC/ByteCode/Instr.hs b/GHC/ByteCode/Instr.hs --- a/GHC/ByteCode/Instr.hs +++ b/GHC/ByteCode/Instr.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- -- (c) The University of Glasgow 2002-2006 @@ -71,12 +70,12 @@ | PUSH16 !Word16 | PUSH32 !Word16 - -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the + -- 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 -- a word) -- This is useful when extracting a packed constructor field for further use. -- Currently we expect all values on the stack to take full words, except for - -- the ones used for PACK (i.e., actually constracting new data types, in + -- 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 @@ -88,7 +87,8 @@ | PUSH_BCO (ProtoBCO Name) -- Push an alt continuation - | PUSH_ALTS (ProtoBCO Name) ArgRep + | PUSH_ALTS (ProtoBCO Name) + | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep | PUSH_ALTS_TUPLE (ProtoBCO Name) -- continuation !NativeCallInfo (ProtoBCO Name) -- tuple return BCO @@ -196,10 +196,9 @@ -- To Infinity And Beyond | ENTER - | RETURN ArgRep -- return a non-tuple value, here's its rep; see - -- Note [Return convention for non-tuple values] in GHC.StgToByteCode - | RETURN_TUPLE -- return an unboxed tuple (info already on stack); see - -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode + | RETURN -- return a lifted value + | RETURN_UNLIFTED ArgRep -- return an unlifted value, here's its rep + | RETURN_TUPLE -- return an unboxed tuple (info already on stack) -- Breakpoints | BRK_FUN Word16 Unique (RemotePtr CostCentre) @@ -274,7 +273,8 @@ <> ppr op ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco) - ppr (PUSH_ALTS bco pk) = hang (text "PUSH_ALTS" <+> ppr pk) 2 (ppr bco) + ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco) + ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco) ppr (PUSH_ALTS_TUPLE bco call_info tuple_bco) = hang (text "PUSH_ALTS_TUPLE" <+> ppr call_info) 2 @@ -340,9 +340,9 @@ 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 marshall_addr flags) = text "CCALL " <+> ppr off - <+> text "marshall code at" - <+> text (show marshall_addr) + ppr (CCALL off marshal_addr flags) = text "CCALL " <+> ppr off + <+> text "marshal code at" + <+> text (show marshal_addr) <+> (case flags of 0x1 -> text "(interruptible)" 0x2 -> text "(unsafe)" @@ -351,12 +351,10 @@ 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 = text "RETURN" + ppr (RETURN_UNLIFTED pk) = text "RETURN_UNLIFTED " <+> ppr pk ppr (RETURN_TUPLE) = text "RETURN_TUPLE" - ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> mb_uniq <+> text "" - where mb_uniq = sdocOption sdocSuppressUniques $ \case - True -> text "" - False -> ppr uniq + ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "" @@ -387,8 +385,10 @@ bciStackUse PUSH_G{} = 1 bciStackUse PUSH_PRIMOP{} = 1 bciStackUse PUSH_BCO{} = 1 -bciStackUse (PUSH_ALTS bco _) = 2 {- profiling only, restore CCCS -} + +bciStackUse (PUSH_ALTS bco) = 2 {- profiling only, restore CCCS -} + 3 + protoBCOStackUse bco +bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 {- profiling only, restore CCCS -} + + 4 + protoBCOStackUse bco bciStackUse (PUSH_ALTS_TUPLE bco info _) = -- (tuple_bco, call_info word, cont_bco, stg_ctoi_t) -- tuple @@ -448,7 +448,8 @@ bciStackUse CASEFAIL{} = 0 bciStackUse JMP{} = 0 bciStackUse ENTER{} = 0 -bciStackUse RETURN{} = 1 -- pushes stg_ret_X for some X +bciStackUse RETURN{} = 0 +bciStackUse RETURN_UNLIFTED{} = 1 -- pushes stg_ret_X for some X bciStackUse RETURN_TUPLE{} = 1 -- pushes stg_ret_t header bciStackUse CCALL{} = 0 bciStackUse PRIMCALL{} = 1 -- pushes stg_primcall diff --git a/GHC/ByteCode/Linker.hs b/GHC/ByteCode/Linker.hs --- a/GHC/ByteCode/Linker.hs +++ b/GHC/ByteCode/Linker.hs @@ -28,7 +28,6 @@ import GHC.Builtin.Names import GHC.Unit.Types -import GHC.Unit.Module.Name import GHC.Data.FastString import GHC.Data.SizedSeq @@ -41,6 +40,8 @@ import GHC.Types.Name import GHC.Types.Name.Env + +import Language.Haskell.Syntax.Module.Name -- Standard libraries import Data.Array.Unboxed diff --git a/GHC/ByteCode/Types.hs b/GHC/ByteCode/Types.hs --- a/GHC/ByteCode/Types.hs +++ b/GHC/ByteCode/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -- -- (c) The University of Glasgow 2002-2006 -- @@ -120,7 +121,7 @@ ppr NativeCallInfo{..} = text " ppr nativeCallSize <+> text "stack" <+> ppr nativeCallStackSpillSize <+> text "regs" <+> - ppr (map (text . show) $ regSetToList nativeCallRegs) <> + ppr (map (text @SDoc . show) $ regSetToList nativeCallRegs) <> char '>' diff --git a/GHC/Cmm.hs b/GHC/Cmm.hs --- a/GHC/Cmm.hs +++ b/GHC/Cmm.hs @@ -6,13 +6,17 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE EmptyCase #-} module GHC.Cmm ( -- * Cmm top-level datatypes CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup, CmmDecl, CmmDeclSRTs, GenCmmDecl(..), + CmmDataDecl, cmmDataDeclCmmDecl, CmmGraph, GenCmmGraph(..), + toBlockMap, revPostorder, toBlockList, CmmBlock, RawCmmDecl, Section(..), SectionType(..), GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..), @@ -30,10 +34,14 @@ -- * Statements, expressions and types module GHC.Cmm.Node, module GHC.Cmm.Expr, + + -- * Pretty-printing + pprCmmGroup, pprSection, pprStatic ) where import GHC.Prelude +import GHC.Platform import GHC.Types.Id import GHC.Types.CostCentre import GHC.Cmm.CLabel @@ -46,7 +54,11 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Utils.Outputable + +import Data.Void (Void) +import Data.List (intersperse) import Data.ByteString (ByteString) +import qualified Data.ByteString as BS ----------------------------------------------------------------------------- -- Cmm, GenCmm @@ -102,9 +114,21 @@ deriving (Functor) +instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) + => OutputableP Platform (GenCmmDecl d info i) where + pdoc = pprTop + type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph +type CmmDataDecl = GenCmmDataDecl CmmStatics +type GenCmmDataDecl d = GenCmmDecl d Void Void -- When `CmmProc` case can be statically excluded +cmmDataDeclCmmDecl :: GenCmmDataDecl d -> GenCmmDecl d h g +cmmDataDeclCmmDecl = \ case + CmmProc void _ _ _ -> case void of + CmmData section d -> CmmData section d +{-# INLINE cmmDataDeclCmmDecl #-} + type RawCmmDecl = GenCmmDecl RawCmmStatics @@ -119,6 +143,29 @@ data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } type CmmBlock = Block CmmNode C C +instance OutputableP Platform CmmGraph where + pdoc = pprCmmGraph + +toBlockMap :: CmmGraph -> LabelMap CmmBlock +toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body + +pprCmmGraph :: Platform -> CmmGraph -> SDoc +pprCmmGraph platform g + = text "{" <> text "offset" + $$ nest 2 (vcat $ map (pdoc platform) blocks) + $$ text "}" + where blocks = revPostorder g + -- revPostorder has the side-effect of discarding unreachable code, + -- so pretty-printed Cmm will omit any unreachable blocks. This can + -- sometimes be confusing. + +revPostorder :: CmmGraph -> [CmmBlock] +revPostorder g = {-# SCC "revPostorder" #-} + revPostorderFrom (toBlockMap g) (g_entry g) + +toBlockList :: CmmGraph -> [CmmBlock] +toBlockList g = mapElems $ toBlockMap g + ----------------------------------------------------------------------------- -- Info Tables ----------------------------------------------------------------------------- @@ -128,6 +175,14 @@ data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable , stack_info :: CmmStackInfo } +instance OutputableP Platform CmmTopInfo where + pdoc = pprTopInfo + +pprTopInfo :: Platform -> CmmTopInfo -> SDoc +pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = + vcat [text "info_tbls: " <> pdoc platform info_tbl, + text "stack_info: " <> ppr stack_info] + topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) topInfoTable _ = Nothing @@ -145,6 +200,13 @@ -- we want to do the stack manipulation manually. } +instance Outputable CmmStackInfo where + ppr = pprStackInfo + +pprStackInfo :: CmmStackInfo -> SDoc +pprStackInfo (StackInfo {arg_space=arg_space}) = + text "arg_space: " <> ppr arg_space + -- | Info table as a haskell data type data CmmInfoTable = CmmInfoTable { @@ -169,6 +231,10 @@ -- GHC.Cmm.Info.Build.doSRTs. } deriving Eq +instance OutputableP Platform CmmInfoTable where + pdoc = pprInfoTable + + data ProfilingInfo = NoProfilingInfo | ProfilingInfo ByteString ByteString -- closure_type, closure_desc @@ -183,7 +249,6 @@ | ReadOnlyData | RelocatableReadOnlyData | UninitialisedData - | ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned -- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini | InitArray -- .init_array on ELF, .ctor on Windows | FiniArray -- .fini_array on ELF, .dtor on Windows @@ -203,7 +268,6 @@ Text -> ReadOnlySection ReadOnlyData -> ReadOnlySection RelocatableReadOnlyData -> WriteProtectedSection - ReadOnlyData16 -> ReadOnlySection InitArray -> ReadOnlySection FiniArray -> ReadOnlySection CString -> ReadOnlySection @@ -230,14 +294,17 @@ -- ^ uninitialised data, N bytes long | CmmString ByteString -- ^ string of 8-bit values only, not zero terminated. - | CmmFileEmbed FilePath - -- ^ an embedded binary file + | CmmFileEmbed FilePath Int + -- ^ an embedded binary file and its byte length +instance OutputableP Platform CmmStatic where + pdoc = pprStatic + instance Outputable CmmStatic where ppr (CmmStaticLit lit) = text "CmmStaticLit" <+> ppr lit ppr (CmmUninitialised n) = text "CmmUninitialised" <+> ppr n ppr (CmmString _) = text "CmmString" - ppr (CmmFileEmbed fp) = text "CmmFileEmbed" <+> text fp + ppr (CmmFileEmbed fp _) = text "CmmFileEmbed" <+> text fp -- Static data before SRT generation data GenCmmStatics (rawOnly :: Bool) where @@ -246,6 +313,9 @@ -> CmmInfoTable -> CostCentreStack -> [CmmLit] -- Payload + -> [CmmLit] -- Non-pointers that go to the end of the closure + -- This is used by stg_unpack_cstring closures. + -- See Note [unpack_cstring closures] in StgStdThunks.cmm. -> GenCmmStatics 'False -- | Static data, after SRTs are generated @@ -254,6 +324,9 @@ -> [CmmStatic] -- The static data itself -> GenCmmStatics a +instance OutputableP Platform (GenCmmStatics a) where + pdoc = pprStatics + type CmmStatics = GenCmmStatics 'False type RawCmmStatics = GenCmmStatics 'True @@ -293,3 +366,115 @@ pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc pprBBlock (BasicBlock ident stmts) = hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) + + +-- -------------------------------------------------------------------------- +-- Pretty-printing Cmm +-- -------------------------------------------------------------------------- +-- +-- This is where we walk over Cmm emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We +-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. + +pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g) + => Platform -> GenCmmGroup d info g -> SDoc +pprCmmGroup platform tops + = vcat $ intersperse blankLine $ map (pprTop platform) tops + +-- -------------------------------------------------------------------------- +-- Top level `procedure' blocks. +-- + +pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) + => Platform -> GenCmmDecl d info i -> SDoc + +pprTop platform (CmmProc info lbl live graph) + + = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live + , nest 8 $ lbrace <+> pdoc platform info $$ rbrace + , nest 4 $ pdoc platform graph + , rbrace ] + +-- -------------------------------------------------------------------------- +-- We follow [1], 4.5 +-- +-- section "data" { ... } +-- + +pprTop platform (CmmData section ds) = + (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds)) + $$ rbrace + +-- -------------------------------------------------------------------------- +-- Pretty-printing info tables +-- -------------------------------------------------------------------------- + +pprInfoTable :: Platform -> CmmInfoTable -> SDoc +pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep + , cit_prof = prof_info + , cit_srt = srt }) + = vcat [ text "label: " <> pdoc platform lbl + , text "rep: " <> ppr rep + , case prof_info of + NoProfilingInfo -> empty + ProfilingInfo ct cd -> + vcat [ text "type: " <> text (show (BS.unpack ct)) + , text "desc: " <> text (show (BS.unpack cd)) ] + , text "srt: " <> pdoc platform srt ] + +-- -------------------------------------------------------------------------- +-- Static data. +-- Strings are printed as C strings, and we print them as I8[], +-- following C-- +-- + +pprStatics :: Platform -> GenCmmStatics a -> SDoc +pprStatics platform (CmmStatics lbl itbl ccs payload extras) = + pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload <+> ppr extras +pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds) + +pprStatic :: Platform -> CmmStatic -> SDoc +pprStatic platform s = case s of + CmmStaticLit lit -> nest 4 $ text "const" <+> pdoc platform lit <> semi + CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) + CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') + CmmFileEmbed path _ -> nest 4 $ text "incbin " <+> text (show path) + +-- -------------------------------------------------------------------------- +-- data sections +-- +pprSection :: Platform -> Section -> SDoc +pprSection platform (Section t suffix) = + section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix) + where + section = text "section" + +pprSectionType :: SectionType -> SDoc +pprSectionType s = doubleQuotes $ case s of + Text -> text "text" + Data -> text "data" + ReadOnlyData -> text "readonly" + RelocatableReadOnlyData -> text "relreadonly" + UninitialisedData -> text "uninitialised" + InitArray -> text "initarray" + FiniArray -> text "finiarray" + CString -> text "cstring" + OtherSection s' -> text s' diff --git a/GHC/Cmm/BlockId.hs b/GHC/Cmm/BlockId.hs --- a/GHC/Cmm/BlockId.hs +++ b/GHC/Cmm/BlockId.hs @@ -11,6 +11,7 @@ import GHC.Prelude import GHC.Cmm.CLabel +import GHC.Data.FastString import GHC.Types.Id.Info import GHC.Types.Name import GHC.Types.Unique @@ -43,4 +44,4 @@ infoTblLbl :: BlockId -> CLabel infoTblLbl label - = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs + = mkBlockInfoTableLabel (mkFCallName (getUnique label) (fsLit "block")) NoCafRefs diff --git a/GHC/Cmm/CLabel.hs b/GHC/Cmm/CLabel.hs --- a/GHC/Cmm/CLabel.hs +++ b/GHC/Cmm/CLabel.hs @@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- --- Object-file symbols (called CLabel for histerical raisins). +-- Object-file symbols (called CLabel for historical reasons). -- -- (c) The University of Glasgow 2004-2006 -- @@ -65,7 +65,6 @@ mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel, mkOutOfBoundsAccessLabel, - mkMemcpyRangeOverlapLabel, mkArrWords_infoLabel, mkSRTInfoLabel, @@ -73,6 +72,8 @@ mkCAFBlackHoleInfoTableLabel, mkRtsPrimOpLabel, mkRtsSlowFastTickyCtrLabel, + mkRtsUnpackCStringLabel, + mkRtsUnpackCStringUtf8Label, mkSelectorInfoLabel, mkSelectorEntryLabel, @@ -109,6 +110,7 @@ isLocalCLabel, mayRedirectTo, isInfoTableLabel, + isCmmInfoTableLabel, isConInfoTableLabel, isIdLabel, isTickyLabel, @@ -129,6 +131,7 @@ LabelStyle (..), pprDebugCLabel, pprCLabel, + pprAsmLabel, ppInternalProcLabel, -- * Others @@ -153,10 +156,11 @@ import GHC.Data.FastString import GHC.Platform import GHC.Types.Unique.Set -import GHC.Utils.Misc import GHC.Core.Ppr ( {- instances -} ) import GHC.Types.SrcLoc +import qualified Data.Semigroup as S + -- ----------------------------------------------------------------------------- -- The CLabel type @@ -295,23 +299,22 @@ instance Show CLabel where show = showPprUnsafe . pprDebugCLabel genericPlatform -instance Outputable CLabel where - ppr = text . show - data ModuleLabelKind - = MLK_Initializer String + = MLK_Initializer LexicalFastString | MLK_InitializerArray - | MLK_Finalizer String + | MLK_Finalizer LexicalFastString | MLK_FinalizerArray | MLK_IPEBuffer deriving (Eq, Ord) -instance Outputable ModuleLabelKind where - ppr MLK_InitializerArray = text "init_arr" - ppr (MLK_Initializer s) = text ("init__" ++ s) - ppr MLK_FinalizerArray = text "fini_arr" - ppr (MLK_Finalizer s) = text ("fini__" ++ s) - ppr MLK_IPEBuffer = text "ipe_buf" +pprModuleLabelKind :: IsLine doc => ModuleLabelKind -> doc +pprModuleLabelKind MLK_InitializerArray = text "init_arr" +pprModuleLabelKind (MLK_Initializer (LexicalFastString s)) = text "init__" <> ftext s +pprModuleLabelKind MLK_FinalizerArray = text "fini_arr" +pprModuleLabelKind (MLK_Finalizer (LexicalFastString s)) = text "fini__" <> ftext s +pprModuleLabelKind MLK_IPEBuffer = text "ipe_buf" +{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> SDoc #-} +{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable isIdLabel :: CLabel -> Bool isIdLabel IdLabel{} = True @@ -348,26 +351,26 @@ -- code-generation. See Note [Unique Determinism and code generation] instance Ord CLabel where compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) = - compare a1 a2 `thenCmp` - compare b1 b2 `thenCmp` + 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 `thenCmp` - compare b1 b2 `thenCmp` + 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. - uniqCompareFS c1 c2 `thenCmp` + 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) = - uniqCompareFS a1 a2 `thenCmp` - compare b1 b2 `thenCmp` - compare c1 c2 `thenCmp` + uniqCompareFS a1 a2 S.<> + compare b1 b2 S.<> + compare c1 c2 S.<> compare d1 d2 compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2 compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) = - compare a1 a2 `thenCmp` + compare a1 a2 S.<> lexicalCompareFS b1 b2 compare (StringLitLabel u1) (StringLitLabel u2) = nonDetCmpUnique u1 u2 @@ -378,10 +381,10 @@ compare (IPE_Label a1) (IPE_Label a2) = compare a1 a2 compare (ModuleLabel m1 k1) (ModuleLabel m2 k2) = - compare m1 m2 `thenCmp` + compare m1 m2 S.<> compare k1 k2 compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) = - compare a1 a2 `thenCmp` + compare a1 a2 S.<> compare b1 b2 compare PicBaseLabel PicBaseLabel = EQ compare (DeadStripPreventer a1) (DeadStripPreventer a2) = @@ -454,7 +457,7 @@ -- The regular Outputable instance only shows the label name, and not its other info. -- pprDebugCLabel :: Platform -> CLabel -> SDoc -pprDebugCLabel platform lbl = pprCLabel platform AsmStyle lbl <> parens extra +pprDebugCLabel platform lbl = pprAsmLabel platform lbl <> parens extra where extra = case lbl of IdLabel _ _ info @@ -563,6 +566,8 @@ | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- ^ AP thunks | RtsApEntry Bool{-updatable-} Int{-arity-} + | RtsUnpackCStringInfoTable + | RtsUnpackCStringUtf8InfoTable | RtsPrimOp PrimOp | RtsApFast NonDetFastString -- ^ _fast versions of generic apply | RtsSlowFastTickyCtr String @@ -617,7 +622,7 @@ mkConInfoTableLabel :: Name -> ConInfoTableLocation -> CLabel mkBytesLabel :: Name -> CLabel mkClosureLabel name c = IdLabel name c Closure --- | Decicdes between external and local labels based on the names externality. +-- | Decides between external and local labels based on the names externality. mkInfoTableLabel name c | isExternalName name = IdLabel name c InfoTable | otherwise = IdLabel name c LocalInfoTable @@ -644,8 +649,7 @@ mkCAFBlackHoleInfoTableLabel, mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel, mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel, - mkOutOfBoundsAccessLabel, mkMemcpyRangeOverlapLabel, - mkMUT_VAR_CLEAN_infoLabel :: CLabel + mkOutOfBoundsAccessLabel, mkMUT_VAR_CLEAN_infoLabel :: CLabel mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData @@ -663,8 +667,7 @@ 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") Nothing ForeignLabelInExternalPackage IsFunction mkMUT_VAR_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN") CmmInfo mkSRTInfoLabel :: Int -> CLabel @@ -737,7 +740,6 @@ assert (arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform)) $ RtsLabel (RtsApEntry upd arity) - -- A call to some primitive hand written Cmm code mkPrimCallLabel :: PrimCall -> CLabel mkPrimCallLabel (PrimCall str pkg) @@ -800,8 +802,14 @@ isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True isInfoTableLabel (IdLabel _ _ ConInfoTable {}) = True isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True +isInfoTableLabel (CmmLabel _ _ _ CmmInfo) = True isInfoTableLabel _ = False +-- | Whether label points to an info table defined in Cmm +isCmmInfoTableLabel :: CLabel -> Bool +isCmmInfoTableLabel (CmmLabel _ _ _ CmmInfo) = True +isCmmInfoTableLabel _ = False + -- | Whether label is points to constructor info table isConInfoTableLabel :: CLabel -> Bool isConInfoTableLabel (IdLabel _ _ ConInfoTable {}) = True @@ -832,6 +840,9 @@ -- Position and information about the info table deriving (Eq, Ord) +instance OutputableP Platform InfoProvEnt where + pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel + -- Constructing Cost Center Labels mkCCLabel :: CostCentre -> CLabel mkCCSLabel :: CostCentreStack -> CLabel @@ -846,6 +857,11 @@ mkRtsSlowFastTickyCtrLabel :: String -> CLabel mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat) +-- | A standard string unpacking thunk. See Note [unpack_cstring closures] in +-- StgStdThunks.cmm. +mkRtsUnpackCStringLabel, mkRtsUnpackCStringUtf8Label :: CLabel +mkRtsUnpackCStringLabel = RtsLabel RtsUnpackCStringInfoTable +mkRtsUnpackCStringUtf8Label = RtsLabel RtsUnpackCStringUtf8InfoTable -- Constructing Code Coverage Labels mkHpcTicksLabel :: Module -> CLabel @@ -871,15 +887,15 @@ mkStringLitLabel :: Unique -> CLabel mkStringLitLabel = StringLitLabel -mkInitializerStubLabel :: Module -> String -> CLabel -mkInitializerStubLabel mod s = ModuleLabel mod (MLK_Initializer s) +mkInitializerStubLabel :: Module -> FastString -> CLabel +mkInitializerStubLabel mod s = ModuleLabel mod (MLK_Initializer (LexicalFastString s)) mkInitializerArrayLabel :: Module -> CLabel mkInitializerArrayLabel mod = ModuleLabel mod MLK_InitializerArray -mkFinalizerStubLabel :: Module -> String -> CLabel -mkFinalizerStubLabel mod s = ModuleLabel mod (MLK_Finalizer s) +mkFinalizerStubLabel :: Module -> FastString -> CLabel +mkFinalizerStubLabel mod s = ModuleLabel mod (MLK_Finalizer (LexicalFastString s)) mkFinalizerArrayLabel :: Module -> CLabel mkFinalizerArrayLabel mod = ModuleLabel mod MLK_FinalizerArray @@ -952,6 +968,9 @@ hasCAF :: CLabel -> Bool hasCAF (IdLabel _ _ (IdTickyInfo TickyRednCounts)) = False -- See Note [ticky for LNE] hasCAF (IdLabel _ MayHaveCafRefs _) = True +hasCAF (RtsLabel RtsUnpackCStringInfoTable) = True +hasCAF (RtsLabel RtsUnpackCStringUtf8InfoTable) = True + -- The info table stg_MK_STRING_info is for thunks hasCAF _ = False -- Note [ticky for LNE] @@ -1187,9 +1206,15 @@ labelType (CmmLabel _ _ _ CmmRetInfo) = DataLabel labelType (CmmLabel _ _ _ CmmRet) = CodeLabel labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel +labelType (RtsLabel (RtsSelectorEntry _ _)) = CodeLabel labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel +labelType (RtsLabel (RtsApEntry _ _)) = CodeLabel labelType (RtsLabel (RtsApFast _)) = CodeLabel -labelType (RtsLabel _) = DataLabel +labelType (RtsLabel RtsUnpackCStringInfoTable) = DataLabel +labelType (RtsLabel RtsUnpackCStringUtf8InfoTable) + = DataLabel +labelType (RtsLabel (RtsPrimOp _)) = CodeLabel +labelType (RtsLabel (RtsSlowFastTickyCtr _)) = DataLabel labelType (LocalBlockLabel _) = CodeLabel labelType (SRTLabel _) = DataLabel labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel @@ -1359,7 +1384,6 @@ ordinary Haskell function of arity 1 that allocates a (Just x) box: Just = \x -> Just x - Just_entry: The entry code for the worker function Just_closure: The closure for this worker Nothing_closure: a statically allocated closure for Nothing @@ -1397,49 +1421,71 @@ -} +-- | 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. +-- +data LabelStyle + = CStyle -- ^ C label style (used by C and LLVM backends) + | AsmStyle -- ^ Asm label style (used by NCG backend) + +pprAsmLabel :: IsLine doc => Platform -> CLabel -> doc +pprAsmLabel platform lbl = pprCLabelStyle platform AsmStyle lbl +{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> SDoc #-} +{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + +pprCLabel :: IsLine doc => Platform -> CLabel -> doc +pprCLabel platform lbl = pprCLabelStyle platform CStyle lbl +{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> SDoc #-} +{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + instance OutputableP Platform CLabel where {-# INLINE pdoc #-} -- see Note [Bangs in CLabel] pdoc !platform lbl = getPprStyle $ \pp_sty -> - let !sty = case pp_sty of - PprCode sty -> sty - _ -> CStyle - in pprCLabel platform sty lbl + case pp_sty of + PprDump{} -> pprCLabel platform lbl + _ -> let lbl_doc = (pprCLabel platform lbl) + in pprTraceUserWarning (text "Labels in code should be printed with pprCLabel or pprAsmLabel" <> lbl_doc) lbl_doc -pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc -pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel] +pprCLabelStyle :: forall doc. IsLine doc => Platform -> LabelStyle -> CLabel -> doc +pprCLabelStyle !platform !sty lbl = -- see Note [Bangs in CLabel] let !use_leading_underscores = platformLeadingUnderscore platform -- some platform (e.g. Darwin) require a leading "_" for exported asm -- symbols - maybe_underscore :: SDoc -> SDoc + maybe_underscore :: doc -> doc maybe_underscore doc = case sty of AsmStyle | use_leading_underscores -> pp_cSEP <> doc _ -> doc - tempLabelPrefixOrUnderscore :: Platform -> SDoc - tempLabelPrefixOrUnderscore platform = case sty of + tempLabelPrefixOrUnderscore :: doc + tempLabelPrefixOrUnderscore = case sty of AsmStyle -> asmTempLabelPrefix platform CStyle -> char '_' in case lbl of LocalBlockLabel u -> case sty of - AsmStyle -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u - CStyle -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u + AsmStyle -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u + CStyle -> tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u AsmTempLabel u - -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u + -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u AsmTempDerivedLabel l suf -> asmTempLabelPrefix platform <> case l of AsmTempLabel u -> pprUniqueAlways u LocalBlockLabel u -> pprUniqueAlways u - _other -> pprCLabel platform sty l + _other -> pprCLabelStyle platform sty l <> ftext suf DynamicLinkerLabel info lbl - -> pprDynamicLinkerAsmLabel platform info (pprCLabel platform AsmStyle lbl) + -> pprDynamicLinkerAsmLabel platform info (pprAsmLabel platform lbl) PicBaseLabel -> text "1b" @@ -1452,7 +1498,7 @@ optional `_` (underscore) because this is how you mark non-temp symbols on some platforms (Darwin) -} - maybe_underscore $ text "dsp_" <> pprCLabel platform sty lbl <> text "_dsp" + maybe_underscore $ text "dsp_" <> pprCLabelStyle platform sty lbl <> text "_dsp" StringLitLabel u -> maybe_underscore $ pprUniqueAlways u <> text "_str" @@ -1469,69 +1515,74 @@ IdLabel name _cafs flavor -> case sty of - AsmStyle -> maybe_underscore $ internalNamePrefix <> ppr name <> ppIdFlavor flavor + AsmStyle -> maybe_underscore $ internalNamePrefix <> pprName name <> ppIdFlavor flavor where isRandomGenerated = not (isExternalName name) internalNamePrefix = if isRandomGenerated then asmTempLabelPrefix platform else empty - CStyle -> ppr name <> ppIdFlavor flavor + CStyle -> pprName name <> ppIdFlavor flavor SRTLabel u - -> maybe_underscore $ tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt" + -> maybe_underscore $ tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt" RtsLabel (RtsApFast (NonDetFastString str)) -> maybe_underscore $ ftext str <> text "_fast" RtsLabel (RtsSelectorInfoTable upd_reqd offset) - -> maybe_underscore $ hcat [ text "stg_sel_", text (show offset) + -> maybe_underscore $ hcat [ text "stg_sel_", int offset , if upd_reqd then text "_upd_info" else text "_noupd_info" ] RtsLabel (RtsSelectorEntry upd_reqd offset) - -> maybe_underscore $ hcat [ text "stg_sel_", text (show offset) + -> maybe_underscore $ hcat [ text "stg_sel_", int offset , if upd_reqd then text "_upd_entry" else text "_noupd_entry" ] RtsLabel (RtsApInfoTable upd_reqd arity) - -> maybe_underscore $ hcat [ text "stg_ap_", text (show arity) + -> maybe_underscore $ hcat [ text "stg_ap_", int arity , if upd_reqd then text "_upd_info" else text "_noupd_info" ] RtsLabel (RtsApEntry upd_reqd arity) - -> maybe_underscore $ hcat [ text "stg_ap_", text (show arity) + -> maybe_underscore $ hcat [ text "stg_ap_", int arity , if upd_reqd then text "_upd_entry" else text "_noupd_entry" ] RtsLabel (RtsPrimOp primop) - -> maybe_underscore $ text "stg_" <> ppr primop + -> maybe_underscore $ text "stg_" <> pprPrimOp primop RtsLabel (RtsSlowFastTickyCtr pat) -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> text "_ctr" + RtsLabel RtsUnpackCStringInfoTable + -> maybe_underscore $ text "stg_unpack_cstring_info" + RtsLabel RtsUnpackCStringUtf8InfoTable + -> maybe_underscore $ text "stg_unpack_cstring_utf8_info" + LargeBitmapLabel u - -> maybe_underscore $ tempLabelPrefixOrUnderscore platform + -> maybe_underscore $ tempLabelPrefixOrUnderscore <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm" -- Some bitmaps for tuple constructors have a numeric tag (e.g. '7') -- until that gets resolved we'll just force them to start -- with a letter so the label will be legal assembly code. HpcTicksLabel mod - -> maybe_underscore $ text "_hpc_tickboxes_" <> ppr mod <> text "_hpc" + -> maybe_underscore $ text "_hpc_tickboxes_" <> pprModule mod <> text "_hpc" - CC_Label cc -> maybe_underscore $ ppr cc - CCS_Label ccs -> maybe_underscore $ ppr ccs - IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCode CStyle (pdoc platform l) <> text "_" <> ppr m <> text "_ipe") - ModuleLabel mod kind -> maybe_underscore $ ppr mod <> text "_" <> ppr kind + CC_Label cc -> maybe_underscore $ pprCostCentre cc + CCS_Label ccs -> maybe_underscore $ pprCostCentreStack ccs + IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform l <> text "_" <> pprModule m <> text "_ipe") + ModuleLabel mod kind -> maybe_underscore $ pprModule mod <> text "_" <> pprModuleLabelKind kind CmmLabel _ _ fs CmmCode -> maybe_underscore $ ftext fs CmmLabel _ _ fs CmmData -> maybe_underscore $ ftext fs @@ -1541,6 +1592,8 @@ CmmLabel _ _ fs CmmRetInfo -> maybe_underscore $ ftext fs <> text "_info" CmmLabel _ _ fs CmmRet -> maybe_underscore $ ftext fs <> text "_ret" CmmLabel _ _ fs CmmClosure -> maybe_underscore $ ftext fs <> text "_closure" +{-# SPECIALIZE pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> SDoc #-} +{-# SPECIALIZE pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- Note [Internal proc labels] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1561,21 +1614,24 @@ -- | Generate a label for a procedure internal to a module (if -- 'Opt_ExposeAllSymbols' is enabled). -- See Note [Internal proc labels]. -ppInternalProcLabel :: Module -- ^ the current module +ppInternalProcLabel :: IsLine doc + => Module -- ^ the current module -> CLabel - -> Maybe SDoc -- ^ the internal proc label + -> Maybe doc -- ^ the internal proc label ppInternalProcLabel this_mod (IdLabel nm _ flavour) | isInternalName nm = Just - $ text "_" <> ppr this_mod + $ text "_" <> pprModule this_mod <> char '_' <> ztext (zEncodeFS (occNameFS (occName nm))) <> char '_' <> pprUniqueAlways (getUnique nm) <> ppIdFlavor flavour ppInternalProcLabel _ _ = Nothing +{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe SDoc #-} +{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -ppIdFlavor :: IdLabelInfo -> SDoc +ppIdFlavor :: IsLine doc => IdLabelInfo -> doc ppIdFlavor x = pp_cSEP <> case x of Closure -> text "closure" InfoTable -> text "info" @@ -1586,22 +1642,22 @@ IdTickyInfo TickyRednCounts -> text "ct" IdTickyInfo (TickyInferedTag unique) - -> text "ct_inf_tag" <> char '_' <> ppr unique + -> text "ct_inf_tag" <> char '_' <> pprUniqueAlways unique ConEntry loc -> case loc of DefinitionSite -> text "con_entry" UsageSite m n -> - ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_entry" + pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_entry" ConInfoTable k -> case k of DefinitionSite -> text "con_info" UsageSite m n -> - ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_info" + pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_info" ClosureTable -> text "closure_tbl" Bytes -> text "bytes" BlockInfoTable -> text "info" -pp_cSEP :: SDoc +pp_cSEP :: IsLine doc => doc pp_cSEP = char '_' @@ -1615,13 +1671,13 @@ -- ----------------------------------------------------------------------------- -- Machine-dependent knowledge about labels. -asmTempLabelPrefix :: Platform -> SDoc -- for formatting labels +asmTempLabelPrefix :: IsLine doc => Platform -> doc -- for formatting labels asmTempLabelPrefix !platform = case platformOS platform of OSDarwin -> text "L" OSAIX -> text "__L" -- follow IBM XL C's convention _ -> text ".L" -pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc +pprDynamicLinkerAsmLabel :: IsLine doc => Platform -> DynamicLinkerLabelInfo -> doc -> doc pprDynamicLinkerAsmLabel !platform dllInfo ppLbl = case platformOS platform of OSDarwin diff --git a/GHC/Cmm/CLabel.hs-boot b/GHC/Cmm/CLabel.hs-boot --- a/GHC/Cmm/CLabel.hs-boot +++ b/GHC/Cmm/CLabel.hs-boot @@ -5,5 +5,4 @@ data CLabel -pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc - +pprCLabel :: IsLine doc => Platform -> CLabel -> doc diff --git a/GHC/Cmm/CallConv.hs b/GHC/Cmm/CallConv.hs --- a/GHC/Cmm/CallConv.hs +++ b/GHC/Cmm/CallConv.hs @@ -12,7 +12,6 @@ import GHC.Cmm.Expr import GHC.Runtime.Heap.Layout import GHC.Cmm (Convention(..)) -import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Platform import GHC.Platform.Profile diff --git a/GHC/Cmm/CommonBlockElim.hs b/GHC/Cmm/CommonBlockElim.hs --- a/GHC/Cmm/CommonBlockElim.hs +++ b/GHC/Cmm/CommonBlockElim.hs @@ -18,16 +18,17 @@ 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 import Data.Word import qualified Data.Map as M -import GHC.Utils.Outputable -import GHC.Utils.Panic import qualified GHC.Data.TrieMap as TM import GHC.Types.Unique.FM import GHC.Types.Unique import Control.Arrow (first, second) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE -- ----------------------------------------------------------------------------- -- Eliminate common blocks @@ -81,7 +82,7 @@ | mapNull new_substs = subst | otherwise = iterate subst' updated_blocks where - grouped_blocks :: [[(Key, [DistinctBlocks])]] + grouped_blocks :: [[(Key, NonEmpty DistinctBlocks)]] grouped_blocks = map groupByLabel blocks merged_blocks :: [[(Key, DistinctBlocks)]] @@ -106,9 +107,8 @@ -- This block is not a duplicate, keep it. Nothing -> second (b:) $ go bs -mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks) -mergeBlockList _ [] = pprPanic "mergeBlockList" empty -mergeBlockList subst (b:bs) = go mapEmpty b bs +mergeBlockList :: Subst -> NonEmpty DistinctBlocks -> (Subst, DistinctBlocks) +mergeBlockList subst (b:|bs) = go mapEmpty b bs where go !new_subst1 b [] = (new_subst1, b) go !new_subst1 b1 (b2:bs) = go new_subst b bs @@ -214,7 +214,7 @@ = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2 eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1) (CmmUnsafeForeignCall t2 r2 a2) - = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2 + = t1 == t2 && r1 == r2 && liftEq (eqExprWith eqBid) a1 a2 eqMiddleWith _ _ _ = False eqExprWith :: (BlockId -> BlockId -> Bool) @@ -225,12 +225,10 @@ CmmLoad e1 t1 a1 `eq` CmmLoad e2 t2 a2 = t1 `cmmEqType` t2 && e1 `eq` e2 && a1==a2 CmmReg r1 `eq` CmmReg r2 = r1==r2 CmmRegOff r1 i1 `eq` CmmRegOff r2 i2 = r1==r2 && i1==i2 - CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && es1 `eqs` es2 + CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && liftEq eq es1 es2 CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2 _e1 `eq` _e2 = False - xs `eqs` ys = eqListWith eq xs ys - eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2 eqLit l1 l2 = l1 == l2 @@ -252,7 +250,7 @@ (_,m',l') = blockSplit block' nodes' = filter (not . dont_care) (blockToList m') - equal = eqListWith (eqMiddleWith eqBid) nodes nodes' && + equal = liftEq (eqMiddleWith eqBid) nodes nodes' && eqLastWith eqBid l l' @@ -261,21 +259,11 @@ eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) = c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2 eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) = - t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2 + t1 == t2 && liftEq eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2 eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) = e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2 eqLastWith _ _ _ = False -eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool -eqMaybeWith eltEq (Just e) (Just e') = eltEq e e' -eqMaybeWith _ Nothing Nothing = True -eqMaybeWith _ _ _ = False - -eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool -eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs -eqListWith _ [] [] = True -eqListWith _ _ _ = False - -- | Given a block map, ensure that all "target" blocks are covered by -- the same ticks as the respective "source" blocks. This not only -- means copying ticks, but also adjusting tick scopes where @@ -301,15 +289,15 @@ -- Group by [Label] -- See Note [Compressed TrieMap] in GHC.Core.Map.Expr about the usage of GenMap. -groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])] +groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, NonEmpty DistinctBlocks)] groupByLabel = - go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks])) + go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, NonEmpty DistinctBlocks)) where go !m [] = TM.foldTM (:) m [] go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries where --k' = map (getKey . getUnique) k - adjust Nothing = Just (k,[v]) - adjust (Just (_,vs)) = Just (k,v:vs) + adjust Nothing = Just (k, pure v) + adjust (Just (_,vs)) = Just (k, v NE.<| vs) groupByInt :: (a -> Int) -> [a] -> [[a]] groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs diff --git a/GHC/Cmm/Config.hs b/GHC/Cmm/Config.hs --- a/GHC/Cmm/Config.hs +++ b/GHC/Cmm/Config.hs @@ -19,6 +19,7 @@ , cmmDoLinting :: !Bool -- ^ Do Cmm Linting Optimization or not , cmmOptElimCommonBlks :: !Bool -- ^ Eliminate common blocks or not , cmmOptSink :: !Bool -- ^ Perform sink after stack layout or not + , cmmOptThreadSanitizer :: !Bool -- ^ Instrument memory accesses for ThreadSanitizer , cmmGenStackUnwindInstr :: !Bool -- ^ Generate stack unwinding instructions (for debugging) , cmmExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries , cmmDoCmmSwitchPlans :: !Bool -- ^ Should the Cmm pass replace Stg switch statements diff --git a/GHC/Cmm/ContFlowOpt.hs b/GHC/Cmm/ContFlowOpt.hs --- a/GHC/Cmm/ContFlowOpt.hs +++ b/GHC/Cmm/ContFlowOpt.hs @@ -1,7 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Cmm.ContFlowOpt ( cmmCfgOpts , cmmCfgOptsProc @@ -21,8 +19,10 @@ import GHC.Cmm.Utils import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList) import GHC.Data.Maybe -import GHC.Utils.Panic +import GHC.Platform import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic import Control.Monad @@ -334,7 +334,7 @@ In this case we could assume that we will end up with a jump for BOTH branches. In this case it might be best to put the likely path in the true branch especially if there are large numbers of predecessors as this saves - us the jump thats not taken. However I haven't tested this and as of early + us the jump that's not taken. However I haven't tested this and as of early 2018 we almost never generate cmm where this would apply. -} @@ -422,9 +422,9 @@ add_preds block env = foldr add env (successors block) where add lbl env = mapInsertWith (+) lbl 1 env --- Removing unreachable blocks -removeUnreachableBlocksProc :: CmmDecl -> CmmDecl -removeUnreachableBlocksProc proc@(CmmProc info lbl live g) +-- Remove unreachable blocks from procs +removeUnreachableBlocksProc :: Platform -> CmmDecl -> CmmDecl +removeUnreachableBlocksProc _ proc@(CmmProc info lbl live g) | used_blocks `lengthLessThan` mapSize (toBlockMap g) = CmmProc info' lbl live g' | otherwise @@ -446,3 +446,5 @@ used_lbls :: LabelSet used_lbls = setFromList $ map entryLabel used_blocks +removeUnreachableBlocksProc platform data'@(CmmData _ _) = + pprPanic "removeUnreachableBlocksProc: passed data declaration instead of procedure" (pdoc platform data') diff --git a/GHC/Cmm/Dataflow.hs b/GHC/Cmm/Dataflow.hs --- a/GHC/Cmm/Dataflow.hs +++ b/GHC/Cmm/Dataflow.hs @@ -87,7 +87,7 @@ Block n C C -> FactBase f -> FactBase f --- | Function for rewrtiting and analysis combined. To be used with +-- | Function for rewriting and analysis combined. To be used with -- @rewriteCmm@. -- -- Currently set to work with @UniqSM@ monad, but we could probably abstract 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 @@ -12,6 +12,7 @@ , NonLocal(..) , addBlock , bodyList + , bodyToBlockList , emptyBody , labelsDefined , mapGraph @@ -55,6 +56,9 @@ bodyList :: Body' block n -> [(Label,block n C C)] bodyList body = mapToList body + +bodyToBlockList :: Body n -> [Block n C C] +bodyToBlockList body = mapElems body addBlock :: (NonLocal block, HasDebugCallStack) 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 @@ -140,7 +140,6 @@ lookupTM k m = mapLookup k m alterTM k f m = mapAlter f k m foldTM k m z = mapFoldr k z m - mapTM f m = mapMap f m filterTM f m = mapFilter f m ----------------------------------------------------------------------------- diff --git a/GHC/Cmm/DebugBlock.hs b/GHC/Cmm/DebugBlock.hs --- a/GHC/Cmm/DebugBlock.hs +++ b/GHC/Cmm/DebugBlock.hs @@ -29,7 +29,8 @@ -- * Unwinding information UnwindTable, UnwindPoint(..), - UnwindExpr(..), toUnwindExpr + UnwindExpr(..), toUnwindExpr, + pprUnwindTable ) where import GHC.Prelude @@ -38,12 +39,12 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm +import GHC.Cmm.Reg ( pprGlobalReg ) import GHC.Cmm.Utils import GHC.Data.FastString ( nilFS, mkFastString ) import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Cmm.Ppr.Expr ( pprExpr ) import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc ( seqList ) @@ -78,7 +79,7 @@ , dblBlocks :: ![DebugBlock] -- ^ Nested blocks } -instance OutputableP env CLabel => OutputableP env DebugBlock where +instance OutputableP Platform DebugBlock where pdoc env blk = (if | dblProcedure blk == dblLabel blk -> text "proc" @@ -86,7 +87,7 @@ -> text "pp-blk" | otherwise -> text "blk") <+> - ppr (dblLabel blk) <+> parens (pdoc env (dblCLabel blk)) <+> + ppr (dblLabel blk) <+> parens (pprAsmLabel env (dblCLabel blk)) <+> (maybe empty ppr (dblSourceTick blk)) <+> (maybe (text "removed") ((text "pos " <>) . ppr) (dblPosition blk)) <+> @@ -122,7 +123,7 @@ | otherwise = panic "findP impossible" #endif - scopeMap = foldr (uncurry insertMulti) Map.empty childScopes + scopeMap = foldl' (\acc (key, scope) -> insertMulti key scope 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 @@ -496,9 +497,9 @@ -- | A label associated with an 'UnwindTable' data UnwindPoint = UnwindPoint !CLabel !UnwindTable -instance OutputableP env CLabel => OutputableP env UnwindPoint where +instance OutputableP Platform UnwindPoint where pdoc env (UnwindPoint lbl uws) = - braces $ pdoc env lbl <> colon + braces $ pprAsmLabel env lbl <> colon <+> hsep (punctuate comma $ map pprUw $ Map.toList uws) where pprUw (g, expr) = ppr g <> char '=' <> pdoc env expr @@ -520,16 +521,24 @@ | UwTimes UnwindExpr UnwindExpr deriving (Eq) -instance OutputableP env CLabel => OutputableP env UnwindExpr where +instance OutputableP Platform UnwindExpr where pdoc = pprUnwindExpr 0 -pprUnwindExpr :: OutputableP env CLabel => Rational -> env -> UnwindExpr -> SDoc +pprUnwindTable :: IsLine doc => Platform -> UnwindTable -> doc +pprUnwindTable platform u = brackets (fsep (punctuate comma (map print_entry (Map.toList u)))) + where print_entry (reg, Nothing) = + parens (sep [pprGlobalReg reg, text "Nothing"]) + print_entry (reg, Just x) = + parens (sep [pprGlobalReg reg, text "Just" <+> pprUnwindExpr 0 platform x]) + -- Follow instance Outputable (Map.Map GlobalReg (Maybe UnwindExpr)) + +pprUnwindExpr :: IsLine doc => Rational -> Platform -> UnwindExpr -> doc pprUnwindExpr p env = \case - UwConst i -> ppr i - UwReg g 0 -> ppr g + UwConst i -> int i + UwReg g 0 -> pprGlobalReg g UwReg g x -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x)) UwDeref e -> char '*' <> pprUnwindExpr 3 env e - UwLabel l -> pdoc env l + UwLabel l -> pprAsmLabel env l UwPlus e0 e1 | p <= 0 -> pprUnwindExpr 0 env e0 <> char '+' <> pprUnwindExpr 0 env e1 UwMinus e0 e1 @@ -537,6 +546,8 @@ UwTimes e0 e1 | p <= 1 -> pprUnwindExpr 2 env e0 <> char '*' <> pprUnwindExpr 2 env e1 other -> parens (pprUnwindExpr 0 env other) +{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc #-} +{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Conversion of Cmm expressions to unwind expressions. We check for -- unsupported operator usages and simplify the expression as far as @@ -559,6 +570,6 @@ (MO_Sub{}, u1, u2 ) -> UwMinus u1 u2 (MO_Mul{}, u1, u2 ) -> UwTimes u1 u2 _otherwise -> pprPanic "Unsupported operator in unwind expression!" - (pprExpr platform e) + (pdoc platform e) toUnwindExpr platform e = pprPanic "Unsupported unwind expression!" (pdoc platform e) diff --git a/GHC/Cmm/Dominators.hs b/GHC/Cmm/Dominators.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Dominators.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE GADTs #-} + +module GHC.Cmm.Dominators + ( + -- * Dominator analysis and representation of results + DominatorSet(..) + , GraphWithDominators(..) + , RPNum + , graphWithDominators + + -- * Utility functions on graphs or graphs-with-dominators + , graphMap + , gwdRPNumber + , gwdDominatorsOf + , gwdDominatorTree + + -- * Utility functions on dominator sets + , dominatorsMember + , intersectDominators + ) +where + +import GHC.Prelude + +import Data.Array.IArray +import Data.Foldable() +import qualified Data.Tree as Tree + +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS + +import qualified GHC.CmmToAsm.CFG.Dominators as LT + +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 + +import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>)) +import GHC.Utils.Misc +import GHC.Utils.Panic + + +-- | =Dominator sets +-- +-- Node X dominates node Y if and only if every path from the entry to +-- Y includes X. Node Y technically dominates itself, but it is +-- never included in the *representation* of its dominator set. +-- +-- A dominator set is represented as a linked list in which each node +-- points to its *immediate* dominator, which is its parent in the +-- dominator tree. In many circumstances the immediate dominator +-- will be the only dominator of interest. + +data DominatorSet = ImmediateDominator { ds_label :: Label -- ^ Label of the immediate dominator. + , ds_parent :: DominatorSet -- ^ Set of nodes dominating the immediate dominator. + } + | EntryNode + deriving (Eq) + +instance Outputable DominatorSet where + ppr EntryNode = text "entry" + ppr (ImmediateDominator l parent) = ppr l <+> text "->" <+> ppr parent + + + +-- | Reverse postorder number of a node in a CFG +newtype RPNum = RPNum Int + deriving (Eq, Ord) +-- in reverse postorder, nodes closer to the entry have smaller numbers + +instance Show RPNum where + show (RPNum i) = "RP" ++ show i + +instance Outputable RPNum where + ppr (RPNum i) = hcat [text "RP", int i] + -- using `(<>)` would conflict with Semigroup + + + +dominatorsMember :: Label -> DominatorSet -> Bool +-- ^ Use to tell if the given label is in the given +-- dominator set. Which is to say, does the bloc +-- with with given label _properly_ and _non-vacuously_ +-- dominate the node whose dominator set this is? +-- +-- Takes linear time in the height of the dominator tree, +-- but uses space efficiently. +dominatorsMember lbl (ImmediateDominator l p) = l == lbl || dominatorsMember lbl p +dominatorsMember _ EntryNode = False + + +-- | Intersect two dominator sets to produce a third dominator set. +-- This function takes time linear in the size of the sets. +-- As such it is inefficient and should be used only for things +-- like visualizations or linters. +intersectDominators :: DominatorSet -> DominatorSet -> DominatorSet +intersectDominators ds ds' = commonPrefix (revDoms ds []) (revDoms ds' []) EntryNode + where revDoms EntryNode prev = prev + revDoms (ImmediateDominator lbl doms) prev = revDoms doms (lbl:prev) + commonPrefix (a:as) (b:bs) doms + | a == b = commonPrefix as bs (ImmediateDominator a doms) + commonPrefix _ _ doms = doms + + +-- | The result of dominator analysis. Also includes a reverse +-- postorder numbering, which is needed for dominator analysis +-- and for other (downstream) analyses. +-- +-- Invariant: Dominators, graph, and RP numberings include only *reachable* blocks. +data GraphWithDominators node = + GraphWithDominators { gwd_graph :: GenCmmGraph node + , gwd_dominators :: LabelMap DominatorSet + , gwd_rpnumbering :: LabelMap RPNum + } + + +-- | Call this function with a `CmmGraph` to get back the results of a +-- dominator analysis of that graph (as well as a reverse postorder +-- numbering). The result also includes the subgraph of the original +-- graph that contains only the reachable blocks. +graphWithDominators :: forall node . + (NonLocal node, HasDebugCallStack) + => GenCmmGraph node + -> GraphWithDominators node + +-- The implementation uses the Lengauer-Tarjan algorithm from the x86 +-- back end. + +graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap + where rpblocks = revPostorderFrom (graphMap g) (g_entry g) + rplabels' = map entryLabel rpblocks + rplabels :: Array Int Label + rplabels = listArray bounds rplabels' + + rpmap :: LabelMap RPNum + rpmap = mapFromList $ zipWith kvpair rpblocks [0..] + where kvpair block i = (entryLabel block, RPNum i) + + labelIndex :: Label -> Int + labelIndex = flip findLabelIn imap + where imap :: LabelMap Int + imap = mapFromList $ zip rplabels' [0..] + blockIndex = labelIndex . entryLabel + + bounds = (0, length rpblocks - 1) + + ltGraph :: [Block node C C] -> LT.Graph + ltGraph [] = IM.empty + ltGraph (block:blocks) = + IM.insert + (blockIndex block) + (IS.fromList $ map labelIndex $ successors block) + (ltGraph blocks) + + idom_array :: Array Int LT.Node + idom_array = array bounds $ LT.idom (0, ltGraph rpblocks) + + domSet 0 = EntryNode + domSet i = ImmediateDominator (rplabels ! d) (doms ! d) + where d = idom_array ! i + doms = tabulate bounds domSet + + dmap = mapFromList $ zipWith (\lbl i -> (lbl, domSet i)) rplabels' [0..] + +reachable :: NonLocal node => [Block node C C] -> GenCmmGraph node -> GenCmmGraph node +reachable blocks g = g { g_graph = GMany NothingO blockmap NothingO } + where blockmap = mapFromList [(entryLabel b, b) | b <- blocks] + + +-- | =Utility functions + +-- | Call `graphMap` to get the mapping from `Label` to `Block` that +-- is embedded in every `CmmGraph`. +graphMap :: GenCmmGraph n -> LabelMap (Block n C C) +graphMap (CmmGraph { g_graph = GMany NothingO blockmap NothingO }) = blockmap + +-- | Use `gwdRPNumber` on the result of the dominator analysis to get +-- a mapping from the `Label` of each reachable block to the reverse +-- postorder number of that block. +gwdRPNumber :: HasDebugCallStack => GraphWithDominators node -> Label -> RPNum +gwdRPNumber g l = findLabelIn l (gwd_rpnumbering g) + +findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a +findLabelIn lbl = mapFindWithDefault failed lbl + where failed = + pprPanic "label not found in result of analysis" (ppr lbl) + +-- | Use `gwdDominatorsOf` on the result of the dominator analysis to get +-- a mapping from the `Label` of each reachable block to the dominator +-- set (and the immediate dominator) of that block. The +-- implementation is space-efficient: intersecting dominator +-- sets share the representation of their intersection. + +gwdDominatorsOf :: HasDebugCallStack => GraphWithDominators node -> Label -> DominatorSet +gwdDominatorsOf g lbl = findLabelIn lbl (gwd_dominators g) + +gwdDominatorTree :: GraphWithDominators node -> Tree.Tree Label +gwdDominatorTree gwd = subtreeAt (g_entry (gwd_graph gwd)) + where subtreeAt label = Tree.Node label $ map subtreeAt $ children label + children l = mapFindWithDefault [] l child_map + child_map :: LabelMap [Label] + child_map = mapFoldlWithKey addParent mapEmpty $ gwd_dominators gwd + where addParent cm _ EntryNode = cm + addParent cm lbl (ImmediateDominator p _) = + mapInsertWith (++) p [lbl] cm + + +-- | Turn a function into an array. Inspired by SML's `Array.tabulate` +tabulate :: (Ix i) => (i, i) -> (i -> e) -> Array i e +tabulate b f = listArray b $ map f $ range b diff --git a/GHC/Cmm/Expr.hs b/GHC/Cmm/Expr.hs --- a/GHC/Cmm/Expr.hs +++ b/GHC/Cmm/Expr.hs @@ -10,6 +10,7 @@ , CmmReg(..), cmmRegType, cmmRegWidth , CmmLit(..), cmmLitType , AlignmentSpec(..) + -- TODO: Remove: , LocalReg(..), localRegType , GlobalReg(..), isArgReg, globalRegType , spReg, hpReg, spLimReg, hpLimReg, nodeReg @@ -26,6 +27,11 @@ , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet , regSetToList + , isTrivialCmmExpr + , hasNoGlobalRegs + , isLit + , isComparisonExpr + , Area(..) , module GHC.Cmm.MachOp , module GHC.Cmm.Type @@ -39,12 +45,14 @@ import GHC.Cmm.CLabel import GHC.Cmm.MachOp import GHC.Cmm.Type +import GHC.Cmm.Reg import GHC.Utils.Panic (panic) import GHC.Utils.Outputable -import GHC.Types.Unique +import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set +import Numeric ( fromRat ) import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf) @@ -78,14 +86,12 @@ CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2 _e1 == _e2 = False +instance OutputableP Platform CmmExpr where + pdoc = pprExpr + data AlignmentSpec = NaturallyAligned | Unaligned deriving (Eq, Ord, Show) -data CmmReg - = CmmLocal {-# UNPACK #-} !LocalReg - | CmmGlobal GlobalReg - deriving( Eq, Ord, Show ) - -- | A stack area is either the stack slot where a variable is spilled -- or the stack space where function arguments and results are passed. data Area @@ -94,6 +100,14 @@ -- See Note [Continuation BlockIds] in GHC.Cmm.Node. deriving (Eq, Ord, Show) +instance Outputable Area where + ppr e = pprArea e + +pprArea :: Area -> SDoc +pprArea Old = text "old" +pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ] + + {- Note [Old Area] ~~~~~~~~~~~~~~~~~~ There is a single call area 'Old', allocated at the extreme old @@ -217,6 +231,9 @@ -- of bytes used deriving (Eq, Show) +instance OutputableP Platform CmmLit where + pdoc = pprLit + instance Outputable CmmLit where ppr (CmmInt n w) = text "CmmInt" <+> ppr n <+> ppr w ppr (CmmFloat n w) = text "CmmFloat" <+> text (show n) <+> ppr w @@ -276,39 +293,35 @@ return (CmmMachOp op' args) maybeInvertCmmExpr _ = Nothing ------------------------------------------------------------------------------ --- Local registers ------------------------------------------------------------------------------ +--------------------------------------------------- +-- CmmExpr predicates +--------------------------------------------------- -data LocalReg - = LocalReg {-# UNPACK #-} !Unique !CmmType - -- ^ Parameters: - -- 1. Identifier - -- 2. Type - deriving Show +isTrivialCmmExpr :: CmmExpr -> Bool +isTrivialCmmExpr (CmmLoad _ _ _) = False +isTrivialCmmExpr (CmmMachOp _ _) = False +isTrivialCmmExpr (CmmLit _) = True +isTrivialCmmExpr (CmmReg _) = True +isTrivialCmmExpr (CmmRegOff _ _) = True +isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" -instance Eq LocalReg where - (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2 +hasNoGlobalRegs :: CmmExpr -> Bool +hasNoGlobalRegs (CmmLoad e _ _) = hasNoGlobalRegs e +hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es +hasNoGlobalRegs (CmmLit _) = True +hasNoGlobalRegs (CmmReg (CmmLocal _)) = True +hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True +hasNoGlobalRegs _ = False --- This is non-deterministic but we do not currently support deterministic --- code-generation. See Note [Unique Determinism and code generation] --- See Note [No Ord for Unique] -instance Ord LocalReg where - compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2 +isLit :: CmmExpr -> Bool +isLit (CmmLit _) = True +isLit _ = False -instance Uniquable LocalReg where - getUnique (LocalReg uniq _) = uniq +isComparisonExpr :: CmmExpr -> Bool +isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op +isComparisonExpr _ = False -cmmRegType :: Platform -> CmmReg -> CmmType -cmmRegType _ (CmmLocal reg) = localRegType reg -cmmRegType platform (CmmGlobal reg) = globalRegType platform reg -cmmRegWidth :: Platform -> CmmReg -> Width -cmmRegWidth platform = typeWidth . cmmRegType platform - -localRegType :: LocalReg -> CmmType -localRegType (LocalReg _ rep) = rep - ----------------------------------------------------------------------------- -- Register-use information for expressions and other types ----------------------------------------------------------------------------- @@ -404,241 +417,159 @@ foldRegsDefd platform f set as = foldl' (foldRegsDefd platform f) set as {-# INLINABLE foldRegsDefd #-} ------------------------------------------------------------------------------ --- Global STG registers ------------------------------------------------------------------------------ - -data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) - ------------------------------------------------------------------------------ --- Global STG registers ------------------------------------------------------------------------------ -{- -Note [Overlapping global registers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The backend might not faithfully implement the abstraction of the STG -machine with independent registers for different values of type -GlobalReg. Specifically, certain pairs of registers (r1, r2) may -overlap in the sense that a store to r1 invalidates the value in r2, -and vice versa. - -Currently this occurs only on the x86_64 architecture where FloatReg n -and DoubleReg n are assigned the same microarchitectural register, in -order to allow functions to receive more Float# or Double# arguments -in registers (as opposed to on the stack). +-- -------------------------------------------------------------------------- +-- Pretty-printing expressions +-- -------------------------------------------------------------------------- -There are no specific rules about which registers might overlap with -which other registers, but presumably it's safe to assume that nothing -will overlap with special registers like Sp or BaseReg. +pprExpr :: Platform -> CmmExpr -> SDoc +pprExpr platform e + = case e of + CmmRegOff reg i -> + pprExpr platform (CmmMachOp (MO_Add rep) + [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) + where rep = typeWidth (cmmRegType platform reg) + CmmLit lit -> pprLit platform lit + _other -> pprExpr1 platform e -Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap -on a particular platform. The instance Eq GlobalReg is syntactic -equality of STG registers and does not take overlap into -account. However it is still used in UserOfRegs/DefinerOfRegs and -there are likely still bugs there, beware! --} +-- Here's the precedence table from GHC.Cmm.Parser: +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +-- %left '|' +-- %left '^' +-- %left '&' +-- %left '>>' '<<' +-- %left '-' '+' +-- %left '/' '*' '%' +-- %right '~' -data GlobalReg - -- Argument and return registers - = VanillaReg -- pointers, unboxed ints and chars - {-# UNPACK #-} !Int -- its number - VGcPtr +-- We just cope with the common operators for now, the rest will get +-- a default conservative behaviour. - | FloatReg -- single-precision floating-point registers - {-# UNPACK #-} !Int -- its number +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc +pprExpr1 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp1 op + = pprExpr7 platform x <+> doc <+> pprExpr7 platform y +pprExpr1 platform e = pprExpr7 platform e - | DoubleReg -- double-precision floating-point registers - {-# UNPACK #-} !Int -- its number +infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc - | LongReg -- long int registers (64-bit, really) - {-# UNPACK #-} !Int -- its number +infixMachOp1 (MO_Eq _) = Just (text "==") +infixMachOp1 (MO_Ne _) = Just (text "!=") +infixMachOp1 (MO_Shl _) = Just (text "<<") +infixMachOp1 (MO_U_Shr _) = Just (text ">>") +infixMachOp1 (MO_U_Ge _) = Just (text ">=") +infixMachOp1 (MO_U_Le _) = Just (text "<=") +infixMachOp1 (MO_U_Gt _) = Just (char '>') +infixMachOp1 (MO_U_Lt _) = Just (char '<') +infixMachOp1 _ = Nothing - | XmmReg -- 128-bit SIMD vector register - {-# UNPACK #-} !Int -- its number +-- %left '-' '+' +pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 + = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) +pprExpr7 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp7 op + = pprExpr7 platform x <+> doc <+> pprExpr8 platform y +pprExpr7 platform e = pprExpr8 platform e - | YmmReg -- 256-bit SIMD vector register - {-# UNPACK #-} !Int -- its number +infixMachOp7 (MO_Add _) = Just (char '+') +infixMachOp7 (MO_Sub _) = Just (char '-') +infixMachOp7 _ = Nothing - | ZmmReg -- 512-bit SIMD vector register - {-# UNPACK #-} !Int -- its number +-- %left '/' '*' '%' +pprExpr8 platform (CmmMachOp op [x,y]) + | Just doc <- infixMachOp8 op + = pprExpr8 platform x <+> doc <+> pprExpr9 platform y +pprExpr8 platform e = pprExpr9 platform e - -- 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 +infixMachOp8 (MO_U_Quot _) = Just (char '/') +infixMachOp8 (MO_Mul _) = Just (char '*') +infixMachOp8 (MO_U_Rem _) = Just (char '%') +infixMachOp8 _ = Nothing - -- 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 +pprExpr9 :: Platform -> CmmExpr -> SDoc +pprExpr9 platform e = + case e of + CmmLit lit -> pprLit1 platform lit + CmmLoad expr rep align + -> let align_mark = + case align of + NaturallyAligned -> empty + Unaligned -> text "^" + in ppr rep <> align_mark <> brackets (pdoc platform expr) + CmmReg reg -> ppr reg + CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) + CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) + CmmMachOp mop args -> genMachOp platform mop args - -- 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 +genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc +genMachOp platform mop args + | Just doc <- infixMachOp mop = case args of + -- dyadic + [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y - -- 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 + -- unary + [x] -> doc <> pprExpr9 platform x - -- The is a dummy register used to indicate to the stack unwinder where - -- a routine would return to. - | UnwindReturnReg + _ -> pprTrace "GHC.Cmm.Expr.genMachOp: machop with strange number of args" + (pprMachOp mop <+> + parens (hcat $ punctuate comma (map (pprExpr platform) args))) + empty - -- Base Register for PIC (position-independent code) calculations - -- Only used inside the native code generator. It's exact meaning differs - -- from platform to platform (see module PositionIndependentCode). - | PicBaseReg + | isJust (infixMachOp1 mop) + || isJust (infixMachOp7 mop) + || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args)) - deriving( Show ) + | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args)) + where ppr_op = text (map (\c -> if c == ' ' then '_' else c) + (show mop)) + -- replace spaces in (show mop) with underscores, -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 +-- +-- Unsigned ops on the word size of the machine get nice symbols. +-- All else get dumped in their ugly format. +-- +infixMachOp :: MachOp -> Maybe SDoc +infixMachOp mop + = case mop of + MO_And _ -> Just $ char '&' + MO_Or _ -> Just $ char '|' + MO_Xor _ -> Just $ char '^' + MO_Not _ -> Just $ char '~' + MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) + _ -> Nothing --- NOTE: this Ord instance affects the tuple layout in GHCi, see --- Note [GHCi tuple layout] -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 +-- -------------------------------------------------------------------------- +-- Pretty-printing literals +-- +-- To minimise line noise we adopt the convention that if the literal +-- has the natural machine word size, we do not append the type +-- -------------------------------------------------------------------------- --- 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 +pprLit :: Platform -> CmmLit -> SDoc +pprLit platform lit = case lit of + CmmInt i rep -> + hcat [ (if i < 0 then parens else id)(integer i) + , ppUnless (rep == wordWidth platform) $ + space <> dcolon <+> ppr rep ] -node :: GlobalReg -node = VanillaReg 1 VGcPtr + CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] + CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>' + CmmLabel clbl -> pdoc platform clbl + CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i + CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-' + <> pdoc platform clbl2 <> ppr_offset i + CmmBlock id -> ppr id + CmmHighStackMark -> text "" -globalRegType :: Platform -> GlobalReg -> CmmType -globalRegType platform = \case - (VanillaReg _ VGcPtr) -> gcWord platform - (VanillaReg _ VNonGcPtr) -> bWord 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. - -- 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) +pprLit1 :: Platform -> CmmLit -> SDoc +pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit) +pprLit1 platform lit = pprLit platform lit - Hp -> gcWord platform -- The initialiser for all - -- dynamically allocated closures - _ -> bWord platform +ppr_offset :: Int -> SDoc +ppr_offset i + | i==0 = empty + | i>=0 = char '+' <> int i + | otherwise = char '-' <> int (-i) -isArgReg :: GlobalReg -> Bool -isArgReg (VanillaReg {}) = True -isArgReg (FloatReg {}) = True -isArgReg (DoubleReg {}) = True -isArgReg (LongReg {}) = True -isArgReg (XmmReg {}) = True -isArgReg (YmmReg {}) = True -isArgReg (ZmmReg {}) = True -isArgReg _ = False +commafy :: [SDoc] -> SDoc +commafy xs = fsep $ punctuate comma xs 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,6 +1,6 @@ {-# LANGUAGE GADTs, BangPatterns, RecordWildCards, GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections, - ScopedTypeVariables, OverloadedStrings, LambdaCase #-} + ScopedTypeVariables, OverloadedStrings, LambdaCase, EmptyCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} @@ -113,55 +113,70 @@ - Static thunks (THUNK), ie. CAFs - Continuations (RET_SMALL, etc.) -In each case, the info table points to the SRT. There are three ways which we -may encode the location of the SRT in the info table, described below. +In each case, the info table points to the SRT, if there is one. -USE_SRT_OFFSET --------------- -In this case we use the info->srt to encode whether or not there is an -SRT and if so encode the offset to its location in info->f.srt_offset: +- info->srt is 0 if there's no SRT +- otherwise, there are three ways which we may encode the location of the SRT in + the info table, described below. -- info->srt is 0 if there's no SRT, otherwise, -- info->srt == 1 and info->f.srt_offset points to the SRT +USE_SRT_POINTER +--------------- +Most general implementation. Can always be used, but other ways are more efficient. -e.g. for a FUN with an SRT: +- info->srt is a pointer -StgFunInfoTable +------+ - info->f.srt_offset | ------------> offset to SRT object -StgStdInfoTable +------+ +We encode an **absolute pointer** to the SRT in info->srt. e.g. for a FUN +with an SRT: + +StgInfoTable +------+ info->layout.ptrs | ... | info->layout.nptrs | ... | - info->srt | 1 | + info->srt | ------------> pointer to SRT object info->type | ... | |------| -USE_SRT_POINTER ---------------- -When tables-next-to-code isn't in use we rather encode an absolute pointer to -the SRT in info->srt. e.g. for a FUN with an SRT: +USE_SRT_OFFSET +-------------- +Requires: + - tables-next-to-code enabled +In this case we use the info->srt to encode whether or not there is an SRT and +if so encode the offset to its location in info->f.srt_offset: + +- info->srt is a half-word +- info->f.srt_offset is a 32-bit int +- info->srt is 0 if there's no SRT, otherwise, +- info->srt == 1 and info->f.srt_offset is a offset to the SRT, relative to the +field address itself + +e.g. for a FUN with an SRT: + StgFunInfoTable +------+ - info->f.srt_offset | ------------> pointer to SRT object -StgStdInfoTable +------+ + info->f.srt_offset | ------------> offset to SRT object +StgInfoTable +------+ info->layout.ptrs | ... | info->layout.nptrs | ... | info->srt | 1 | info->type | ... | |------| + USE_INLINE_SRT_FIELD -------------------- -When using TNTC on x86_64 (and other platforms using the small memory model), -we optimise the info table representation further. The offset to the SRT can +Requires: + - tables-next-to-code enabled + - 64-bit architecture + - small memory model + +We optimise the info table representation further. The offset to the SRT can be stored in 32 bits (all code lives within a 2GB region in x86_64's small memory model), so we can save a word in the info table by storing the srt_offset in the srt field, which is half a word. -On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169): - -- info->srt is zero if there's no SRT, otherwise: +- info->srt is a half-word +- info->srt is 0 if there's no SRT, otherwise: - info->srt is an offset from the info pointer to the SRT object -StgStdInfoTable +------+ +StgInfoTable +------+ info->layout.ptrs | | info->layout.nptrs | | info->srt | ------------> offset to SRT object @@ -561,7 +576,7 @@ -> CAFSet cafAnalData platform st = case st of CmmStaticsRaw _lbl _data -> Set.empty - CmmStatics _lbl _itbl _ccs payload -> + CmmStatics _lbl _itbl _ccs payload _extras -> foldl' analyzeStatic Set.empty payload where analyzeStatic s lit = @@ -726,7 +741,9 @@ getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFfyLabel)] getLabelledBlocks platform decl = case decl of CmmData _ (CmmStaticsRaw _ _) -> [] - CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl) ] + CmmData _ (CmmStatics lbl info _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl) + | not (isThunkRep (cit_rep info)) + ] CmmProc top_info _ _ _ -> [ (BlockLabel blockId, caf_lbl) | (blockId, info) <- mapToList (info_tbls top_info) , let rep = cit_rep info @@ -771,29 +788,49 @@ graph :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)] graph = stronglyConnCompFromEdgedVerticesOrd nodes --- | Get @(Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block. --- The @Set CafLabel@ represents the set of CAFfy things which this CAF's code +-- | Get @(Maybe Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block. +-- The @Set CAFfyLabel@ represents the set of CAFfy things which this CAF's code -- depends upon. -- --- CAFs are treated differently from other labelled blocks: +-- - The 'Label' represents the entry code of the closure. This may be +-- 'Nothing' if it is a standard closure type (e.g. @stg_unpack_cstring@; see +-- Note [unpack_cstring closures] in StgStdThunks.cmm). +-- - The 'CAFLabel' is the label of the CAF closure. +-- - The @Set CAFLabel@ is the set of CAFfy closures which should be included +-- in the closure's SRT. -- +-- Note that CAFs are treated differently from other labelled blocks: +-- -- - we never shortcut a reference to a CAF to the contents of its -- SRT, since the point of SRTs is to keep CAFs alive. -- -- - CAFs therefore don't take part in the dependency analysis in depAnalSRTs. -- instead we generate their SRTs after everything else. --- -getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFfyLabel, Set CAFfyLabel)] -getCAFs platform cafEnv decls = - [ (g_entry g, mkCAFfyLabel platform topLbl, cafs) - | CmmProc top_info topLbl _ g <- decls - , Just info <- [mapLookup (g_entry g) (info_tbls top_info)] - , let rep = cit_rep info - , isStaticRep rep && isThunkRep rep - , Just cafs <- [mapLookup (g_entry g) cafEnv] - ] +getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Maybe Label, CAFfyLabel, Set CAFfyLabel)] +getCAFs platform cafEnv = mapMaybe getCAFLabel + where + getCAFLabel :: CmmDecl -> Maybe (Maybe Label, CAFfyLabel, Set CAFfyLabel) + getCAFLabel (CmmProc top_info top_lbl _ g) + | Just info <- mapLookup (g_entry g) (info_tbls top_info) + , let rep = cit_rep info + , isStaticRep rep && isThunkRep rep + , Just cafs <- mapLookup (g_entry g) cafEnv + = Just (Just (g_entry g), mkCAFfyLabel platform top_lbl, cafs) + | otherwise + = Nothing + + getCAFLabel (CmmData _ (CmmStatics top_lbl info _ccs _payload _extras)) + | isThunkRep (cit_rep info) + = Just (Nothing, mkCAFfyLabel platform top_lbl, Set.empty) + + | otherwise + = Nothing + + getCAFLabel (CmmData _ (CmmStaticsRaw _lbl _payload)) + = Nothing + -- | Get the list of blocks that correspond to the entry points for -- @FUN_STATIC@ closures. These are the blocks for which if we have an -- SRT we can merge it with the static closure. [FUN] @@ -847,7 +884,7 @@ :: CmmConfig -> ModuleSRTInfo -> [(CAFEnv, [CmmDecl])] -- ^ 'CAFEnv's and 'CmmDecl's for code blocks - -> [(CAFSet, CmmDecl)] -- ^ static data decls and their 'CAFSet's + -> [(CAFSet, CmmDataDecl)] -- ^ static data decls and their 'CAFSet's -> IO (ModuleSRTInfo, [CmmDeclSRTs]) doSRTs cfg moduleSRTInfo procs data_ = do @@ -863,16 +900,15 @@ flip map data_ $ \(set, decl) -> case decl of - CmmProc{} -> - pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl) + CmmProc void _ _ _ -> case void of CmmData _ static -> case static of - CmmStatics lbl _ _ _ -> (lbl, set) + CmmStatics lbl _ _ _ _ -> (lbl, set) CmmStaticsRaw lbl _ -> (lbl, set) (proc_envs, procss) = unzip procs cafEnv = mapUnions proc_envs - decls = map snd data_ ++ concat procss + decls = map (cmmDataDeclCmmDecl . snd) data_ ++ concat procss staticFuns = mapFromList (getStaticFuns decls) platform = cmmPlatform cfg @@ -887,7 +923,7 @@ sccs :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)] sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls - cafsWithSRTs :: [(Label, CAFfyLabel, Set CAFfyLabel)] + cafsWithSRTs :: [(Maybe Label, CAFfyLabel, Set CAFfyLabel)] cafsWithSRTs = getCAFs platform cafEnv decls srtTraceM "doSRTs" (text "data:" <+> pdoc platform data_ $$ @@ -910,7 +946,7 @@ flip runStateT moduleSRTInfo $ do nonCAFs <- mapM (doSCC cfg staticFuns static_data_env) sccs cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) -> - oneSRT cfg staticFuns [BlockLabel l] [cafLbl] + oneSRT cfg staticFuns (map BlockLabel (maybeToList l)) [cafLbl] True{-is a CAF-} cafs static_data_env return (nonCAFs ++ cAFs) @@ -943,8 +979,7 @@ | otherwise -> -- Not an IdLabel, ignore srtMap - CmmProc{} -> - pprPanic "doSRTs" (text "Found Proc in static data list:" <+> pdoc platform decl)) + CmmProc void _ _ _ -> case void of) (moduleSRTMap moduleSRTInfo') data_ return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls') @@ -1137,7 +1172,8 @@ not (labelDynamic this_mod platform (cmmExternalDynamicRefs cfg) lbl) -- MachO relocations can't express offsets between compilation units at - -- all, so we are always forced to build a singleton SRT in this case. + -- all, so we are always forced to build a singleton SRT in this case + -- (cf #15169) && (not (osMachOTarget $ platformOS $ profilePlatform profile) || isLocalCLabel this_mod lbl) -> do @@ -1205,15 +1241,15 @@ ( [CmmDeclSRTs] -- The SRT object(s) , SRTEntry -- label to use in the info table ) -buildSRTChain _ [] = panic "buildSRT: empty" buildSRTChain profile cafSet = case splitAt mAX_SRT_SIZE cafSet of + ([], _) -> panic "buildSRT: empty" (these, []) -> do (decl,lbl) <- buildSRT profile these return ([decl], lbl) - (these,those) -> do - (rest, rest_lbl) <- buildSRTChain profile (head these : those) - (decl,lbl) <- buildSRT profile (rest_lbl : tail these) + (this:these,those) -> do + (rest, rest_lbl) <- buildSRTChain profile (this : those) + (decl,lbl) <- buildSRT profile (rest_lbl : these) return (decl:rest, lbl) where mAX_SRT_SIZE = 16 @@ -1232,6 +1268,7 @@ [] -- no padding [mkIntCLit platform 0] -- link field [] -- no saved info + [] -- no extras return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl) -- | Update info tables with references to their SRTs. Also generate @@ -1247,10 +1284,10 @@ updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics)) = [CmmData s (CmmStaticsRaw lbl statics)] -updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload)) +updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload extras)) = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))] where - field_lits = mkStaticClosureFields profile itbl ccs caffy payload + field_lits = mkStaticClosureFields profile itbl ccs caffy payload extras updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g) | Just (_,closure) <- maybeStaticClosure = [ proc, closure ] @@ -1280,7 +1317,7 @@ Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res) (info_tbl { cit_rep = new_rep }, res) where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ] - fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries + fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries [] new_rep = case cit_rep of HeapRep sta ptrs nptrs ty -> HeapRep sta (ptrs + length srtEntries) nptrs ty diff --git a/GHC/Cmm/Lexer.hs b/GHC/Cmm/Lexer.hs --- a/GHC/Cmm/Lexer.hs +++ b/GHC/Cmm/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 13 "_build/source-dist/ghc-9.4.8-src/ghc-9.4.8/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 13 "_build/source-dist/ghc-9.6.1-src/ghc-9.6.1/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer ( CmmToken(..), cmmlex, ) where @@ -385,7 +385,7 @@ , (0,alex_action_20) ] -{-# LINE 133 "_build/source-dist/ghc-9.4.8-src/ghc-9.4.8/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 133 "_build/source-dist/ghc-9.6.1-src/ghc-9.6.1/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken = CmmT_SpecChar Char | CmmT_DotDot diff --git a/GHC/Cmm/Lint.hs b/GHC/Cmm/Lint.hs --- a/GHC/Cmm/Lint.hs +++ b/GHC/Cmm/Lint.hs @@ -6,6 +6,7 @@ -- ----------------------------------------------------------------------------- {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} module GHC.Cmm.Lint ( @@ -21,13 +22,15 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm -import GHC.Cmm.Utils import GHC.Cmm.Liveness import GHC.Cmm.Switch (switchTargetsToList) -import GHC.Cmm.Ppr () -- For Outputable instances +import GHC.Cmm.CLabel (pprDebugCLabel) import GHC.Utils.Outputable -import Control.Monad (ap, unless) +import Control.Monad (unless) +import Control.Monad.Trans.Except (ExceptT (..), Except) +import Control.Monad.Trans.Reader (ReaderT (..)) +import Data.Functor.Identity (Identity (..)) -- Things to check: -- - invariant on CmmBlock in GHC.Cmm.Expr (see comment there) @@ -47,7 +50,8 @@ runCmmLint :: OutputableP Platform a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc runCmmLint platform l p = case unCL (l p) platform of - Left err -> Just (vcat [text "Cmm lint error:", + Left err -> Just (withPprStyle defaultDumpStyle $ vcat + [text "Cmm lint error:", nest 2 err, text "Program was:", nest 2 (pdoc platform p)]) @@ -57,7 +61,7 @@ lintCmmDecl (CmmProc _ lbl _ g) = do platform <- getPlatform - addLintInfo (text "in proc " <> pdoc platform lbl) $ lintCmmGraph g + addLintInfo (text "in proc " <> pprDebugCLabel platform lbl) $ lintCmmGraph g lintCmmDecl (CmmData {}) = return () @@ -274,17 +278,8 @@ -- just a basic error monad: newtype CmmLint a = CmmLint { unCL :: Platform -> Either SDoc a } - deriving (Functor) - -instance Applicative CmmLint where - pure a = CmmLint (\_ -> Right a) - (<*>) = ap - -instance Monad CmmLint where - CmmLint m >>= k = CmmLint $ \platform -> - case m platform of - Left e -> Left e - Right a -> unCL (k a) platform + deriving stock (Functor) + deriving (Applicative, Monad) via ReaderT Platform (Except SDoc) getPlatform :: CmmLint Platform getPlatform = CmmLint $ \platform -> Right platform diff --git a/GHC/Cmm/Liveness.hs b/GHC/Cmm/Liveness.hs --- a/GHC/Cmm/Liveness.hs +++ b/GHC/Cmm/Liveness.hs @@ -20,7 +20,6 @@ import GHC.Platform import GHC.Cmm.BlockId import GHC.Cmm -import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow @@ -104,7 +103,7 @@ ----------------------------------------------------------------------------- -- | Specialization that only retains the keys for local variables. -- --- Local variablas are mostly glorified Ints, and some parts of the compiler +-- Local variables are mostly glorified Ints, and some parts of the compiler -- really don't care about anything but the Int part. So we can avoid some -- overhead by computing a IntSet instead of a Set LocalReg which (unsurprisingly) -- is quite a bit faster. diff --git a/GHC/Cmm/MachOp.hs b/GHC/Cmm/MachOp.hs --- a/GHC/Cmm/MachOp.hs +++ b/GHC/Cmm/MachOp.hs @@ -66,7 +66,6 @@ | MO_S_Neg Width -- unary - -- Unsigned multiply/divide - | MO_U_MulMayOflo Width -- nonzero if unsigned multiply overflows | MO_U_Quot Width -- unsigned / (same semantics as WordQuotOp) | MO_U_Rem Width -- unsigned % (same semantics as WordRemOp) @@ -252,7 +251,6 @@ MO_Ne _ -> True MO_Mul _ -> True MO_S_MulMayOflo _ -> True - MO_U_MulMayOflo _ -> True MO_And _ -> True MO_Or _ -> True MO_Xor _ -> True @@ -380,7 +378,6 @@ MO_S_Quot r -> cmmBits r MO_S_Rem r -> cmmBits r MO_S_Neg r -> cmmBits r - MO_U_MulMayOflo r -> cmmBits r MO_U_Quot r -> cmmBits r MO_U_Rem r -> cmmBits r @@ -474,7 +471,6 @@ MO_S_Quot r -> [r,r] MO_S_Rem r -> [r,r] MO_S_Neg r -> [r] - MO_U_MulMayOflo r -> [r,r] MO_U_Quot r -> [r,r] MO_U_Rem r -> [r,r] diff --git a/GHC/Cmm/Node.hs b/GHC/Cmm/Node.hs --- a/GHC/Cmm/Node.hs +++ b/GHC/Cmm/Node.hs @@ -7,9 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE LambdaCase #-} -- CmmNode type for representation using Hoopl graphs. @@ -28,23 +26,29 @@ import GHC.Prelude hiding (succ) import GHC.Platform.Regs +import GHC.Cmm.CLabel import GHC.Cmm.Expr import GHC.Cmm.Switch import GHC.Data.FastString +import GHC.Data.Pair import GHC.Types.ForeignCall import GHC.Utils.Outputable import GHC.Runtime.Heap.Layout import GHC.Types.Tickish (CmmTickish) import qualified GHC.Types.Unique as U +import GHC.Types.Basic (FunctionOrData(..)) +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) import Data.Maybe import Data.List (tails,sortBy) import GHC.Types.Unique (nonDetCmpUnique) -import GHC.Utils.Misc +import GHC.Utils.Constants (debugIsOn) ------------------------ @@ -165,6 +169,177 @@ intrbl:: Bool -- whether or not the call is interruptible } -> CmmNode O C +instance OutputableP Platform (CmmNode e x) where + pdoc = pprNode + +pprNode :: Platform -> CmmNode e x -> SDoc +pprNode platform node = pp_node <+> pp_debug + where + pp_node :: SDoc + pp_node = case node of + -- label: + CmmEntry id tscope -> + (sdocOption sdocSuppressUniques $ \case + True -> text "_lbl_" + False -> ppr id + ) + <> colon + <+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope) + + -- // text + CmmComment s -> text "//" <+> ftext s + + -- //tick bla<...> + CmmTick t -> ppUnlessOption sdocSuppressTicks + (text "//tick" <+> ppr t) + + -- unwind reg = expr; + CmmUnwind regs -> + text "unwind " + <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi + + -- reg = expr; + CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi + + -- rep[lv] = expr; + CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi + where + align_mark = case align of + Unaligned -> text "^" + NaturallyAligned -> empty + rep = ppr ( cmmExprType platform expr ) + + -- call "ccall" foo(x, y)[r1, r2]; + -- ToDo ppr volatile + CmmUnsafeForeignCall target results args -> + hsep [ ppUnless (null results) $ + parens (commafy $ map ppr results) <+> equals, + text "call", + pdoc platform target <> parens (commafy $ map (pdoc platform) args) <> semi] + + -- goto label; + CmmBranch ident -> text "goto" <+> ppr ident <> semi + + -- if (expr) goto t; else goto f; + CmmCondBranch expr t f l -> + hsep [ text "if" + , parens (pdoc platform expr) + , case l of + Nothing -> empty + Just b -> parens (text "likely:" <+> ppr b) + , text "goto" + , ppr t <> semi + , text "else goto" + , ppr f <> semi + ] + + CmmSwitch expr ids -> + hang (hsep [ text "switch" + , range + , if isTrivialCmmExpr expr + then pdoc platform expr + else parens (pdoc platform expr) + , text "{" + ]) + 4 (vcat (map ppCase cases) $$ def) $$ rbrace + where + (cases, mbdef) = switchTargetsFallThrough ids + ppCase (is,l) = hsep + [ text "case" + , commafy $ toList $ fmap integer is + , text ": goto" + , ppr l <> semi + ] + def | Just l <- mbdef = hsep + [ text "default:" + , braces (text "goto" <+> ppr l <> semi) + ] + | otherwise = empty + + range = brackets $ hsep [integer lo, text "..", integer hi] + where (lo,hi) = switchTargetsRange ids + + CmmCall tgt k regs out res updfr_off -> + hcat [ text "call", space + , pprFun tgt, parens (interpp'SP regs), space + , returns <+> + text "args: " <> ppr out <> comma <+> + text "res: " <> ppr res <> comma <+> + text "upd: " <> ppr updfr_off + , semi ] + where pprFun f@(CmmLit _) = pdoc platform f + pprFun f = parens (pdoc platform f) + + returns + | Just r <- k = text "returns to" <+> ppr r <> comma + | otherwise = empty + + CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> + hcat $ if i then [text "interruptible", space] else [] ++ + [ text "foreign call", space + , pdoc platform t, text "(...)", space + , text "returns to" <+> ppr s + <+> text "args:" <+> parens (pdoc platform as) + <+> text "ress:" <+> parens (ppr rs) + , text "ret_args:" <+> ppr a + , text "ret_off:" <+> ppr u + , semi ] + + pp_debug :: SDoc + pp_debug = + if not debugIsOn then empty + else case node of + CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry" + CmmComment {} -> empty -- Looks also terrible with text " // CmmComment" + CmmTick {} -> empty + CmmUnwind {} -> text " // CmmUnwind" + CmmAssign {} -> text " // CmmAssign" + CmmStore {} -> text " // CmmStore" + CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall" + CmmBranch {} -> text " // CmmBranch" + CmmCondBranch {} -> text " // CmmCondBranch" + CmmSwitch {} -> text " // CmmSwitch" + CmmCall {} -> text " // CmmCall" + CmmForeignCall {} -> text " // CmmForeignCall" + + commafy :: [SDoc] -> SDoc + commafy xs = hsep $ punctuate comma xs + +instance OutputableP Platform (Block CmmNode C C) where + pdoc = pprBlock +instance OutputableP Platform (Block CmmNode C O) where + pdoc = pprBlock +instance OutputableP Platform (Block CmmNode O C) where + pdoc = pprBlock +instance OutputableP Platform (Block CmmNode O O) where + pdoc = pprBlock + +instance OutputableP Platform (Graph CmmNode e x) where + pdoc = pprGraph + +pprBlock :: IndexedCO x SDoc SDoc ~ SDoc + => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc +pprBlock platform block + = foldBlockNodesB3 ( ($$) . pdoc platform + , ($$) . (nest 4) . pdoc platform + , ($$) . (nest 4) . pdoc platform + ) + block + empty + +pprGraph :: Platform -> Graph CmmNode e x -> SDoc +pprGraph platform = \case + GNil -> empty + GUnit block -> pdoc platform block + GMany entry body exit -> + text "{" + $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit) + $$ text "}" + where pprMaybeO :: OutputableP Platform (Block CmmNode e x) + => MaybeO ex (Block CmmNode e x) -> SDoc + pprMaybeO NothingO = empty + pprMaybeO (JustO block) = pdoc platform block + {- Note [Foreign calls] ~~~~~~~~~~~~~~~~~~~~~~~ A CmmUnsafeForeignCall is used for *unsafe* foreign calls; @@ -291,11 +466,25 @@ CmmReturnInfo deriving Eq +instance Outputable ForeignConvention where + ppr = pprForeignConvention + +pprForeignConvention :: ForeignConvention -> SDoc +pprForeignConvention (ForeignConvention c args res ret) = + doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret + data CmmReturnInfo = CmmMayReturn | CmmNeverReturns deriving ( Eq ) +instance Outputable CmmReturnInfo where + ppr = pprReturnInfo + +pprReturnInfo :: CmmReturnInfo -> SDoc +pprReturnInfo CmmMayReturn = empty +pprReturnInfo CmmNeverReturns = text "never returns" + data ForeignTarget -- The target of a foreign call = ForeignTarget -- A foreign procedure CmmExpr -- Its address @@ -304,6 +493,35 @@ CallishMachOp -- Which one deriving Eq +instance OutputableP Platform ForeignTarget where + pdoc = pprForeignTarget + +pprForeignTarget :: Platform -> ForeignTarget -> SDoc +pprForeignTarget platform (ForeignTarget fn c) = + ppr c <+> ppr_target fn + where + ppr_target :: CmmExpr -> SDoc + ppr_target t@(CmmLit _) = pdoc platform t + ppr_target fn' = parens (pdoc platform fn') +pprForeignTarget platform (PrimTarget op) + -- HACK: We're just using a ForeignLabel to get this printed, the label + -- might not really be foreign. + = pdoc platform + (mkForeignLabel + (mkFastString (show op)) + Nothing ForeignLabelInThisPackage IsFunction) + +instance Outputable Convention where + ppr = pprConvention + +pprConvention :: Convention -> SDoc +pprConvention (NativeNodeCall {}) = text "" +pprConvention (NativeDirectCall {}) = text "" +pprConvention (NativeReturn {}) = text "" +pprConvention Slow = text "" +pprConvention GC = text "" + + foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint]) foreignTargetHints target = ( res_hints ++ repeat NoHint @@ -505,7 +723,7 @@ mapExpM _ (CmmTick _) = Nothing mapExpM f (CmmUnwind regs) = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e -mapExpM f (CmmStore addr e align) = (\[addr', e'] -> CmmStore addr' e' align) `fmap` mapListM f [addr, e] +mapExpM f (CmmStore addr e align) = (\ (Pair addr' e') -> CmmStore addr' e' align) `fmap` traverse f (Pair addr e) mapExpM _ (CmmBranch _) = Nothing mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e @@ -693,7 +911,7 @@ compare GlobalScope _ = LT compare _ GlobalScope = GT compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u' - compare scope scope' = cmpList nonDetCmpUnique + compare scope scope' = liftCompare nonDetCmpUnique (sortBy nonDetCmpUnique $ scopeUniques scope) (sortBy nonDetCmpUnique $ scopeUniques scope') diff --git a/GHC/Cmm/Parser.hs b/GHC/Cmm/Parser.hs --- a/GHC/Cmm/Parser.hs +++ b/GHC/Cmm/Parser.hs @@ -5,16 +5,11 @@ #endif {-# LANGUAGE TupleSections #-} -module GHC.Cmm.Parser ( parseCmmFile ) where +module GHC.Cmm.Parser ( parseCmmFile, CmmParserConfig(..) ) where import GHC.Prelude import qualified Prelude -- for happy-generated code -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Config.Parser (initParserOpts) -import GHC.Driver.Config.StgToCmm - import GHC.Platform import GHC.Platform.Profile @@ -45,6 +40,7 @@ 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 @@ -494,7 +490,7 @@ 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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +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 = @@ -510,22 +506,22 @@ 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\xc1\x03\xc3\x03\x00\x00\x00\x00\x00\x00"# +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\xc4\x03\x00\x00\xc2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\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\xce\x03\x3c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\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\xd8\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\xd2\x03\x00\x00\xea\x03\x00\x00\x00\x00\x00\x00\xe7\xff\x00\x00\xdf\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\xd0\x03\x00\x00\x9e\x03\xaa\x03\x00\x00\xac\x03\x00\x00\x00\x00\x00\x00\xcd\x03\xdb\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\xdd\x03\x00\x00\xe1\x03\x00\x00\x00\x00\x9c\x01\x9e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x03\xc6\x03\x4b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x03\x00\x00\xfb\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\xf7\x03\x54\x03\xd3\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x01\x00\x00\x00\x00\x11\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\x17\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\x09\x04\x16\x01\x00\x00\x00\x00\x5a\x00\x16\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\x22\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\x0a\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\x15\x04\x00\x00\x00\x00\x00\x00\x82\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x04\x1b\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\x26\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +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\xe5\xff"# +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\x08\x00\x08\x00\x23\x00\x24\x00\x23\x00\x24\x00\x0f\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x09\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\x06\x00\x2c\x00\x0f\x00\x03\x00\x23\x00\x24\x00\x23\x00\x24\x00\x1b\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x26\x00\x2c\x00\x25\x00\x19\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\x22\x00\x31\x00\x23\x00\x24\x00\x23\x00\x24\x00\x30\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x14\x00\x2c\x00\x1a\x00\x09\x00\x23\x00\x24\x00\x23\x00\x24\x00\x06\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x06\x00\x2c\x00\x09\x00\x1a\x00\x23\x00\x24\x00\x23\x00\x24\x00\x20\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x21\x00\x2c\x00\x18\x00\x1f\x00\x23\x00\x24\x00\x23\x00\x24\x00\x11\x00\x36\x00\x37\x00\x36\x00\x37\x00\x2c\x00\x1e\x00\x2c\x00\x15\x00\x1f\x00\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\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"# +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\xc1\x01\x7e\x00\xc0\x01\x2d\x00\xf1\x00\x7d\x00\xef\x00\x7d\x00\x2c\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x4e\x00\x7e\x00\x24\x00\x43\x00\xe5\x00\x7d\x00\xe0\x00\x7d\x00\x30\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x92\x00\x7e\x00\x2c\x00\x41\x00\xb9\x00\x7d\x00\x3e\x01\x7d\x00\x9a\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\xee\x00\x7e\x00\xf3\x00\xd8\x00\x33\x01\x7d\x00\x32\x01\x7d\x00\x97\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\xec\x00\x7e\x00\xd3\x00\x16\x01\x31\x01\x7d\x00\x30\x01\x7d\x00\xba\x00\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x3b\x01\x7e\x00\x19\x01\x54\x01\x2f\x01\x7d\x00\x2e\x01\x7d\x00\x0c\x01\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\xfe\x00\x7e\x00\x4d\x01\x73\x01\x2d\x01\x7d\x00\x2c\x01\x7d\x00\x6e\x01\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x89\x01\x7e\x00\xa3\x01\x6b\x01\x2b\x01\x7d\x00\x2a\x01\x7d\x00\x6a\x01\x7f\x00\x09\x00\x7f\x00\x09\x00\x7e\x00\x9a\x01\x7e\x00\xa8\x01\x9d\x01\x29\x01\x7d\x00\x28\x01\x7d\x00\x00\x00\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\x00\x00\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"# +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), @@ -898,7 +894,7 @@ 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) [] [] [] } + dontCareCCS (map getLit lits) [] [] [] [] } ) `HappyStk` happyRest}} happyReduce_17 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ) @@ -936,7 +932,7 @@ platform <- getPlatform; ctx <- getContext; formals <- sequence (fromMaybe [] happy_var_3); - withName (renderWithContext ctx (pdoc platform entry_ret_label)) + 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 @@ -1030,8 +1026,10 @@ ) (\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 16# 10# happyReduction_26 -happyReduction_26 (happy_x_16 `HappyStk` +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` @@ -1055,13 +1053,13 @@ 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 0 (ArgSpec (fromIntegral happy_var_15)) - -- Arity zero, arg_type happy_var_15 + 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 @@ -1069,7 +1067,7 @@ 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 ) @@ -2866,8 +2864,9 @@ exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) exprOp name args_code = do - profile <- PD.getProfile - align_check <- gopt Opt_AlignmentSanitisation <$> getDynFlags + 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 @@ -2902,7 +2901,6 @@ ( "ne", MO_Ne ), ( "mul", MO_Mul ), ( "mulmayoflo", MO_S_MulMayOflo ), - ( "mulmayoflou", MO_U_MulMayOflo ), ( "neg", MO_S_Neg ), ( "quot", MO_S_Quot ), ( "rem", MO_S_Rem ), @@ -3184,7 +3182,7 @@ staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload = do profile <- getProfile - let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] + let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] [] code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits foreignCall @@ -3435,45 +3433,41 @@ ] where platform = profilePlatform profile - -parseCmmFile :: DynFlags +parseCmmFile :: CmmParserConfig -> Module -> HomeUnit -> FilePath -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt])) -parseCmmFile dflags this_mod home_unit filename = do +parseCmmFile cmmpConfig this_mod home_unit filename = do buf <- hGetStringBuffer filename let init_loc = mkRealSrcLoc (mkFastString filename) 1 1 - opts = initParserOpts dflags - init_state = (initParserState opts buf init_loc) { lex_state = [0] } + 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. - case unPD cmmParse dflags home_unit init_state of + 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 $ targetProfile dflags) - let config = initStgToCmmConfig dflags no_module + let fstate = F.initFCodeState (profilePlatform $ pdProfile pdConfig) let fcode = do - ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return () + ((), 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 config + do_ipe = stgToCmmInfoTableMap $ cmmpStgToCmmConfig cmmpConfig ((), cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info return (cmm ++ cmm2, used_info) - (cmm, _) = runC config fstate st fcode + (cmm, _) = runC (cmmpStgToCmmConfig cmmpConfig) fstate st fcode (warnings,errors) = getPsMessages pst if not (isEmptyMessages errors) then return (warnings, errors, Nothing) else return (warnings, errors, Just cmm) - where - no_module = panic "parseCmmFile: no module" {-# LINE 1 "templates/GenericTemplate.hs" #-} -- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $ diff --git a/GHC/Cmm/Parser/Config.hs b/GHC/Cmm/Parser/Config.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Parser/Config.hs @@ -0,0 +1,24 @@ +module GHC.Cmm.Parser.Config ( + PDConfig(..) + , CmmParserConfig(..) +) where + +import GHC.Prelude + +import GHC.Platform.Profile + +import GHC.StgToCmm.Config + +import GHC.Parser.Lexer + + +data PDConfig = PDConfig + { pdProfile :: !Profile + , pdSanitizeAlignment :: !Bool -- ^ Insert alignment checks (cf @-falignment-sanitisation@) + } + +data CmmParserConfig = CmmParserConfig + { cmmpParserOpts :: !ParserOpts + , cmmpPDConfig :: !PDConfig + , cmmpStgToCmmConfig :: !StgToCmmConfig + } diff --git a/GHC/Cmm/Parser/Monad.hs b/GHC/Cmm/Parser/Monad.hs --- a/GHC/Cmm/Parser/Monad.hs +++ b/GHC/Cmm/Parser/Monad.hs @@ -11,19 +11,22 @@ PD(..) , liftP , failMsgPD + , getPDConfig , getProfile , getPlatform , getHomeUnitId + , PDConfig(..) ) where import GHC.Prelude +import GHC.Cmm.Parser.Config + import GHC.Platform import GHC.Platform.Profile import Control.Monad -import GHC.Driver.Session import GHC.Parser.Lexer import GHC.Parser.Errors.Types import GHC.Types.Error ( MsgEnvelope ) @@ -31,7 +34,7 @@ import GHC.Unit.Types import GHC.Unit.Home -newtype PD a = PD { unPD :: DynFlags -> HomeUnit -> PState -> ParseResult a } +newtype PD a = PD { unPD :: PDConfig -> HomeUnit -> PState -> ParseResult a } instance Functor PD where fmap = liftM @@ -58,11 +61,11 @@ POk s1 a -> unPD (k a) d hu s1 PFailed s1 -> PFailed s1 -instance HasDynFlags PD where - getDynFlags = PD $ \d _ s -> POk s d +getPDConfig :: PD PDConfig +getPDConfig = PD $ \pdc _ s -> POk s pdc getProfile :: PD Profile -getProfile = targetProfile <$> getDynFlags +getProfile = PD $ \pdc _ s -> POk s (pdProfile pdc) getPlatform :: PD Platform getPlatform = profilePlatform <$> getProfile diff --git a/GHC/Cmm/Pipeline.hs b/GHC/Cmm/Pipeline.hs --- a/GHC/Cmm/Pipeline.hs +++ b/GHC/Cmm/Pipeline.hs @@ -1,14 +1,13 @@ {-# LANGUAGE BangPatterns #-} module GHC.Cmm.Pipeline ( - -- | Converts C-- with an implicit stack and native C-- calls into - -- optimized, CPS converted and native-call-less C--. The latter - -- C-- can be used to generate assembly. cmmPipeline ) where import GHC.Prelude +import GHC.Driver.Flags + import GHC.Cmm import GHC.Cmm.Config import GHC.Cmm.ContFlowOpt @@ -20,39 +19,41 @@ import GHC.Cmm.ProcPoint import GHC.Cmm.Sink import GHC.Cmm.Switch.Implement +import GHC.Cmm.ThreadSanitizer import GHC.Types.Unique.Supply -import GHC.Driver.Session -import GHC.Driver.Config.Cmm + import GHC.Utils.Error import GHC.Utils.Logger -import GHC.Driver.Env -import Control.Monad import GHC.Utils.Outputable + import GHC.Platform + +import Control.Monad import Data.Either (partitionEithers) ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline ----------------------------------------------------------------------------- +-- | Converts C-- with an implicit stack and native C-- calls into +-- optimized, CPS converted and native-call-less C--. The latter +-- C-- can be used to generate assembly. cmmPipeline - :: HscEnv -- Compilation env including - -- dynamic flags: -dcmm-lint -ddump-cmm-cps + :: Logger + -> CmmConfig -> ModuleSRTInfo -- Info about SRTs generated so far -> CmmGroup -- Input C-- with Procedures -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C-- -cmmPipeline hsc_env srtInfo prog = do - let logger = hsc_logger hsc_env - let cmmConfig = initCmmConfig (hsc_dflags hsc_env) +cmmPipeline logger cmm_config srtInfo prog = do let forceRes (info, group) = info `seq` foldr seq () group - let platform = cmmPlatform cmmConfig + let platform = cmmPlatform cmm_config withTimingSilent logger (text "Cmm pipeline") forceRes $ do - tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmmConfig) prog + tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmm_config) prog let (procs, data_) = partitionEithers tops - (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmmConfig srtInfo procs data_ + (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo procs data_ dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) return (srtInfo, cmms) @@ -66,8 +67,8 @@ -- [SRTs]. -- -- - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing -cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) -cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p)) +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 = do ----------- Control-flow optimisations ---------------------------------- @@ -98,6 +99,13 @@ else pure g dump Opt_D_dump_cmm_switch "Post switch plan" g + ----------- ThreadSanitizer instrumentation ----------------------------- + g <- {-# SCC "annotateTSAN" #-} + if cmmOptThreadSanitizer cfg + then runUniqSM $ annotateTSAN platform g + else return g + dump Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g + ----------- Proc points ------------------------------------------------- let call_pps :: ProcPointSet -- LabelMap @@ -156,7 +164,7 @@ return $ if cmmOptControlFlow cfg then map (cmmCfgOptsProc splitting_proc_points) g else g - g <- return (map removeUnreachableBlocksProc g) + g <- return $ map (removeUnreachableBlocksProc platform) g -- See Note [unreachable blocks] dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g diff --git a/GHC/Cmm/Ppr.hs b/GHC/Cmm/Ppr.hs deleted file mode 100644 --- a/GHC/Cmm/Ppr.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - ----------------------------------------------------------------------------- --- --- Pretty-printing of Cmm as (a superset of) C-- --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ --- --- This is where we walk over CmmNode emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We --- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs - -module GHC.Cmm.Ppr - ( module GHC.Cmm.Ppr.Decl - , module GHC.Cmm.Ppr.Expr - ) -where - -import GHC.Prelude hiding (succ) - -import GHC.Platform -import GHC.Cmm.CLabel -import GHC.Cmm -import GHC.Cmm.Utils -import GHC.Cmm.Switch -import GHC.Data.FastString -import GHC.Utils.Outputable -import GHC.Cmm.Ppr.Decl -import GHC.Cmm.Ppr.Expr -import GHC.Utils.Constants (debugIsOn) - -import GHC.Types.Basic -import GHC.Cmm.Dataflow.Block -import GHC.Cmm.Dataflow.Graph - -------------------------------------------------- --- Outputable instances -instance OutputableP Platform InfoProvEnt where - pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel - -instance Outputable CmmStackInfo where - ppr = pprStackInfo - -instance OutputableP Platform CmmTopInfo where - pdoc = pprTopInfo - - -instance OutputableP Platform (CmmNode e x) where - pdoc = pprNode - -instance Outputable Convention where - ppr = pprConvention - -instance Outputable ForeignConvention where - ppr = pprForeignConvention - -instance OutputableP Platform ForeignTarget where - pdoc = pprForeignTarget - -instance Outputable CmmReturnInfo where - ppr = pprReturnInfo - -instance OutputableP Platform (Block CmmNode C C) where - pdoc = pprBlock -instance OutputableP Platform (Block CmmNode C O) where - pdoc = pprBlock -instance OutputableP Platform (Block CmmNode O C) where - pdoc = pprBlock -instance OutputableP Platform (Block CmmNode O O) where - pdoc = pprBlock - -instance OutputableP Platform (Graph CmmNode e x) where - pdoc = pprGraph - -instance OutputableP Platform CmmGraph where - pdoc = pprCmmGraph - ----------------------------------------------------------- --- Outputting types Cmm contains - -pprStackInfo :: CmmStackInfo -> SDoc -pprStackInfo (StackInfo {arg_space=arg_space}) = - text "arg_space: " <> ppr arg_space - -pprTopInfo :: Platform -> CmmTopInfo -> SDoc -pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) = - vcat [text "info_tbls: " <> pdoc platform info_tbl, - text "stack_info: " <> ppr stack_info] - ----------------------------------------------------------- --- Outputting blocks and graphs - -pprBlock :: IndexedCO x SDoc SDoc ~ SDoc - => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc -pprBlock platform block - = foldBlockNodesB3 ( ($$) . pdoc platform - , ($$) . (nest 4) . pdoc platform - , ($$) . (nest 4) . pdoc platform - ) - block - empty - -pprGraph :: Platform -> Graph CmmNode e x -> SDoc -pprGraph platform = \case - GNil -> empty - GUnit block -> pdoc platform block - GMany entry body exit -> - text "{" - $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit) - $$ text "}" - where pprMaybeO :: OutputableP Platform (Block CmmNode e x) - => MaybeO ex (Block CmmNode e x) -> SDoc - pprMaybeO NothingO = empty - pprMaybeO (JustO block) = pdoc platform block - -pprCmmGraph :: Platform -> CmmGraph -> SDoc -pprCmmGraph platform g - = text "{" <> text "offset" - $$ nest 2 (vcat $ map (pdoc platform) blocks) - $$ text "}" - where blocks = revPostorder g - -- revPostorder has the side-effect of discarding unreachable code, - -- so pretty-printed Cmm will omit any unreachable blocks. This can - -- sometimes be confusing. - ---------------------------------------------- --- Outputting CmmNode and types which it contains - -pprConvention :: Convention -> SDoc -pprConvention (NativeNodeCall {}) = text "" -pprConvention (NativeDirectCall {}) = text "" -pprConvention (NativeReturn {}) = text "" -pprConvention Slow = text "" -pprConvention GC = text "" - -pprForeignConvention :: ForeignConvention -> SDoc -pprForeignConvention (ForeignConvention c args res ret) = - doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret - -pprReturnInfo :: CmmReturnInfo -> SDoc -pprReturnInfo CmmMayReturn = empty -pprReturnInfo CmmNeverReturns = text "never returns" - -pprForeignTarget :: Platform -> ForeignTarget -> SDoc -pprForeignTarget platform (ForeignTarget fn c) = ppr c <+> ppr_target fn - where - ppr_target :: CmmExpr -> SDoc - ppr_target t@(CmmLit _) = pdoc platform t - ppr_target fn' = parens (pdoc platform fn') - -pprForeignTarget platform (PrimTarget op) - -- HACK: We're just using a ForeignLabel to get this printed, the label - -- might not really be foreign. - = pdoc platform - (CmmLabel (mkForeignLabel - (mkFastString (show op)) - Nothing ForeignLabelInThisPackage IsFunction)) - -pprNode :: Platform -> CmmNode e x -> SDoc -pprNode platform node = pp_node <+> pp_debug - where - pp_node :: SDoc - pp_node = case node of - -- label: - CmmEntry id tscope -> - (sdocOption sdocSuppressUniques $ \case - True -> text "_lbl_" - False -> ppr id - ) - <> colon - <+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope) - - -- // text - CmmComment s -> text "//" <+> ftext s - - -- //tick bla<...> - CmmTick t -> ppUnlessOption sdocSuppressTicks - (text "//tick" <+> ppr t) - - -- unwind reg = expr; - CmmUnwind regs -> - text "unwind " - <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi - - -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi - - -- rep[lv] = expr; - CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi - where - align_mark = case align of - Unaligned -> text "^" - NaturallyAligned -> empty - rep = ppr ( cmmExprType platform expr ) - - -- call "ccall" foo(x, y)[r1, r2]; - -- ToDo ppr volatile - CmmUnsafeForeignCall target results args -> - hsep [ ppUnless (null results) $ - parens (commafy $ map ppr results) <+> equals, - text "call", - pdoc platform target <> parens (commafy $ map (pdoc platform) args) <> semi] - - -- goto label; - CmmBranch ident -> text "goto" <+> ppr ident <> semi - - -- if (expr) goto t; else goto f; - CmmCondBranch expr t f l -> - hsep [ text "if" - , parens (pdoc platform expr) - , case l of - Nothing -> empty - Just b -> parens (text "likely:" <+> ppr b) - , text "goto" - , ppr t <> semi - , text "else goto" - , ppr f <> semi - ] - - CmmSwitch expr ids -> - hang (hsep [ text "switch" - , range - , if isTrivialCmmExpr expr - then pdoc platform expr - else parens (pdoc platform expr) - , text "{" - ]) - 4 (vcat (map ppCase cases) $$ def) $$ rbrace - where - (cases, mbdef) = switchTargetsFallThrough ids - ppCase (is,l) = hsep - [ text "case" - , commafy $ map integer is - , text ": goto" - , ppr l <> semi - ] - def | Just l <- mbdef = hsep - [ text "default:" - , braces (text "goto" <+> ppr l <> semi) - ] - | otherwise = empty - - range = brackets $ hsep [integer lo, text "..", integer hi] - where (lo,hi) = switchTargetsRange ids - - CmmCall tgt k regs out res updfr_off -> - hcat [ text "call", space - , pprFun tgt, parens (interpp'SP regs), space - , returns <+> - text "args: " <> ppr out <> comma <+> - text "res: " <> ppr res <> comma <+> - text "upd: " <> ppr updfr_off - , semi ] - where pprFun f@(CmmLit _) = pdoc platform f - pprFun f = parens (pdoc platform f) - - returns - | Just r <- k = text "returns to" <+> ppr r <> comma - | otherwise = empty - - CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> - hcat $ if i then [text "interruptible", space] else [] ++ - [ text "foreign call", space - , pdoc platform t, text "(...)", space - , text "returns to" <+> ppr s - <+> text "args:" <+> parens (pdoc platform as) - <+> text "ress:" <+> parens (ppr rs) - , text "ret_args:" <+> ppr a - , text "ret_off:" <+> ppr u - , semi ] - - pp_debug :: SDoc - pp_debug = - if not debugIsOn then empty - else case node of - CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry" - CmmComment {} -> empty -- Looks also terrible with text " // CmmComment" - CmmTick {} -> empty - CmmUnwind {} -> text " // CmmUnwind" - CmmAssign {} -> text " // CmmAssign" - CmmStore {} -> text " // CmmStore" - CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall" - CmmBranch {} -> text " // CmmBranch" - CmmCondBranch {} -> text " // CmmCondBranch" - CmmSwitch {} -> text " // CmmSwitch" - CmmCall {} -> text " // CmmCall" - CmmForeignCall {} -> text " // CmmForeignCall" - - commafy :: [SDoc] -> SDoc - commafy xs = hsep $ punctuate comma xs diff --git a/GHC/Cmm/Ppr/Decl.hs b/GHC/Cmm/Ppr/Decl.hs deleted file mode 100644 --- a/GHC/Cmm/Ppr/Decl.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} - - ----------------------------------------------------------------------------- --- --- Pretty-printing of common Cmm types --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - --- --- This is where we walk over Cmm emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We --- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs --- - -{-# OPTIONS_GHC -fno-warn-orphans #-} -module GHC.Cmm.Ppr.Decl - ( pprCmms, pprCmmGroup, pprSection, pprStatic - ) -where - -import GHC.Prelude - -import GHC.Platform -import GHC.Cmm.Ppr.Expr -import GHC.Cmm - -import GHC.Utils.Outputable - -import Data.List (intersperse) - -import qualified Data.ByteString as BS - - -pprCmms :: (OutputableP Platform info, OutputableP Platform g) - => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc -pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms)) - where - separator = space $$ text "-------------------" $$ space - ------------------------------------------------------------------------------ - -instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) - => OutputableP Platform (GenCmmDecl d info i) where - pdoc = pprTop - -instance OutputableP Platform (GenCmmStatics a) where - pdoc = pprStatics - -instance OutputableP Platform CmmStatic where - pdoc = pprStatic - -instance OutputableP Platform CmmInfoTable where - pdoc = pprInfoTable - - ------------------------------------------------------------------------------ - -pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g) - => Platform -> GenCmmGroup d info g -> SDoc -pprCmmGroup platform tops - = vcat $ intersperse blankLine $ map (pprTop platform) tops - --- -------------------------------------------------------------------------- --- Top level `procedure' blocks. --- -pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i) - => Platform -> GenCmmDecl d info i -> SDoc - -pprTop platform (CmmProc info lbl live graph) - - = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live - , nest 8 $ lbrace <+> pdoc platform info $$ rbrace - , nest 4 $ pdoc platform graph - , rbrace ] - --- -------------------------------------------------------------------------- --- We follow [1], 4.5 --- --- section "data" { ... } --- -pprTop platform (CmmData section ds) = - (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds)) - $$ rbrace - --- -------------------------------------------------------------------------- --- Info tables. - -pprInfoTable :: Platform -> CmmInfoTable -> SDoc -pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep - , cit_prof = prof_info - , cit_srt = srt }) - = vcat [ text "label: " <> pdoc platform lbl - , text "rep: " <> ppr rep - , case prof_info of - NoProfilingInfo -> empty - ProfilingInfo ct cd -> - vcat [ text "type: " <> text (show (BS.unpack ct)) - , text "desc: " <> text (show (BS.unpack cd)) ] - , text "srt: " <> pdoc platform srt ] - -instance Outputable ForeignHint where - ppr NoHint = empty - ppr SignedHint = quotes(text "signed") --- ppr AddrHint = quotes(text "address") --- Temp Jan08 - ppr AddrHint = (text "PtrHint") - --- -------------------------------------------------------------------------- --- Static data. --- Strings are printed as C strings, and we print them as I8[], --- following C-- --- - -pprStatics :: Platform -> GenCmmStatics a -> SDoc -pprStatics platform (CmmStatics lbl itbl ccs payload) = - pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload -pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds) - -pprStatic :: Platform -> CmmStatic -> SDoc -pprStatic platform s = case s of - CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit platform lit <> semi - CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) - CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') - CmmFileEmbed path -> nest 4 $ text "incbin " <+> text (show path) - --- -------------------------------------------------------------------------- --- data sections --- -pprSection :: Platform -> Section -> SDoc -pprSection platform (Section t suffix) = - section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix) - where - section = text "section" - -pprSectionType :: SectionType -> SDoc -pprSectionType s = doubleQuotes $ case s of - Text -> text "text" - Data -> text "data" - ReadOnlyData -> text "readonly" - ReadOnlyData16 -> text "readonly16" - RelocatableReadOnlyData -> text "relreadonly" - UninitialisedData -> text "uninitialised" - InitArray -> text "initarray" - FiniArray -> text "finiarray" - CString -> text "cstring" - OtherSection s' -> text s' diff --git a/GHC/Cmm/Ppr/Expr.hs b/GHC/Cmm/Ppr/Expr.hs deleted file mode 100644 --- a/GHC/Cmm/Ppr/Expr.hs +++ /dev/null @@ -1,299 +0,0 @@ ----------------------------------------------------------------------------- --- --- Pretty-printing of common Cmm types --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - --- --- This is where we walk over Cmm emitting an external representation, --- suitable for parsing, in a syntax strongly reminiscent of C--. This --- is the "External Core" for the Cmm layer. --- --- As such, this should be a well-defined syntax: we want it to look nice. --- Thus, we try wherever possible to use syntax defined in [1], --- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We --- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather --- than C--'s bits8 .. bits64. --- --- We try to ensure that all information available in the abstract --- syntax is reproduced, or reproducible, in the concrete syntax. --- Data that is not in printed out can be reconstructed according to --- conventions used in the pretty printer. There are at least two such --- cases: --- 1) if a value has wordRep type, the type is not appended in the --- output. --- 2) MachOps that operate over wordRep type are printed in a --- C-style, rather than as their internal MachRep name. --- --- These conventions produce much more readable Cmm output. --- --- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs --- -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module GHC.Cmm.Ppr.Expr - ( pprExpr, pprLit - ) -where - -import GHC.Prelude - -import GHC.Platform -import GHC.Cmm.Expr - -import GHC.Utils.Outputable -import GHC.Utils.Trace - -import Data.Maybe -import Numeric ( fromRat ) - ------------------------------------------------------------------------------ - -instance OutputableP Platform CmmExpr where - pdoc = pprExpr - -instance Outputable CmmReg where - ppr e = pprReg e - -instance OutputableP Platform CmmLit where - pdoc = pprLit - -instance Outputable LocalReg where - ppr e = pprLocalReg e - -instance Outputable Area where - ppr e = pprArea e - -instance Outputable GlobalReg where - ppr e = pprGlobalReg e - -instance OutputableP env GlobalReg where - pdoc _ = ppr - --- -------------------------------------------------------------------------- --- Expressions --- - -pprExpr :: Platform -> CmmExpr -> SDoc -pprExpr platform e - = case e of - CmmRegOff reg i -> - pprExpr platform (CmmMachOp (MO_Add rep) - [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) - where rep = typeWidth (cmmRegType platform reg) - CmmLit lit -> pprLit platform lit - _other -> pprExpr1 platform e - --- Here's the precedence table from GHC.Cmm.Parser: --- %nonassoc '>=' '>' '<=' '<' '!=' '==' --- %left '|' --- %left '^' --- %left '&' --- %left '>>' '<<' --- %left '-' '+' --- %left '/' '*' '%' --- %right '~' - --- We just cope with the common operators for now, the rest will get --- a default conservative behaviour. - --- %nonassoc '>=' '>' '<=' '<' '!=' '==' -pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc -pprExpr1 platform (CmmMachOp op [x,y]) - | Just doc <- infixMachOp1 op - = pprExpr7 platform x <+> doc <+> pprExpr7 platform y -pprExpr1 platform e = pprExpr7 platform e - -infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc - -infixMachOp1 (MO_Eq _) = Just (text "==") -infixMachOp1 (MO_Ne _) = Just (text "!=") -infixMachOp1 (MO_Shl _) = Just (text "<<") -infixMachOp1 (MO_U_Shr _) = Just (text ">>") -infixMachOp1 (MO_U_Ge _) = Just (text ">=") -infixMachOp1 (MO_U_Le _) = Just (text "<=") -infixMachOp1 (MO_U_Gt _) = Just (char '>') -infixMachOp1 (MO_U_Lt _) = Just (char '<') -infixMachOp1 _ = Nothing - --- %left '-' '+' -pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 - = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) -pprExpr7 platform (CmmMachOp op [x,y]) - | Just doc <- infixMachOp7 op - = pprExpr7 platform x <+> doc <+> pprExpr8 platform y -pprExpr7 platform e = pprExpr8 platform e - -infixMachOp7 (MO_Add _) = Just (char '+') -infixMachOp7 (MO_Sub _) = Just (char '-') -infixMachOp7 _ = Nothing - --- %left '/' '*' '%' -pprExpr8 platform (CmmMachOp op [x,y]) - | Just doc <- infixMachOp8 op - = pprExpr8 platform x <+> doc <+> pprExpr9 platform y -pprExpr8 platform e = pprExpr9 platform e - -infixMachOp8 (MO_U_Quot _) = Just (char '/') -infixMachOp8 (MO_Mul _) = Just (char '*') -infixMachOp8 (MO_U_Rem _) = Just (char '%') -infixMachOp8 _ = Nothing - -pprExpr9 :: Platform -> CmmExpr -> SDoc -pprExpr9 platform e = - case e of - CmmLit lit -> pprLit1 platform lit - CmmLoad expr rep align - -> let align_mark = - case align of - NaturallyAligned -> empty - Unaligned -> text "^" - in ppr rep <> align_mark <> brackets (pdoc platform expr) - CmmReg reg -> ppr reg - CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) - CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) - CmmMachOp mop args -> genMachOp platform mop args - -genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc -genMachOp platform mop args - | Just doc <- infixMachOp mop = case args of - -- dyadic - [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y - - -- unary - [x] -> doc <> pprExpr9 platform x - - _ -> pprTrace "GHC.Cmm.Ppr.Expr.genMachOp: machop with strange number of args" - (pprMachOp mop <+> - parens (hcat $ punctuate comma (map (pprExpr platform) args))) - empty - - | isJust (infixMachOp1 mop) - || isJust (infixMachOp7 mop) - || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args)) - - | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args)) - where ppr_op = text (map (\c -> if c == ' ' then '_' else c) - (show mop)) - -- replace spaces in (show mop) with underscores, - --- --- Unsigned ops on the word size of the machine get nice symbols. --- All else get dumped in their ugly format. --- -infixMachOp :: MachOp -> Maybe SDoc -infixMachOp mop - = case mop of - MO_And _ -> Just $ char '&' - MO_Or _ -> Just $ char '|' - MO_Xor _ -> Just $ char '^' - MO_Not _ -> Just $ char '~' - MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) - _ -> Nothing - --- -------------------------------------------------------------------------- --- Literals. --- To minimise line noise we adopt the convention that if the literal --- has the natural machine word size, we do not append the type --- -pprLit :: Platform -> CmmLit -> SDoc -pprLit platform lit = case lit of - CmmInt i rep -> - hcat [ (if i < 0 then parens else id)(integer i) - , ppUnless (rep == wordWidth platform) $ - space <> dcolon <+> ppr rep ] - - CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] - CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>' - CmmLabel clbl -> pdoc platform clbl - CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i - CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-' - <> pdoc platform clbl2 <> ppr_offset i - CmmBlock id -> ppr id - CmmHighStackMark -> text "" - -pprLit1 :: Platform -> CmmLit -> SDoc -pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit) -pprLit1 platform lit = pprLit platform lit - -ppr_offset :: Int -> SDoc -ppr_offset i - | i==0 = empty - | i>=0 = char '+' <> int i - | otherwise = char '-' <> int (-i) - --- -------------------------------------------------------------------------- --- Registers, whether local (temps) or global --- -pprReg :: CmmReg -> SDoc -pprReg r - = case r of - CmmLocal local -> pprLocalReg local - CmmGlobal global -> pprGlobalReg global - --- --- We only print the type of the local reg if it isn't wordRep --- -pprLocalReg :: LocalReg -> SDoc -pprLocalReg (LocalReg uniq rep) = --- = ppr rep <> char '_' <> ppr uniq --- Temp Jan08 - char '_' <> pprUnique uniq <> - (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh - then dcolon <> ptr <> ppr rep - else dcolon <> ptr <> ppr rep) - where - pprUnique unique = sdocOption sdocSuppressUniques $ \case - True -> text "_locVar_" - False -> ppr unique - ptr = empty - --if isGcPtrType rep - -- then doubleQuotes (text "ptr") - -- else empty - --- Stack areas -pprArea :: Area -> SDoc -pprArea Old = text "old" -pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ] - --- needs to be kept in syn with 'GHC.Cmm.Expr.GlobalReg' --- -pprGlobalReg :: GlobalReg -> SDoc -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 - FloatReg n -> char 'F' <> int n - DoubleReg n -> char 'D' <> int n - LongReg n -> char 'L' <> int n - XmmReg n -> text "XMM" <> int n - YmmReg n -> text "YMM" <> int n - ZmmReg n -> text "ZMM" <> int n - Sp -> text "Sp" - SpLim -> text "SpLim" - Hp -> text "Hp" - HpLim -> text "HpLim" - MachSp -> text "MachSp" - UnwindReturnReg-> text "UnwindReturnReg" - CCCS -> text "CCCS" - CurrentTSO -> text "CurrentTSO" - CurrentNursery -> text "CurrentNursery" - HpAlloc -> text "HpAlloc" - EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" - GCEnter1 -> text "stg_gc_enter_1" - GCFun -> text "stg_gc_fun" - BaseReg -> text "BaseReg" - PicBaseReg -> text "PicBaseReg" - ------------------------------------------------------------------------------ - -commafy :: [SDoc] -> SDoc -commafy xs = fsep $ punctuate comma xs diff --git a/GHC/Cmm/ProcPoint.hs b/GHC/Cmm/ProcPoint.hs --- a/GHC/Cmm/ProcPoint.hs +++ b/GHC/Cmm/ProcPoint.hs @@ -2,8 +2,6 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Cmm.ProcPoint ( ProcPointSet, Status(..) , callProcPoints, minimalProcPointSet @@ -17,7 +15,6 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm -import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Cmm.Utils import GHC.Cmm.Info import GHC.Cmm.Liveness diff --git a/GHC/Cmm/Reducibility.hs b/GHC/Cmm/Reducibility.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Reducibility.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-| +Module : GHC.Cmm.Reducibility +Description : Tell if a `CmmGraph` is reducible, or make it so + +Test a Cmm control-flow graph for reducibility. And provide a +function that, when given an arbitrary control-flow graph, returns an +equivalent, reducible control-flow graph. The equivalent graph is +obtained by "splitting" (copying) nodes of the original graph. +The resulting equivalent graph has the same dynamic behavior as the +original, but it is larger. + +Documentation uses the language of control-flow analysis, in which a +basic block is called a "node." These "nodes" are `CmmBlock`s or +equivalent; they have nothing to do with a `CmmNode`. + +For more on reducibility and related analyses and algorithms, see +Note [Reducibility resources] +-} + +module GHC.Cmm.Reducibility + ( Reducibility(..) + , reducibility + + , asReducible + ) +where + +import GHC.Prelude hiding (splitAt, succ) + +import Control.Monad +import Data.List (nub) +import Data.Maybe +import Data.Semigroup +import qualified Data.Sequence as Seq + +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) +import GHC.Cmm.Dataflow.Label +import GHC.Data.Graph.Collapse +import GHC.Data.Graph.Inductive.Graph +import GHC.Data.Graph.Inductive.PatriciaTree +import GHC.Types.Unique.Supply +import GHC.Utils.Panic + +-- | Represents the result of a reducibility analysis. +data Reducibility = Reducible | Irreducible + deriving (Eq, Show) + +-- | Given a graph, say whether the graph is reducible. The graph must +-- be bundled with a dominator analysis and a reverse postorder +-- numbering, as these results are needed to perform the test. + +reducibility :: NonLocal node + => GraphWithDominators node + -> Reducibility +reducibility gwd = + if all goodBlock blockmap then Reducible else Irreducible + where goodBlock b = all (goodEdge (entryLabel b)) (successors b) + goodEdge from to = rpnum to > rpnum from || to `dominates` from + rpnum = gwdRPNumber gwd + blockmap = graphMap $ gwd_graph gwd + dominators = gwdDominatorsOf gwd + dominates lbl blockname = + lbl == blockname || dominatorsMember lbl (dominators blockname) + +-- | Given a graph, return an equivalent reducible graph, by +-- "splitting" (copying) nodes if necessary. The input +-- graph must be bundled with a dominator analysis and a reverse +-- postorder numbering. The computation is monadic because when a +-- node is split, the new copy needs a fresh label. +-- +-- Use this function whenever a downstream algorithm needs a reducible +-- control-flow graph. + +asReducible :: GraphWithDominators CmmNode + -> UniqSM (GraphWithDominators CmmNode) +asReducible gwd = case reducibility gwd of + Reducible -> return gwd + Irreducible -> assertReducible <$> nodeSplit gwd + +assertReducible :: GraphWithDominators CmmNode -> GraphWithDominators CmmNode +assertReducible gwd = case reducibility gwd of + Reducible -> gwd + Irreducible -> panic "result not reducible" + +---------------------------------------------------------------- + +-- | Split one or more nodes of the given graph, which must be +-- irreducible. + +nodeSplit :: GraphWithDominators CmmNode + -> UniqSM (GraphWithDominators CmmNode) +nodeSplit gwd = + graphWithDominators <$> inflate (g_entry g) <$> runNullCollapse collapsed + where g = gwd_graph gwd + collapsed :: NullCollapseViz (Gr CmmSuper ()) + collapsed = collapseInductiveGraph (cgraphOfCmm g) + +type CGraph = Gr CmmSuper () + +-- | Turn a collapsed supernode back into a control-flow graph +inflate :: Label -> CGraph -> CmmGraph +inflate entry cg = CmmGraph entry graph + where graph = GMany NothingO body NothingO + body :: LabelMap CmmBlock + body = foldl (\map block -> mapInsert (entryLabel block) block map) mapEmpty $ + blocks super + super = case labNodes cg of + [(_, s)] -> s + _ -> panic "graph given to `inflate` is not singleton" + + +-- | Convert a `CmmGraph` into an inductive graph. +-- (The function coalesces duplicate edges into a single edge.) +cgraphOfCmm :: CmmGraph -> CGraph +cgraphOfCmm g = foldl' addSuccEdges (mkGraph cnodes []) blocks + where blocks = zip [0..] $ revPostorderFrom (graphMap g) (g_entry g) + cnodes = [(k, super block) | (k, block) <- blocks] + where super block = Nodes (entryLabel block) (Seq.singleton block) + labelNumber = \lbl -> fromJust $ mapLookup lbl numbers + where numbers :: LabelMap Int + numbers = mapFromList $ map swap blocks + swap (k, block) = (entryLabel block, k) + addSuccEdges :: CGraph -> (Node, CmmBlock) -> CGraph + addSuccEdges graph (k, block) = + insEdges [(k, labelNumber lbl, ()) | lbl <- nub $ successors block] graph +{- +Note [Reducibility resources] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +*Flow Analysis of Computer Programs.* Matthew S. Hecht North Holland, 1977. +Available to borrow from archive.org. + +Matthew S. Hecht and Jeffrey D. Ullman (1972). +Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202. +https://doi.org/10.1137/0201014 + +Johan Janssen and Henk Corporaal. 1997. Making graphs reducible with +controlled node splitting. ACM TOPLAS 19, 6 (Nov. 1997), +1031–1052. DOI:https://doi.org/10.1145/267959.269971 + +Sebastian Unger and Frank Mueller. 2002. Handling irreducible loops: +optimized node splitting versus DJ-graphs. ACM TOPLAS 24, 4 (July +2002), 299–333. https://doi.org/10.1145/567097.567098. (This one +contains the most detailed account of how the Hecht/Ullman algorithm +is used to modify an actual control-flow graph. But still not much detail.) + +https://rgrig.blogspot.com/2009/10/dtfloatleftclearleft-summary-of-some.html + (Nice summary of useful facts) + +-} + + + +type Seq = Seq.Seq + +-- | A "supernode" contains a single-entry, multiple-exit, reducible subgraph. +-- The entry point is the given label, and the block with that label +-- dominates all the other blocks in the supernode. When an entire +-- graph is collapsed into a single supernode, the graph is reducible. +-- More detail can be found in "GHC.Data.Graph.Collapse". + +data CmmSuper + = Nodes { label :: Label + , blocks :: Seq CmmBlock + } + +instance Semigroup CmmSuper where + s <> s' = Nodes (label s) (blocks s <> blocks s') + +instance PureSupernode CmmSuper where + superLabel = label + mapLabels = changeLabels + +instance Supernode CmmSuper NullCollapseViz where + freshen s = liftUniqSM $ relabel s + + +-- | Return all labels defined within a supernode. +definedLabels :: CmmSuper -> Seq Label +definedLabels = fmap entryLabel . blocks + + + +-- | Map the given function over every use and definition of a label +-- in the given supernode. +changeLabels :: (Label -> Label) -> (CmmSuper -> CmmSuper) +changeLabels f (Nodes l blocks) = Nodes (f l) (fmap (changeBlockLabels f) blocks) + +-- | Map the given function over every use and definition of a label +-- in the given block. +changeBlockLabels :: (Label -> Label) -> CmmBlock -> CmmBlock +changeBlockLabels f block = blockJoin entry' middle exit' + where (entry, middle, exit) = blockSplit block + entry' = let CmmEntry l scope = entry + in CmmEntry (f l) scope + exit' = case exit of + -- unclear why mapSuccessors doesn't touch these + CmmCall { cml_cont = Just l } -> exit { cml_cont = Just (f l) } + CmmForeignCall { succ = l } -> exit { succ = f l } + _ -> mapSuccessors f exit + + +-- | Within the given supernode, replace every defined label (and all +-- of its uses) with a fresh label. + +relabel :: CmmSuper -> UniqSM 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) + addPair map old = do new <- newBlockId + return $ mapInsert old new map + labelChanger :: LabelMap Label -> (Label -> Label) + labelChanger mapping = \lbl -> mapFindWithDefault lbl lbl mapping diff --git a/GHC/Cmm/Reg.hs b/GHC/Cmm/Reg.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/Reg.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module GHC.Cmm.Reg + ( -- * Cmm Registers + CmmReg(..) + , cmmRegType + , cmmRegWidth + -- * Local registers + , LocalReg(..) + , localRegType + -- * Global registers + , GlobalReg(..), isArgReg, globalRegType + , pprGlobalReg + , spReg, hpReg, spLimReg, hpLimReg, nodeReg + , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg + , node, baseReg + , VGcPtr(..) + ) where + +import GHC.Prelude + +import GHC.Platform +import GHC.Utils.Outputable +import GHC.Types.Unique +import GHC.Cmm.Type + +----------------------------------------------------------------------------- +-- Cmm registers +----------------------------------------------------------------------------- + +data CmmReg + = CmmLocal {-# UNPACK #-} !LocalReg + | CmmGlobal GlobalReg + deriving( Eq, Ord, Show ) + +instance Outputable CmmReg where + ppr e = pprReg e + +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 + +cmmRegWidth :: Platform -> CmmReg -> Width +cmmRegWidth platform = typeWidth . cmmRegType platform + + +----------------------------------------------------------------------------- +-- Local registers +----------------------------------------------------------------------------- + +data LocalReg + = LocalReg {-# UNPACK #-} !Unique !CmmType + -- ^ Parameters: + -- 1. Identifier + -- 2. Type + deriving Show + +instance Eq LocalReg where + (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2 + +instance Outputable LocalReg where + ppr e = pprLocalReg e + +-- This is non-deterministic but we do not currently support deterministic +-- code-generation. See Note [Unique Determinism and code generation] +-- See Note [No Ord for Unique] +instance Ord LocalReg where + compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2 + +instance Uniquable LocalReg where + getUnique (LocalReg uniq _) = uniq + +localRegType :: LocalReg -> CmmType +localRegType (LocalReg _ rep) = rep + +-- +-- We only print the type of the local reg if it isn't wordRep +-- +pprLocalReg :: LocalReg -> SDoc +pprLocalReg (LocalReg uniq rep) = +-- = ppr rep <> char '_' <> ppr uniq +-- Temp Jan08 + char '_' <> pprUnique uniq <> + (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh + then dcolon <> ptr <> ppr rep + else dcolon <> ptr <> ppr rep) + where + pprUnique unique = sdocOption sdocSuppressUniques $ \case + True -> text "_locVar_" + False -> ppr unique + ptr = empty + --if isGcPtrType rep + -- then doubleQuotes (text "ptr") + -- else empty + +----------------------------------------------------------------------------- +-- Global STG registers +----------------------------------------------------------------------------- +{- +Note [Overlapping global registers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The backend might not faithfully implement the abstraction of the STG +machine with independent registers for different values of type +GlobalReg. Specifically, certain pairs of registers (r1, r2) may +overlap in the sense that a store to r1 invalidates the value in r2, +and vice versa. + +Currently this occurs only on the x86_64 architecture where FloatReg n +and DoubleReg n are assigned the same microarchitectural register, in +order to allow functions to receive more Float# or Double# arguments +in registers (as opposed to on the stack). + +There are no specific rules about which registers might overlap with +which other registers, but presumably it's safe to assume that nothing +will overlap with special registers like Sp or BaseReg. + +Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap +on a particular platform. The instance Eq GlobalReg is syntactic +equality of STG registers and does not take overlap into +account. However it is still used in UserOfRegs/DefinerOfRegs and +there are likely still bugs there, beware! +-} + +data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) + +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 + + | DoubleReg -- double-precision floating-point registers + {-# UNPACK #-} !Int -- its number + + | LongReg -- long int registers (64-bit, really) + {-# UNPACK #-} !Int -- its number + + | XmmReg -- 128-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + | YmmReg -- 256-bit SIMD vector register + {-# UNPACK #-} !Int -- its number + + | ZmmReg -- 512-bit SIMD vector register + {-# 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 + + -- 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 + + -- 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 + -- 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 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 + -- 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 + +instance Outputable GlobalReg where + ppr e = pprGlobalReg e + +instance OutputableP env GlobalReg where + pdoc _ = ppr + +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 + FloatReg n -> char 'F' <> int n + DoubleReg n -> char 'D' <> int n + LongReg n -> char 'L' <> int n + XmmReg n -> text "XMM" <> int n + YmmReg n -> text "YMM" <> int n + ZmmReg n -> text "ZMM" <> int n + Sp -> text "Sp" + SpLim -> text "SpLim" + Hp -> text "Hp" + HpLim -> text "HpLim" + MachSp -> text "MachSp" + UnwindReturnReg-> text "UnwindReturnReg" + CCCS -> text "CCCS" + CurrentTSO -> text "CurrentTSO" + CurrentNursery -> text "CurrentNursery" + HpAlloc -> text "HpAlloc" + EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info" + GCEnter1 -> text "stg_gc_enter_1" + GCFun -> text "stg_gc_fun" + BaseReg -> text "BaseReg" + PicBaseReg -> text "PicBaseReg" +{-# SPECIALIZE pprGlobalReg :: GlobalReg -> SDoc #-} +{-# SPECIALIZE pprGlobalReg :: GlobalReg -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + + +-- 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 + +node :: GlobalReg +node = VanillaReg 1 VGcPtr + +globalRegType :: Platform -> GlobalReg -> CmmType +globalRegType platform = \case + (VanillaReg _ VGcPtr) -> gcWord platform + (VanillaReg _ VNonGcPtr) -> bWord 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. + -- 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) + + Hp -> gcWord platform -- The initialiser for all + -- dynamically allocated closures + _ -> bWord platform + +isArgReg :: GlobalReg -> Bool +isArgReg (VanillaReg {}) = True +isArgReg (FloatReg {}) = True +isArgReg (DoubleReg {}) = True +isArgReg (LongReg {}) = True +isArgReg (XmmReg {}) = True +isArgReg (YmmReg {}) = True +isArgReg (ZmmReg {}) = True +isArgReg _ = False diff --git a/GHC/Cmm/Sink.hs b/GHC/Cmm/Sink.hs --- a/GHC/Cmm/Sink.hs +++ b/GHC/Cmm/Sink.hs @@ -268,7 +268,7 @@ all_succs = concatMap successors blocks succ_counts :: LabelMap Int - succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs + succ_counts = foldl' (\acc l -> mapInsertWith (+) l 1 acc) mapEmpty all_succs -- -- filter the list of assignments to remove any assignments that @@ -360,7 +360,7 @@ * The assignment `_c3 = [R1 + 1]`; (R1 already inlined on pickup) conflicts with R1 = R1, because it reads `R1` and the node writes to R1 - * This is clearly no-sensical because `R1 = R1` doesn't affect R1's value. + * This is clearly nonsensical because `R1 = R1` doesn't affect R1's value. The solutions is to check if we can discard nodes before and *after* simplifying them. We could only do it after as well, but I assume doing it early might save @@ -490,7 +490,7 @@ where (final_node, rest') = go usages live' node' (insertLRegSet l skipped) rest -- Avoid discarding of assignments to vars on the rhs. - -- See Note [Keeping assignemnts mentioned in skipped RHSs] + -- See Note [Keeping assignments mentioned in skipped RHSs] -- usages' = foldLocalRegsUsed platform (\m r -> addToUFM m r 2) -- usages rhs live' = inline foldLocalRegsUsed platform (\m r -> insertLRegSet r m) @@ -518,7 +518,7 @@ inl_exp (CmmMachOp op args) = cmmMachOpFold platform op args inl_exp other = other -{- Note [Keeping assignemnts mentioned in skipped RHSs] +{- Note [Keeping assignments mentioned in skipped RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have to assignments: [z = y, y = e1] and we skip z we *must* retain the assignment y = e1. This is because diff --git a/GHC/Cmm/Switch.hs b/GHC/Cmm/Switch.hs --- a/GHC/Cmm/Switch.hs +++ b/GHC/Cmm/Switch.hs @@ -8,11 +8,11 @@ switchTargetsToList, eqSwitchTargetWith, SwitchPlan(..), - backendSupportsSwitch, + backendHasNativeSwitch, createSwitchPlan, ) where -import GHC.Prelude +import GHC.Prelude hiding (head) import GHC.Utils.Outputable import GHC.Driver.Backend @@ -20,8 +20,7 @@ import GHC.Cmm.Dataflow.Label (Label) import Data.Maybe -import Data.List (groupBy) -import Data.Function (on) +import Data.List.NonEmpty (NonEmpty (..), groupWith, head) import qualified Data.Map as M -- Note [Cmm Switches, the general plan] @@ -201,11 +200,11 @@ -- | Groups cases with equal targets, suitable for pretty-printing to a -- c-like switch statement with fall-through semantics. -switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label) +switchTargetsFallThrough :: SwitchTargets -> ([(NonEmpty Integer, Label)], Maybe Label) switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef) where - groups = map (\xs -> (map fst xs, snd (head xs))) $ - groupBy ((==) `on` snd) $ + groups = fmap (\xs -> (fmap fst xs, snd (head xs))) $ + groupWith snd $ M.toList branches -- | Custom equality helper, needed for "GHC.Cmm.CommonBlockElim" @@ -312,13 +311,6 @@ -} --- | Does the backend support switch out of the box? Then leave this to the --- backend! -backendSupportsSwitch :: Backend -> Bool -backendSupportsSwitch ViaC = True -backendSupportsSwitch LLVM = True -backendSupportsSwitch _ = False - -- | This function creates a SwitchPlan from a SwitchTargets value, breaking it -- down into smaller pieces suitable for code generation. createSwitchPlan :: SwitchTargets -> SwitchPlan @@ -372,7 +364,7 @@ --- Step 3: Fill in the blanks --- --- | A FlatSwitchPlan is a list of SwitchPlans, with an integer inbetween every +-- | A FlatSwitchPlan is a list of SwitchPlans, with an integer in between every -- two entries, dividing the range. -- So if we have (abusing list syntax) [plan1,n,plan2], then we use plan1 if -- the expression is < n, and plan2 otherwise. diff --git a/GHC/Cmm/ThreadSanitizer.hs b/GHC/Cmm/ThreadSanitizer.hs new file mode 100644 --- /dev/null +++ b/GHC/Cmm/ThreadSanitizer.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +-- | Annotate a CmmGraph with ThreadSanitizer instrumentation calls. +module GHC.Cmm.ThreadSanitizer (annotateTSAN) where + +import GHC.Prelude + +import GHC.StgToCmm.Utils (get_GlobalReg_addr) +import GHC.Platform +import GHC.Platform.Regs (activeStgRegs, callerSaves) +import GHC.Cmm +import GHC.Cmm.Utils +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Data.FastString +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.Unique +import GHC.Types.Unique.Supply + +import Data.Maybe (fromMaybe) + +data Env = Env { platform :: Platform + , uniques :: [Unique] + } + +annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph +annotateTSAN platform graph = do + env <- Env platform <$> getUniquesM + return $ modifyGraph (mapGraphBlocks (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 + +annotateBlock :: Env -> Block CmmNode e x -> Block CmmNode e x +annotateBlock env = mapBlockList (annotateNode env) + +annotateNode :: Env -> CmmNode e x -> Block CmmNode e x +annotateNode env node = + case node of + CmmEntry{} -> BlockCO node BNil + CmmComment{} -> BMiddle node + CmmTick{} -> BMiddle node + CmmUnwind{} -> BMiddle node + CmmAssign{} -> annotateNodeOO env node + CmmStore lhs rhs align -> + let ty = cmmExprType (platform env) rhs + rhs_nodes = annotateLoads env (collectExprLoads rhs) + lhs_nodes = annotateLoads env (collectExprLoads lhs) + st = tsanStore env align 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) + arg_nodes = blockConcat $ map (annotateExpr env) args + in arg_nodes `blockAppend` node' + CmmUnsafeForeignCall{} -> annotateNodeOO env node + CmmBranch{} -> annotateNodeOC env node + CmmCondBranch{} -> annotateNodeOC env node + CmmSwitch{} -> annotateNodeOC env node + CmmCall{} -> annotateNodeOC env node + CmmForeignCall{} -> annotateNodeOC env node + +annotateNodeOO :: Env -> CmmNode O O -> Block CmmNode O O +annotateNodeOO env node = + annotateLoads env (collectLoadsNode node) `blockSnoc` node + +annotateNodeOC :: Env -> CmmNode O C -> Block CmmNode O C +annotateNodeOC env node = + annotateLoads env (collectLoadsNode node) `blockJoinTail` node + +annotateExpr :: Env -> CmmExpr -> Block CmmNode O O +annotateExpr env expr = + annotateLoads env (collectExprLoads expr) + +data Load = Load CmmType AlignmentSpec CmmExpr + +annotateLoads :: Env -> [Load] -> Block CmmNode O O +annotateLoads env loads = + blockConcat + [ tsanLoad env align ty addr + | Load ty align addr <- loads + ] + +collectLoadsNode :: CmmNode e x -> [Load] +collectLoadsNode node = + foldExp (\exp rest -> collectExprLoads exp ++ rest) node [] + +-- | Collect all of the memory locations loaded from by a 'CmmExpr'. +collectExprLoads :: CmmExpr -> [Load] +collectExprLoads (CmmLit _) = [] +collectExprLoads (CmmLoad e ty align) = [Load ty align e] +collectExprLoads (CmmReg _) = [] +collectExprLoads (CmmMachOp _op args) = foldMap collectExprLoads args +collectExprLoads (CmmStackSlot _ _) = [] +collectExprLoads (CmmRegOff _ _) = [] + +-- | Generate TSAN instrumentation for a 'CallishMachOp' occurrence. +annotatePrim :: Env + -> CallishMachOp -- ^ the applied operation + -> [CmmFormal] -- ^ results + -> [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_Cmpxchg w) [dest] [addr, expected, new] + = Just $ tsanAtomicCas env MemOrderSeqCst MemOrderSeqCst w addr expected new dest +annotatePrim _ _ _ _ = Nothing + +mkUnsafeCall :: Env + -> ForeignTarget -- ^ function + -> [CmmFormal] -- ^ results + -> [CmmActual] -- ^ arguments + -> Block CmmNode O O +mkUnsafeCall env ftgt formals args = + save `blockAppend` -- save global registers + bind_args `blockSnoc` -- bind arguments to local registers + 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) + + -- 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 + where + arg_reg :: Unique -> CmmExpr -> CmmReg + arg_reg u expr = CmmLocal $ LocalReg u (cmmExprType (platform env) expr) + + bind_args :: Block CmmNode O O + bind_args = blockConcat $ zipWith (\r e -> BMiddle $ CmmAssign r e) arg_regs args + + call = CmmUnsafeForeignCall ftgt formals (map CmmReg arg_regs) + +saveRestoreCallerRegs :: Platform + -> (Block CmmNode O O, Block CmmNode O O) +saveRestoreCallerRegs platform = + (save, restore) + where + regs = filter (callerSaves platform) (activeStgRegs platform) + + save = blockFromList (map saveReg regs) + saveReg reg = + CmmStore (get_GlobalReg_addr platform reg) + (CmmReg (CmmGlobal reg)) + NaturallyAligned + + restore = blockFromList (map restoreReg regs) + restoreReg reg = + CmmAssign (CmmGlobal reg) + (CmmLoad (get_GlobalReg_addr platform reg) + (globalRegType platform reg) + NaturallyAligned) + +-- | Mirrors __tsan_memory_order +-- +memoryOrderToTsanMemoryOrder :: Env -> MemoryOrdering -> CmmExpr +memoryOrderToTsanMemoryOrder env mord = + mkIntExpr (platform env) n + where + n = case mord of + MemOrderRelaxed -> 0 + MemOrderAcquire -> 2 + MemOrderRelease -> 3 + MemOrderSeqCst -> 5 + +tsanTarget :: FastString -- ^ function name + -> [ForeignHint] -- ^ formals + -> [ForeignHint] -- ^ arguments + -> ForeignTarget +tsanTarget fn formals args = + ForeignTarget (CmmLit (CmmLabel lbl)) conv + where + conv = ForeignConvention CCallConv args formals CmmMayReturn + lbl = mkForeignLabel fn Nothing ForeignLabelInExternalPackage IsFunction + +tsanStore :: Env + -> AlignmentSpec -> CmmType -> CmmExpr + -> Block CmmNode O O +tsanStore env align ty addr = + mkUnsafeCall env ftarget [] [addr] + 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 + +tsanLoad :: Env + -> AlignmentSpec -> CmmType -> CmmExpr + -> Block CmmNode O O +tsanLoad env align ty addr = + mkUnsafeCall env ftarget [] [addr] + where + ftarget = tsanTarget fn [] [AddrHint] + w = widthInBytes (typeWidth ty) + fn = case align of + Unaligned + | w > 1 -> fsLit $ "__tsan_unaligned_read" ++ show w + _ -> fsLit $ "__tsan_read" ++ show w + +tsanAtomicStore :: Env + -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr + -> Block CmmNode O O +tsanAtomicStore env mord w val addr = + mkUnsafeCall env ftarget [] [addr, val, mord'] + where + mord' = memoryOrderToTsanMemoryOrder env mord + ftarget = tsanTarget fn [] [AddrHint, NoHint, NoHint] + fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_store" + +tsanAtomicLoad :: Env + -> MemoryOrdering -> Width -> CmmExpr -> LocalReg + -> Block CmmNode O O +tsanAtomicLoad env mord w addr dest = + mkUnsafeCall env ftarget [dest] [addr, mord'] + where + mord' = memoryOrderToTsanMemoryOrder env mord + ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint] + fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_load" + +tsanAtomicExchange :: Env + -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr -> LocalReg + -> Block CmmNode O O +tsanAtomicExchange env mord w val addr dest = + mkUnsafeCall env ftarget [dest] [addr, val, mord'] + where + mord' = memoryOrderToTsanMemoryOrder env mord + ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint] + fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_exchange" + +-- N.B. C11 CAS returns a boolean (to avoid the ABA problem) whereas Cmm's CAS +-- returns the expected value. We use define a shim in the RTS to provide +-- Cmm's semantics using the TSAN C11 primitive. +tsanAtomicCas :: Env + -> MemoryOrdering -- ^ success ordering + -> MemoryOrdering -- ^ failure ordering + -> Width + -> CmmExpr -- ^ address + -> CmmExpr -- ^ expected value + -> CmmExpr -- ^ new value + -> LocalReg -- ^ result destination + -> Block CmmNode O O +tsanAtomicCas env mord_success mord_failure w addr expected new dest = + mkUnsafeCall env ftarget [dest] [addr, expected, new, mord_success', mord_failure'] + where + mord_success' = memoryOrderToTsanMemoryOrder env mord_success + mord_failure' = memoryOrderToTsanMemoryOrder env mord_failure + ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint, NoHint, NoHint] + fn = fsLit $ "ghc_tsan_atomic" ++ show (widthInBits w) ++ "_compare_exchange" + +tsanAtomicRMW :: Env + -> MemoryOrdering -> AtomicMachOp -> Width -> CmmExpr -> CmmExpr -> LocalReg + -> Block CmmNode O O +tsanAtomicRMW env mord op w addr val dest = + mkUnsafeCall env ftarget [dest] [addr, val, mord'] + where + mord' = memoryOrderToTsanMemoryOrder env mord + ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint] + op' = case op of + AMO_Add -> "fetch_add" + AMO_Sub -> "fetch_sub" + AMO_And -> "fetch_and" + AMO_Nand -> "fetch_nand" + 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 @@ -364,6 +364,14 @@ -- Used to give extra per-argument or per-result -- information needed by foreign calling conventions +instance Outputable ForeignHint where + ppr NoHint = empty + ppr SignedHint = quotes(text "signed") +-- ppr AddrHint = quotes(text "address") +-- Temp Jan08 + ppr AddrHint = (text "PtrHint") + + ------------------------------------------------------------------------- -- These don't really belong here, but I don't know where is best to diff --git a/GHC/Cmm/Utils.hs b/GHC/Cmm/Utils.hs --- a/GHC/Cmm/Utils.hs +++ b/GHC/Cmm/Utils.hs @@ -42,8 +42,6 @@ cmmMkAssign, - isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr, - baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr, currentTSOExpr, currentNurseryExpr, cccsExpr, @@ -61,9 +59,9 @@ modifyGraph, ofBlockMap, toBlockMap, - ofBlockList, toBlockList, bodyToBlockList, + ofBlockList, toBlockList, toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough, - foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1, + foldlGraphBlocks, mapGraphNodes, mapGraphNodes1, -- * Ticks blockTicks @@ -199,9 +197,9 @@ -- | We make a top-level decl for the embedded binary file, and return a label pointing to it mkFileEmbedLit - :: CLabel -> FilePath -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt) -mkFileEmbedLit lbl path - = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path])) + :: CLabel -> FilePath -> Int -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt) +mkFileEmbedLit lbl path len + = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path len])) -- | Build a data-segment data block @@ -401,36 +399,6 @@ --------------------------------------------------- -- --- CmmExpr predicates --- ---------------------------------------------------- - -isTrivialCmmExpr :: CmmExpr -> Bool -isTrivialCmmExpr (CmmLoad _ _ _) = False -isTrivialCmmExpr (CmmMachOp _ _) = False -isTrivialCmmExpr (CmmLit _) = True -isTrivialCmmExpr (CmmReg _) = True -isTrivialCmmExpr (CmmRegOff _ _) = True -isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" - -hasNoGlobalRegs :: CmmExpr -> Bool -hasNoGlobalRegs (CmmLoad e _ _) = hasNoGlobalRegs e -hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es -hasNoGlobalRegs (CmmLit _) = True -hasNoGlobalRegs (CmmReg (CmmLocal _)) = True -hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True -hasNoGlobalRegs _ = False - -isLit :: CmmExpr -> Bool -isLit (CmmLit _) = True -isLit _ = False - -isComparisonExpr :: CmmExpr -> Bool -isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op -isComparisonExpr _ = False - ---------------------------------------------------- --- -- Tagging -- --------------------------------------------------- @@ -526,15 +494,9 @@ modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} -toBlockMap :: CmmGraph -> LabelMap CmmBlock -toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body - ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} -toBlockList :: CmmGraph -> [CmmBlock] -toBlockList g = mapElems $ toBlockMap g - -- | like 'toBlockList', but the entry block always comes first toBlockListEntryFirst :: CmmGraph -> [CmmBlock] toBlockListEntryFirst g @@ -579,9 +541,6 @@ , g_graph = GMany NothingO body NothingO } where body = foldr addBlock emptyBody blocks -bodyToBlockList :: Body CmmNode -> [CmmBlock] -bodyToBlockList body = mapElems body - mapGraphNodes :: ( CmmNode C O -> CmmNode C O , CmmNode O O -> CmmNode O O , CmmNode O C -> CmmNode O C) @@ -596,10 +555,6 @@ foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g - -revPostorder :: CmmGraph -> [CmmBlock] -revPostorder g = {-# SCC "revPostorder" #-} - revPostorderFrom (toBlockMap g) (g_entry g) ------------------------------------------------- -- Tick utilities diff --git a/GHC/CmmToAsm.hs b/GHC/CmmToAsm.hs --- a/GHC/CmmToAsm.hs +++ b/GHC/CmmToAsm.hs @@ -15,8 +15,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | Native code generator -- -- The native-code generator has machine-independent and @@ -78,11 +76,12 @@ ) where -import GHC.Prelude +import GHC.Prelude hiding (head) import qualified GHC.CmmToAsm.X86 as X86 import qualified GHC.CmmToAsm.PPC as PPC import qualified GHC.CmmToAsm.AArch64 as AArch64 +import qualified GHC.CmmToAsm.Wasm as Wasm32 import GHC.CmmToAsm.Reg.Liveness import qualified GHC.CmmToAsm.Reg.Linear as Linear @@ -116,7 +115,6 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block import GHC.Cmm.Opt ( cmmMachOpFold ) -import GHC.Cmm.Ppr import GHC.Cmm.CLabel import GHC.Types.Unique.FM @@ -126,11 +124,9 @@ import GHC.Utils.Misc import GHC.Utils.Logger -import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.BufHandle import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain ( massert ) import GHC.Utils.Error import GHC.Utils.Exception (evaluate) import GHC.Utils.Constants (debugIsOn) @@ -140,18 +136,21 @@ import GHC.Unit import GHC.Data.Stream (Stream) import qualified GHC.Data.Stream as Stream +import GHC.Settings -import Data.List (sortBy, groupBy) +import Data.List (sortBy) +import Data.List.NonEmpty (groupAllWith, head) import Data.Maybe import Data.Ord ( comparing ) import Control.Monad import System.IO +import System.Directory ( getCurrentDirectory ) -------------------- -nativeCodeGen :: forall a . Logger -> NCGConfig -> ModLocation -> Handle -> UniqSupply +nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle -> UniqSupply -> Stream IO RawCmmGroup a -> IO a -nativeCodeGen logger config modLoc h us cmms +nativeCodeGen logger ts config modLoc h us cmms = let platform = ncgPlatform config nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr) => NcgImpl statics instr jumpDest -> IO a @@ -168,8 +167,10 @@ 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" ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript" + ArchWasm32 -> Wasm32.ncgWasm platform ts us modLoc h cmms -- | Data accumulated during code generation. Mostly about statistics, -- but also collects debug data for DWARF generation. @@ -243,16 +244,17 @@ -> UniqSupply -> NativeGenAcc statics instr -> IO UniqSupply -finishNativeGen logger config modLoc bufh@(BufHandle _ _ h) us ngs +finishNativeGen logger config modLoc bufh us ngs = withTimingSilent logger (text "NCG") (`seq` ()) $ do -- Write debug data and finish us' <- if not (ncgDwarfEnabled config) then return us else do - (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs) - emitNativeCode logger config bufh dwarf + 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' - bFlush bufh -- dump global NCG stats for graph coloring allocator let stats = concat (ngs_colorStats ngs) @@ -285,8 +287,9 @@ -- write out the imports let ctx = ncgAsmContext config - printSDocLn ctx Pretty.LeftMode h - $ makeImportsDoc config (concat (ngs_imports ngs)) + bPutHDoc bufh ctx $ makeImportsDoc config (concat (ngs_imports ngs)) + bFlush bufh + return us' where dump_stats = logDumpFile logger (mkDumpStyle alwaysQualify) @@ -333,7 +336,7 @@ dbgMap = debugToMap ndbgs -- Generate native code - (ngs',us') <- cmmNativeGens logger config modLoc ncgImpl h + (ngs',us') <- cmmNativeGens logger config ncgImpl h dbgMap us cmms ngs 0 -- Link native code information into debug blocks @@ -357,7 +360,6 @@ (OutputableP Platform statics, Outputable jumpDest, Instruction instr) => Logger -> NCGConfig - -> ModLocation -> NcgImpl statics instr jumpDest -> BufHandle -> LabelMap DebugBlock @@ -367,7 +369,7 @@ -> Int -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGens logger config modLoc ncgImpl h dbgMap = go +cmmNativeGens logger config ncgImpl h dbgMap = go where go :: UniqSupply -> [RawCmmDecl] -> NativeGenAcc statics instr -> Int @@ -380,7 +382,7 @@ let fileIds = ngs_dwarfFiles ngs (us', fileIds', native, imports, colorStats, linearStats, unwinds) <- {-# SCC "cmmNativeGen" #-} - cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap + cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count -- Generate .file directives for every new file that has been @@ -389,16 +391,21 @@ let newFileIds = sortBy (comparing snd) $ nonDetEltsUFM $ fileIds' `minusUFM` fileIds -- See Note [Unique Determinism and code generation] - pprDecl (f,n) = text "\t.file " <> ppr n <+> - pprFilePathString (unpackFS f) + pprDecl (f,n) = line $ text "\t.file " <> int n <+> + pprFilePathString (unpackFS f) - emitNativeCode logger config h $ vcat $ - map pprDecl newFileIds ++ - map (pprNatCmmDecl ncgImpl) native + -- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad + emitNativeCode logger config h + (vcat $ + map pprDecl newFileIds ++ + map (pprNatCmmDeclH ncgImpl) native) + (vcat $ + map pprDecl newFileIds ++ + map (pprNatCmmDeclS ncgImpl) native) -- force evaluation all this stuff to avoid space leaks let platform = ncgPlatform config - {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pdoc platform) imports) () + {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pprAsmLabel platform) imports) () let !labels' = if ncgDwarfEnabled config then cmmDebugLabels isMetaInstr native else [] @@ -417,11 +424,11 @@ go us' cmms ngs' (count + 1) -emitNativeCode :: Logger -> NCGConfig -> BufHandle -> SDoc -> IO () -emitNativeCode logger config h sdoc = do - +-- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad +emitNativeCode :: Logger -> NCGConfig -> BufHandle -> HDoc -> SDoc -> IO () +emitNativeCode logger config h hdoc sdoc = do let ctx = ncgAsmContext config - {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc + {-# SCC "pprNativeCode" #-} bPutHDoc h ctx hdoc -- dump native code putDumpFileMaybe logger @@ -434,7 +441,6 @@ cmmNativeGen :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest) => Logger - -> ModLocation -> NcgImpl statics instr jumpDest -> UniqSupply -> DwarfFiles @@ -450,14 +456,14 @@ , LabelMap [UnwindPoint] -- unwinding information for blocks ) -cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap cmm count +cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count = do let config = ncgConfig ncgImpl let platform = ncgPlatform config let weights = ncgCfgWeights config let proc_name = case cmm of - (CmmProc _ entry_label _ _) -> pdoc platform entry_label + (CmmProc _ entry_label _ _) -> pprAsmLabel platform entry_label _ -> text "DataChunk" -- rewrite assignments to global regs @@ -480,13 +486,13 @@ -- generate native code from cmm let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) = {-# SCC "genMachCode" #-} - initUs us $ genMachCode config modLoc + initUs us $ genMachCode config (cmmTopCodeGen ncgImpl) fileIds dbgMap opt_cmm cmmCfg putDumpFileMaybe logger Opt_D_dump_asm_native "Native code" FormatASM - (vcat $ map (pprNatCmmDecl ncgImpl) native) + (vcat $ map (pprNatCmmDeclS ncgImpl) native) maybeDumpCfg logger (Just nativeCfgWeights) "CFG Weights - Native" proc_name @@ -543,7 +549,7 @@ putDumpFileMaybe logger Opt_D_dump_asm_regalloc "Registers allocated" FormatCMM - (vcat $ map (pprNatCmmDecl ncgImpl) alloced) + (vcat $ map (pprNatCmmDeclS ncgImpl) alloced) putDumpFileMaybe logger Opt_D_dump_asm_regalloc_stages "Build/spill stages" @@ -587,7 +593,7 @@ putDumpFileMaybe logger Opt_D_dump_asm_regalloc "Registers allocated" FormatCMM - (vcat $ map (pprNatCmmDecl ncgImpl) alloced) + (vcat $ map (pprNatCmmDeclS ncgImpl) alloced) let mPprStats = if logHasDumpFlag logger Opt_D_dump_asm_stats @@ -649,14 +655,13 @@ text "cfg not in lockstep") () ---- sequence blocks - -- sequenced :: [NatCmmDecl statics instr] - let (sequenced, us_seq) = - {-# SCC "sequenceBlocks" #-} - initUs usAlloc $ mapM (BlockLayout.sequenceTop - ncgImpl optimizedCFG) - shorted - - massert (checkLayout shorted sequenced) + let sequenced :: [NatCmmDecl statics instr] + sequenced = + checkLayout shorted $ + {-# SCC "sequenceBlocks" #-} + map (BlockLayout.sequenceTop + ncgImpl optimizedCFG) + shorted let branchOpt :: [NatCmmDecl statics instr] branchOpt = @@ -679,7 +684,7 @@ addUnwind acc proc = acc `mapUnion` computeUnwinding config ncgImpl proc - return ( us_seq + return ( usAlloc , fileIds' , branchOpt , lastMinuteImports ++ imports @@ -699,10 +704,10 @@ -- | Make sure all blocks we want the layout algorithm to place have been placed. checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr] - -> Bool + -> [NatCmmDecl statics instr] checkLayout procsUnsequenced procsSequenced = assertPpr (setNull diff) (text "Block sequencing dropped blocks:" <> ppr diff) - True + procsSequenced where blocks1 = foldl' (setUnion) setEmpty $ map getBlockIds procsUnsequenced :: LabelSet @@ -740,7 +745,7 @@ -- | Build a doc for all the imports. -- -makeImportsDoc :: NCGConfig -> [CLabel] -> SDoc +makeImportsDoc :: NCGConfig -> [CLabel] -> HDoc makeImportsDoc config imports = dyld_stubs imports $$ @@ -748,7 +753,7 @@ -- dead-stripping of code and data on a per-symbol basis. -- There's a hack to make this work in PprMach.pprNatCmmDecl. (if platformHasSubsectionsViaSymbols platform - then text ".subsections_via_symbols" + then line $ text ".subsections_via_symbols" else Outputable.empty) $$ -- On recent GNU ELF systems one can mark an object file @@ -758,14 +763,14 @@ -- security. GHC generated code does not need an executable -- stack so add the note in: (if platformHasGnuNonexecStack platform - then text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits" + then line $ text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits" else Outputable.empty) $$ -- And just because every other compiler does, let's stick in -- an identifier directive: .ident "GHC x.y.z" (if platformHasIdentDirective platform then let compilerIdent = text "GHC" <+> text cProjectVersion - in text ".ident" <+> doubleQuotes compilerIdent + in line $ text ".ident" <+> doubleQuotes compilerIdent else Outputable.empty) where @@ -773,26 +778,23 @@ -- Generate "symbol stubs" for all external symbols that might -- come from a dynamic library. - dyld_stubs :: [CLabel] -> SDoc -{- dyld_stubs imps = vcat $ map pprDyldSymbolStub $ - map head $ group $ sort imps-} + dyld_stubs :: [CLabel] -> HDoc -- (Hack) sometimes two Labels pretty-print the same, but have -- different uniques; so we compare their text versions... dyld_stubs imps | needImportedSymbols config = vcat $ (pprGotDeclaration config :) $ - map ( pprImportedSymbol config . fst . head) $ - groupBy (\(_,a) (_,b) -> a == b) $ - sortBy (\(_,a) (_,b) -> compare a b) $ + fmap (pprImportedSymbol config . fst . head) $ + groupAllWith snd $ map doPpr $ imps | otherwise = Outputable.empty - doPpr lbl = (lbl, renderWithContext + doPpr lbl = (lbl, showSDocOneLine (ncgAsmContext config) - (pprCLabel platform AsmStyle lbl)) + (pprAsmLabel platform lbl)) -- ----------------------------------------------------------------------------- -- Generate jump tables @@ -805,7 +807,7 @@ generateJumpTables ncgImpl xs = concatMap f xs where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs f p = [p] - g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs) + g (BasicBlock _ xs) = mapMaybe (generateJumpTableForInstr ncgImpl) xs -- ----------------------------------------------------------------------------- -- Shortcut branches @@ -920,7 +922,6 @@ genMachCode :: NCGConfig - -> ModLocation -> (RawCmmDecl -> NatM [NatCmmDecl statics instr]) -> DwarfFiles -> LabelMap DebugBlock @@ -933,10 +934,10 @@ , CFG ) -genMachCode config modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg +genMachCode config cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg = do { initial_us <- getUniqueSupplyM ; let initial_st = mkNatM_State initial_us 0 config - modLoc fileIds dbgMap cmm_cfg + 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 diff --git a/GHC/CmmToAsm/AArch64.hs b/GHC/CmmToAsm/AArch64.hs --- a/GHC/CmmToAsm/AArch64.hs +++ b/GHC/CmmToAsm/AArch64.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} --- | Native code generator for x86 and x86-64 architectures +-- | Native code generator for AArch64 architectures module GHC.CmmToAsm.AArch64 ( ncgAArch64 ) where @@ -11,6 +11,7 @@ import GHC.CmmToAsm.Monad import GHC.CmmToAsm.Config import GHC.CmmToAsm.Types +import GHC.Utils.Outputable (ftext) import qualified GHC.CmmToAsm.AArch64.Instr as AArch64 import qualified GHC.CmmToAsm.AArch64.Ppr as AArch64 @@ -28,13 +29,14 @@ ,canShortcut = AArch64.canShortcut ,shortcutStatics = AArch64.shortcutStatics ,shortcutJump = AArch64.shortcutJump - ,pprNatCmmDecl = AArch64.pprNatCmmDecl config + ,pprNatCmmDeclS = AArch64.pprNatCmmDecl config + ,pprNatCmmDeclH = AArch64.pprNatCmmDecl config ,maxSpillSlots = AArch64.maxSpillSlots config ,allocatableRegs = AArch64.allocatableRegs platform ,ncgAllocMoreStack = AArch64.allocMoreStack platform - ,ncgMakeFarBranches = AArch64.makeFarBranches + ,ncgMakeFarBranches = const id ,extractUnwindPoints = const [] - ,invertCondBranches = \_ _ blocks -> blocks + ,invertCondBranches = \_ _ -> id } where platform = ncgPlatform config @@ -55,5 +57,5 @@ mkJumpInstr = AArch64.mkJumpInstr mkStackAllocInstr = AArch64.mkStackAllocInstr mkStackDeallocInstr = AArch64.mkStackDeallocInstr - mkComment = pure . AArch64.COMMENT + mkComment = pure . AArch64.COMMENT . ftext pprInstr = AArch64.pprInstr 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 @@ -3,10 +3,10 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumericUnderscores #-} module GHC.CmmToAsm.AArch64.CodeGen ( cmmTopCodeGen , generateJumpTableForInstr - , makeFarBranches ) where @@ -43,11 +43,9 @@ 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 @@ -62,9 +60,7 @@ import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Monad (mapAccumLM) - -import GHC.Cmm.Dataflow.Collections +import GHC.Utils.Constants (debugIsOn) -- Note [General layout of an NCG] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -140,10 +136,11 @@ id = entryLabel block stmts = blockToList nodes - header_comment_instr = unitOL $ MULTILINE_COMMENT ( + header_comment_instr | debugIsOn = unitOL $ MULTILINE_COMMENT ( text "-- --------------------------- basicBlockCodeGen --------------------------- --\n" - $+$ pdoc (ncgPlatform config) block + $+$ withPprStyle defaultDumpStyle (pdoc (ncgPlatform config) block) ) + | otherwise = nilOL -- Generate location directive dbg <- getDebugBlock (entryLabel block) loc_instrs <- case dblSourceTick =<< dbg of @@ -164,17 +161,15 @@ 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) -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 @@ -184,13 +179,13 @@ -- 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 assmebly we see. By having the verbatim AST printed --- we can simply check the patterns that were matched to arrive at the assmebly +-- 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 labourous and adds +-- 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 @@ -701,16 +696,12 @@ -- 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)))) + | n > 0 && n < 4096 -> 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)))) + | n > 0 && n < 4096 -> 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 @@ -782,12 +773,12 @@ 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) -> + CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (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) -> + CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (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 @@ -919,7 +910,6 @@ intOp True w (\d x y -> toOL [ SDIV t x y, MSUB d t y x ]) -- Unsigned multiply/divide - MO_U_MulMayOflo _w -> unsupportedP plat expr 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 ]) @@ -949,7 +939,7 @@ -- 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 intutive. Don't let yourself be fooled by + -- 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 @@ -971,11 +961,21 @@ -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr) where - unsupportedP :: OutputableP env a => env -> a -> b - unsupportedP platform op = pprPanic "Unsupported op:" (pdoc platform op) - isNbitEncodeable :: Int -> Integer -> Bool isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift) + -- This needs to check if n can be encoded as a bitmask immediate: + -- + -- See https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly + -- + isBitMaskImmediate :: Integer -> Bool + isBitMaskImmediate i = i `elem` [0b0000_0001, 0b0000_0010, 0b0000_0100, 0b0000_1000, 0b0001_0000, 0b0010_0000, 0b0100_0000, 0b1000_0000 + ,0b0000_0011, 0b0000_0110, 0b0000_1100, 0b0001_1000, 0b0011_0000, 0b0110_0000, 0b1100_0000 + ,0b0000_0111, 0b0000_1110, 0b0001_1100, 0b0011_1000, 0b0111_0000, 0b1110_0000 + ,0b0000_1111, 0b0001_1110, 0b0011_1100, 0b0111_1000, 0b1111_0000 + ,0b0001_1111, 0b0011_1110, 0b0111_1100, 0b1111_1000 + ,0b0011_1111, 0b0111_1110, 0b1111_1100 + ,0b0111_1111, 0b1111_1110 + ,0b1111_1111] -- N.B. MUL does not set the overflow flag. do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register @@ -1018,39 +1018,6 @@ CMP (OpReg tmp_w tmp) (OpRegExt tmp_w tmp 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) @@ -1176,7 +1143,6 @@ -- ----------------------------------------------------------------------------- -- Jumps - genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock genJump expr@(CmmLit (CmmLabel lbl)) = return $ unitOL (annExpr expr (J (TLabel lbl))) @@ -1262,23 +1228,7 @@ _ -> 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 @@ -1582,9 +1532,34 @@ 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_AtomicRead w _ -> mkCCall (atomicReadLabel w) - MO_AtomicWrite w _ -> mkCCall (atomicWriteLabel w) MO_Cmpxchg w -> mkCCall (cmpxchgLabel w) -- -- Should be an AtomicRMW variant eventually. -- -- Sequential consistent. @@ -1604,7 +1579,7 @@ genCCall (ForeignTarget target cconv) dest_regs arg_regs bid -- TODO: Optimize using paired stores and loads (STP, LDP). It is - -- automomatically done by the allocator for us. However it's not optimal, + -- 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]! @@ -1768,163 +1743,3 @@ 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 - massertPpr (null no_data) $ text "There should be no data in the instruction stream" - - 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') - BCOND cond t - -> case target_in_range m t pos of - InRange -> pure (pos+long_bc_jump_size,[instr]) - NotInRange far_target -> do - jmp_code <- genCondFarJump cond far_target - pure (pos+long_bc_jump_size, fromOL jmp_code) - CBZ op t -> long_zero_jump op t EQ - CBNZ op t -> long_zero_jump op t NE - instr - | isMetaInstr instr -> pure (pos,[instr]) - | otherwise -> pure (pos+1, [instr]) - - where - -- cmp_op: EQ = CBZ, NEQ = CBNZ - long_zero_jump op t cmp_op = - case target_in_range m t pos of - InRange -> pure (pos+long_bz_jump_size,[instr]) - NotInRange far_target -> do - jmp_code <- genCondFarJump cmp_op far_target - -- TODO: Fix zero reg so we can use it here - pure (pos + long_bz_jump_size, CMP op (OpImm (ImmInt 0)) : fromOL jmp_code) - - - 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 - -- Maybe we should be pessimistic here, for now just fixing intra proc jumps - -> 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 (TBlock dest_lbl) - Just dest_pos -> if abs (dest_pos - src_pos) < max_jump_dist - then InRange - else NotInRange (TBlock 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 = - case instr of - ANN _ann instr -> instr_pos (pos, m) instr - NEWBLOCK _bid -> panic "mkFarBranched - unexpected NEWBLOCK" -- At this point there should be no NEWBLOCK - -- in the instruction stream - -- (pos, mapInsert bid pos m) - COMMENT{} -> (pos, m) - instr - | Just jump_size <- is_expandable_jump instr -> (pos+jump_size, m) - | otherwise -> (pos+1, m) - - infoTblSize_maybe bid = - case mapLookup bid statics of - Nothing -> 0 :: Int - Just _info_static -> max_info_size - - -- These jumps have a 19bit immediate as offset which is quite - -- limiting so we potentially have to expand them into - -- multiple instructions. - is_expandable_jump i = case i of - CBZ{} -> Just long_bz_jump_size - CBNZ{} -> Just long_bz_jump_size - BCOND{} -> Just long_bc_jump_size - _ -> Nothing diff --git a/GHC/CmmToAsm/AArch64/Cond.hs b/GHC/CmmToAsm/AArch64/Cond.hs --- a/GHC/CmmToAsm/AArch64/Cond.hs +++ b/GHC/CmmToAsm/AArch64/Cond.hs @@ -1,6 +1,6 @@ module GHC.CmmToAsm.AArch64.Cond where -import GHC.Prelude hiding (EQ) +import GHC.Prelude -- https://developer.arm.com/documentation/den0024/a/the-a64-instruction-set/data-processing-instructions/conditional-instructions @@ -60,13 +60,7 @@ | UOGE -- b.pl | UOGT -- b.hi -- others - -- NEVER -- b.nv - -- I removed never. According to the ARM spec: - -- > The Condition code NV exists only to provide a valid disassembly of - -- > the 0b1111 encoding, otherwise its behavior is identical to AL. - -- This can only lead to disaster. Better to not have it than someone - -- using it assuming it actually means never. - + | NEVER -- b.nv | VS -- oVerflow set | VC -- oVerflow clear deriving Eq 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 @@ -128,7 +128,9 @@ CBNZ src _ -> usage (regOp src, []) -- 7. Load and Store Instructions -------------------------------------------- STR _ src dst -> usage (regOp src ++ regOp dst, []) + 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) @@ -265,7 +267,9 @@ CBNZ o l -> CBNZ (patchOp o) l -- 7. Load and Store Instructions ------------------------------------------ STR f o1 o2 -> STR f (patchOp o1) (patchOp o2) + 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) @@ -348,8 +352,8 @@ -- -- Using sp to compute the offset will 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 poitner --- always poitns to the top of the stack, and we can't use it for computation. +-- 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. -- -- | An instruction to spill a register into a spill slot. mkSpillInstr @@ -551,7 +555,7 @@ | PUSH_STACK_FRAME | POP_STACK_FRAME -- 1. Arithmetic Instructions ---------------------------------------------- - -- | ADC Operand Operand Operang -- rd = rn + rm + C + -- | ADC Operand Operand Operand -- rd = rn + rm + C -- | ADCS ... | ADD Operand Operand Operand -- rd = rn + rm -- | ADDS Operand Operand Operand -- rd = rn + rm @@ -618,7 +622,9 @@ -- 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) @@ -693,7 +699,9 @@ ROR{} -> "ROR" TST{} -> "TST" STR{} -> "STR" + STLR{} -> "STLR" LDR{} -> "LDR" + LDAR{} -> "LDAR" STP{} -> "STP" LDP{} -> "LDP" CSET{} -> "CSET" @@ -713,7 +721,6 @@ = TBlock BlockId | TLabel CLabel | TReg Reg - deriving (Eq, Ord) -- Extension 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,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-} -module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr, pprBasicBlock) where +module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr) where import GHC.Prelude hiding (EQ) @@ -22,7 +22,6 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform @@ -30,12 +29,12 @@ import GHC.Utils.Panic -pprProcAlignment :: NCGConfig -> SDoc +pprProcAlignment :: IsDoc doc => NCGConfig -> doc pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config) where platform = ncgPlatform config -pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc +pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc pprNatCmmDecl config (CmmData section dats) = pprSectionAlign config section $$ pprDatas config dats @@ -51,45 +50,45 @@ pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock config top_info) blocks) $$ (if ncgDwarfEnabled config - then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ + then line (pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':') else empty) $$ pprSizeDecl platform lbl Just (CmmStaticsRaw info_lbl _) -> pprSectionAlign config (Section Text info_lbl) $$ -- pprProcAlignment config $$ (if platformHasSubsectionsViaSymbols platform - then ppr (mkDeadStripPreventer info_lbl) <> char ':' + then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':') else empty) $$ vcat (map (pprBasicBlock config 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 then -- See Note [Subsections Via Symbols] - text "\t.long " - <+> ppr info_lbl + line + $ text "\t.long " + <+> pprAsmLabel platform info_lbl <+> char '-' - <+> ppr (mkDeadStripPreventer info_lbl) + <+> 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 :: Platform -> CLabel -> SDoc +pprLabel :: IsDoc doc => Platform -> CLabel -> doc pprLabel platform lbl = pprGloblDecl platform lbl $$ pprTypeDecl platform lbl - $$ (pdoc platform lbl <> char ':') + $$ line (pprAsmLabel platform lbl <> char ':') -pprAlign :: Platform -> Alignment -> SDoc +pprAlign :: IsDoc doc => Platform -> Alignment -> doc pprAlign _platform alignment - = text "\t.balign " <> int (alignmentBytes alignment) + = line $ text "\t.balign " <> int (alignmentBytes alignment) -- | Print appropriate alignment for the given section type. -pprAlignForSection :: Platform -> SectionType -> SDoc +pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc pprAlignForSection _platform _seg -- .balign is stable, whereas .align is platform dependent. - = text "\t.balign 8" -- always 8 - -instance Outputable Instr where - ppr = pprInstr genericPlatform + = line (text "\t.balign 8") -- always 8 -- | Print section header and appropriate alignment for that section. -- @@ -98,28 +97,28 @@ -- .section .text -- .balign 8 -- -pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign _config (Section (OtherSection _) _) = panic "AArch64.Ppr.pprSectionAlign: unknown section" pprSectionAlign config sec@(Section seg _) = - pprSectionHeader config sec + line (pprSectionHeader config sec) $$ pprAlignForSection (ncgPlatform config) seg -- | Output the ELF .size directive. -pprSizeDecl :: Platform -> CLabel -> SDoc +pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc pprSizeDecl platform lbl = if osElfTarget (platformOS platform) - then text "\t.size" <+> pdoc platform lbl <> text ", .-" <> pdoc platform lbl + then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl) else empty -pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr - -> SDoc +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)) $$ (if ncgDwarfEnabled config - then ppr (mkAsmTempEndLabel asmLbl) <> char ':' + then line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':') else empty ) where @@ -139,7 +138,7 @@ pprLabel platform info_lbl $$ c $$ (if ncgDwarfEnabled config - then ppr (mkAsmTempEndLabel info_lbl) <> char ':' + then line (pprAsmLabel platform (mkAsmTempEndLabel info_lbl) <> char ':') else empty) -- Make sure the info table has the right .loc for the block -- coming right after it. See Note [Info Offset] @@ -147,7 +146,7 @@ (l@LOCATION{} : _) -> pprInstr platform l _other -> empty -pprDatas :: NCGConfig -> RawCmmStatics -> SDoc +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 @@ -157,41 +156,41 @@ , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' = pprGloblDecl (ncgPlatform config) alias - $$ text ".equiv" <+> pdoc (ncgPlatform config) alias <> comma <> pdoc (ncgPlatform config) (CmmLabel ind') + $$ 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 :: NCGConfig -> CmmStatic -> SDoc -pprData _config (CmmString str) = pprString str -pprData _config (CmmFileEmbed path) = pprFileEmbed path +pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc +pprData _config (CmmString str) = line (pprString str) +pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path) pprData config (CmmUninitialised bytes) - = let platform = ncgPlatform config - in if platformOS platform == OSDarwin - then text ".space " <> int bytes - else text ".skip " <> int 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 :: Platform -> CLabel -> SDoc +pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = text "\t.globl " <> pdoc platform lbl + | 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 migth want to lookup the +-- 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' :: Platform -> CLabel -> SDoc +pprLabelType' :: IsLine doc => Platform -> CLabel -> doc pprLabelType' platform lbl = if isCFunctionLabel lbl || functionOkInfoTable then text "@function" @@ -199,18 +198,18 @@ text "@object" where functionOkInfoTable = platformTablesNextToCode platform && - isInfoTableLabel lbl && not (isConInfoTableLabel lbl) + isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl) -- this is called pprTypeAndSizeDecl in PPC.Ppr -pprTypeDecl :: Platform -> CLabel -> SDoc +pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc pprTypeDecl platform lbl = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl - then text ".type " <> pdoc platform lbl <> text ", " <> pprLabelType' platform lbl + then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl) else empty -pprDataItem :: NCGConfig -> CmmLit -> SDoc +pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc pprDataItem config lit - = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) where platform = ncgPlatform config @@ -231,12 +230,12 @@ ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit) -pprImm :: Platform -> Imm -> SDoc +pprImm :: IsLine doc => Platform -> Imm -> doc pprImm _ (ImmInt i) = int i pprImm _ (ImmInteger i) = integer i -pprImm p (ImmCLbl l) = pdoc p l -pprImm p (ImmIndex l i) = pdoc p l <> char '+' <> int i -pprImm _ (ImmLit s) = s +pprImm p (ImmCLbl l) = pprAsmLabel p l +pprImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i +pprImm _ (ImmLit s) = ftext s -- TODO: See pprIm below for why this is a bad idea! pprImm _ (ImmFloat f) @@ -261,13 +260,13 @@ asmMultilineComment :: SDoc -> SDoc asmMultilineComment c = whenPprDebug $ text "/*" $+$ c $+$ text "*/" -pprIm :: Platform -> Imm -> SDoc +pprIm :: IsLine doc => Platform -> Imm -> doc pprIm platform im = case im of ImmInt i -> char '#' <> int i ImmInteger i -> char '#' <> integer i -- TODO: This will only work for - -- The floating point value must be expressable as ±n ÷ 16 × 2^r, + -- The floating point value must be expressible as ±n ÷ 16 × 2^r, -- where n and r are integers such that 16 ≤ n ≤ 31 and -3 ≤ r ≤ 4. -- and 0 needs to be encoded as wzr/xzr. -- @@ -277,17 +276,17 @@ -- This is something the x86 backend does. -- -- We could also just turn them into statics :-/ Which is what the - -- PowerPC backend odes. + -- PowerPC backend does. ImmFloat f | f == 0 -> text "wzr" ImmFloat f -> char '#' <> float (fromRational f) ImmDouble d | d == 0 -> text "xzr" ImmDouble d -> char '#' <> double (fromRational d) -- = pseudo instruction! - ImmCLbl l -> char '=' <> pdoc platform l - ImmIndex l o -> text "[=" <> pdoc platform l <> comma <+> char '#' <> int o <> char ']' + ImmCLbl l -> char '=' <> pprAsmLabel platform l + ImmIndex l o -> text "[=" <> pprAsmLabel platform l <> comma <+> char '#' <> int o <> char ']' _ -> panic "AArch64.pprIm" -pprExt :: ExtMode -> SDoc +pprExt :: IsLine doc => ExtMode -> doc pprExt EUXTB = text "uxtb" pprExt EUXTH = text "uxth" pprExt EUXTW = text "uxtw" @@ -297,13 +296,13 @@ pprExt ESXTW = text "sxtw" pprExt ESXTX = text "sxtx" -pprShift :: ShiftMode -> SDoc +pprShift :: IsLine doc => ShiftMode -> doc pprShift SLSL = text "lsl" pprShift SLSR = text "lsr" pprShift SASR = text "asr" pprShift SROR = text "ror" -pprOp :: Platform -> Operand -> SDoc +pprOp :: IsLine doc => Platform -> Operand -> doc pprOp plat op = case op of OpReg w r -> pprReg w r OpRegExt w r x 0 -> pprReg w r <> comma <+> pprExt x @@ -311,12 +310,12 @@ OpRegShift w r s i -> pprReg w r <> comma <+> pprShift s <+> char '#' <> int i OpImm im -> pprIm plat im OpImmShift im s i -> pprIm plat im <> comma <+> pprShift s <+> char '#' <> int i - -- TODO: Address compuation always use registers as 64bit -- is this correct? + -- TODO: Address computation always use registers as 64bit -- is this correct? OpAddr (AddrRegReg r1 r2) -> char '[' <+> pprReg W64 r1 <> comma <+> pprReg W64 r2 <+> char ']' OpAddr (AddrRegImm r1 im) -> char '[' <+> pprReg W64 r1 <> comma <+> pprImm plat im <+> char ']' OpAddr (AddrReg r1) -> char '[' <+> pprReg W64 r1 <+> char ']' -pprReg :: Width -> Reg -> SDoc +pprReg :: forall doc. IsLine doc => Width -> Reg -> doc pprReg w r = case r of RegReal (RealRegSingle i) -> ppr_reg_no w i -- virtual regs should not show up, but this is helpful for debugging. @@ -326,7 +325,7 @@ _ -> pprPanic "AArch64.pprReg" (text $ show r) where - ppr_reg_no :: Width -> Int -> SDoc + ppr_reg_no :: Width -> Int -> doc ppr_reg_no w 31 | w == W64 = text "sp" | w == W32 = text "wsp" @@ -355,110 +354,110 @@ isFloatOp (OpReg _ (RegVirtual (VirtualRegD _))) = True isFloatOp _ = False -pprInstr :: Platform -> Instr -> SDoc +pprInstr :: IsDoc doc => Platform -> Instr -> doc pprInstr platform instr = case instr of -- Meta Instructions --------------------------------------------------------- - COMMENT s -> asmComment s - MULTILINE_COMMENT s -> asmMultilineComment s - ANN d i -> pprInstr platform i <+> asmDoubleslashComment d - LOCATION file line col _name - -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col - DELTA d -> asmComment $ text ("\tdelta = " ++ show d) - NEWBLOCK blockid -> -- This is invalid assembly. But NEWBLOCK should never be contained - -- in the final instruction stream. But we still want to be able to - -- print it for debugging purposes. - text "BLOCK " <> pprLabel platform (blockLbl blockid) + -- 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 + -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable + NEWBLOCK _ -> panic "PprInstr: NEWBLOCK" LDATA _ _ -> panic "pprInstr: LDATA" -- Pseudo Instructions ------------------------------------------------------- - PUSH_STACK_FRAME -> text "\tstp x29, x30, [sp, #-16]!" - $$ text "\tmov x29, sp" + PUSH_STACK_FRAME -> lines_ [text "\tstp x29, x30, [sp, #-16]!", + text "\tmov x29, sp"] - POP_STACK_FRAME -> text "\tldp x29, x30, [sp], #16" + POP_STACK_FRAME -> line $ text "\tldp x29, x30, [sp], #16" -- =========================================================================== -- AArch64 Instruction Set -- 1. Arithmetic Instructions ------------------------------------------------ ADD o1 o2 o3 - | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> text "\tfadd" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - | otherwise -> text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - CMN o1 o2 -> text "\tcmn" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + | 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 -> text "\tfcmp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - | otherwise -> text "\tcmp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - MSUB o1 o2 o3 o4 -> text "\tmsub" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 + | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfcmp") o1 o2 + | otherwise -> op2 (text "\tcmp") o1 o2 + MSUB o1 o2 o3 o4 -> op4 (text "\tmsub") o1 o2 o3 o4 MUL o1 o2 o3 - | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> text "\tfmul" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - | otherwise -> text "\tmul" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - SMULH o1 o2 o3 -> text "\tsmulh" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - SMULL o1 o2 o3 -> text "\tsmull" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform 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 NEG o1 o2 - | isFloatOp o1 && isFloatOp o2 -> text "\tfneg" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - | otherwise -> text "\tneg" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfneg") o1 o2 + | otherwise -> op2 (text "\tneg") o1 o2 SDIV o1 o2 o3 | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 - -> text "\tfdiv" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - SDIV o1 o2 o3 -> text "\tsdiv" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + -> op3 (text "\tfdiv") o1 o2 o3 + SDIV o1 o2 o3 -> op3 (text "\tsdiv") o1 o2 o3 SUB o1 o2 o3 - | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> text "\tfsub" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - | otherwise -> text "\tsub" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - UDIV o1 o2 o3 -> text "\tudiv" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfsub") o1 o2 o3 + | otherwise -> op3 (text "\tsub") o1 o2 o3 + UDIV o1 o2 o3 -> op3 (text "\tudiv") o1 o2 o3 -- 2. Bit Manipulation Instructions ------------------------------------------ - SBFM o1 o2 o3 o4 -> text "\tsbfm" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 - UBFM o1 o2 o3 o4 -> text "\tubfm" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 + SBFM o1 o2 o3 o4 -> op4 (text "\tsbfm") o1 o2 o3 o4 + UBFM o1 o2 o3 o4 -> op4 (text "\tubfm") o1 o2 o3 o4 -- signed and unsigned bitfield extract - SBFX o1 o2 o3 o4 -> text "\tsbfx" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 - UBFX o1 o2 o3 o4 -> text "\tubfx" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 - SXTB o1 o2 -> text "\tsxtb" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - UXTB o1 o2 -> text "\tuxtb" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - SXTH o1 o2 -> text "\tsxth" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - UXTH o1 o2 -> text "\tuxth" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + SBFX o1 o2 o3 o4 -> op4 (text "\tsbfx") o1 o2 o3 o4 + UBFX o1 o2 o3 o4 -> op4 (text "\tubfx") o1 o2 o3 o4 + SXTB o1 o2 -> op2 (text "\tsxtb") o1 o2 + UXTB o1 o2 -> op2 (text "\tuxtb") o1 o2 + SXTH o1 o2 -> op2 (text "\tsxth") o1 o2 + UXTH o1 o2 -> op2 (text "\tuxth") o1 o2 -- 3. Logical and Move Instructions ------------------------------------------ - AND o1 o2 o3 -> text "\tand" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - ANDS o1 o2 o3 -> text "\tands" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - ASR o1 o2 o3 -> text "\tasr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - BIC o1 o2 o3 -> text "\tbic" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - BICS o1 o2 o3 -> text "\tbics" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - EON o1 o2 o3 -> text "\teon" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - EOR o1 o2 o3 -> text "\teor" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - LSL o1 o2 o3 -> text "\tlsl" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - LSR o1 o2 o3 -> text "\tlsr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + 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 MOV o1 o2 - | isFloatOp o1 || isFloatOp o2 -> text "\tfmov" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - | otherwise -> text "\tmov" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - MOVK o1 o2 -> text "\tmovk" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - MVN o1 o2 -> text "\tmvn" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - ORN o1 o2 o3 -> text "\torn" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - ORR o1 o2 o3 -> text "\torr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - ROR o1 o2 o3 -> text "\tror" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - TST o1 o2 -> text "\ttst" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + | isFloatOp o1 || isFloatOp o2 -> op2 (text "\tfmov") o1 o2 + | otherwise -> op2 (text "\tmov") o1 o2 + MOVK o1 o2 -> op2 (text "\tmovk") 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) - B (TBlock bid) -> text "\tb" <+> pdoc platform (mkLocalBlockLabel (getUnique bid)) - B (TLabel lbl) -> text "\tb" <+> pdoc platform lbl - B (TReg r) -> text "\tbr" <+> pprReg W64 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) _ _ -> text "\tbl" <+> pdoc platform (mkLocalBlockLabel (getUnique bid)) - BL (TLabel lbl) _ _ -> text "\tbl" <+> pdoc platform lbl - BL (TReg r) _ _ -> 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) -> text "\t" <> pprBcond c <+> pdoc platform (mkLocalBlockLabel (getUnique bid)) - BCOND c (TLabel lbl) -> text "\t" <> pprBcond c <+> pdoc platform lbl + 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 BCOND _ (TReg _) -> panic "AArch64.ppr: No conditional branching to registers!" -- 5. Atomic Instructions ---------------------------------------------------- -- 6. Conditional Instructions ----------------------------------------------- - CSET o c -> text "\tcset" <+> pprOp platform o <> comma <+> pprCond c + CSET o c -> line $ text "\tcset" <+> pprOp platform o <> comma <+> pprCond c - CBZ o (TBlock bid) -> text "\tcbz" <+> pprOp platform o <> comma <+> pdoc platform (mkLocalBlockLabel (getUnique bid)) - CBZ o (TLabel lbl) -> text "\tcbz" <+> pprOp platform o <> comma <+> pdoc platform lbl + CBZ o (TBlock bid) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + CBZ o (TLabel lbl) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl CBZ _ (TReg _) -> panic "AArch64.ppr: No conditional (cbz) branching to registers!" - CBNZ o (TBlock bid) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pdoc platform (mkLocalBlockLabel (getUnique bid)) - CBNZ o (TLabel lbl) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pdoc platform lbl + CBNZ o (TBlock bid) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid)) + CBNZ o (TLabel lbl) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl CBNZ _ (TReg _) -> panic "AArch64.ppr: No conditional (cbnz) branching to registers!" -- 7. Load and Store Instructions -------------------------------------------- @@ -466,88 +465,98 @@ -- address. Not observing the correct size when loading will lead -- inevitably to crashes. STR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 -> - text "\tstrb" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + op2 (text "\tstrb") o1 o2 STR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 -> - text "\tstrh" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - STR _f o1 o2 -> text "\tstr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + op2 (text "\tstrh") o1 o2 + 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' -> - text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$ - text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" $$ - text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits. + 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 -> - text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$ - text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" $$ - text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits. + 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)) -> - text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@page" $$ - text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@pageoff" $$ - text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits. + 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' -> - text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$ - text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" + op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$ + op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff") LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl -> - text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$ - text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" + op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$ + op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff") LDR _f o1 (OpImm (ImmCLbl lbl)) -> - text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@page" $$ - text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@pageoff" + 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' -> - text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$ - text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" $$ - text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits. + 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. LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl -> - text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$ - text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" $$ - text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits. + 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. LDR _f o1 (OpImm (ImmIndex lbl off)) -> - text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl $$ - text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text ":lo12:" <> pdoc platform lbl $$ - text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits. + 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. LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' -> - text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$ - text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" + op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$ + op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl) LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl -> - text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$ - text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" + op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$ + op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl) LDR _f o1 (OpImm (ImmCLbl lbl)) -> - text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl $$ - text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text ":lo12:" <> pdoc platform lbl + op_adrp o1 (pprAsmLabel platform lbl) $$ + op_add o1 (text ":lo12:" <> pprAsmLabel platform lbl) + #endif LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 -> - text "\tldrb" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + op2 (text "\tldrb") o1 o2 LDR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 -> - text "\tldrh" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - LDR _f o1 o2 -> text "\tldr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 + op2 (text "\tldrh") o1 o2 + LDR _f o1 o2 -> op2 (text "\tldr") o1 o2 + LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2 - STP _f o1 o2 o3 -> text "\tstp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 - LDP _f o1 o2 o3 -> text "\tldp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 + 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 -> text "\tdmb sy" + DMBSY -> line $ text "\tdmb sy" -- 9. Floating Point Instructions -------------------------------------------- - FCVT o1 o2 -> text "\tfcvt" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - SCVTF o1 o2 -> text "\tscvtf" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - FCVTZS o1 o2 -> text "\tfcvtzs" <+> pprOp platform o1 <> comma <+> pprOp platform o2 - FABS o1 o2 -> text "\tfabs" <+> pprOp platform o1 <> comma <+> pprOp platform 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 + 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 -pprBcond :: Cond -> SDoc +pprBcond :: IsLine doc => Cond -> doc pprBcond c = text "b." <> pprCond c -pprCond :: Cond -> SDoc +pprCond :: IsLine doc => Cond -> doc pprCond c = case c of ALWAYS -> text "al" -- Always EQ -> text "eq" -- Equal @@ -563,11 +572,11 @@ UGE -> text "hs" -- Carry set/unsigned higher or same ; Greater than or equal, or unordered UGT -> text "hi" -- Unsigned higher ; Greater than, or unordered - -- NEVER -> text "nv" -- Never + NEVER -> text "nv" -- Never VS -> text "vs" -- Overflow ; Unordered (at least one NaN operand) VC -> text "vc" -- No overflow ; Not unordered - -- Orderd variants. Respecting NaN. + -- Ordered variants. Respecting NaN. OLT -> text "mi" OLE -> text "ls" OGE -> text "ge" 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 @@ -2,6 +2,7 @@ module GHC.CmmToAsm.AArch64.Regs where import GHC.Prelude +import GHC.Data.FastString import GHC.Platform.Reg import GHC.Platform.Reg.Class @@ -59,7 +60,7 @@ = ImmInt Int | ImmInteger Integer -- Sigh. | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLit SDoc -- Simple string + | ImmLit FastString | ImmIndex CLabel Int | ImmFloat Rational | ImmDouble Rational @@ -67,14 +68,8 @@ | ImmConstantDiff Imm Imm deriving (Eq, Show) -instance Show SDoc where - show = showPprUnsafe . ppr - -instance Eq SDoc where - lhs == rhs = show lhs == show rhs - -strImmLit :: String -> Imm -strImmLit s = ImmLit (text s) +strImmLit :: FastString -> Imm +strImmLit s = ImmLit s litToImm :: CmmLit -> Imm diff --git a/GHC/CmmToAsm/BlockLayout.hs b/GHC/CmmToAsm/BlockLayout.hs --- a/GHC/CmmToAsm/BlockLayout.hs +++ b/GHC/CmmToAsm/BlockLayout.hs @@ -13,7 +13,7 @@ ( sequenceTop, backendMaintainsCfg) where -import GHC.Prelude +import GHC.Prelude hiding (head, init, last, tail) import GHC.Platform @@ -35,20 +35,21 @@ import GHC.Data.List.SetOps (removeDups) import GHC.Data.OrdList -import GHC.Utils.Trace 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) import qualified Data.Set as Set import Data.STRef import Control.Monad.ST.Strict import Control.Monad (foldM, unless) import GHC.Data.UnionFind -import GHC.Types.Unique.Supply (UniqSM) {- Note [CFG based code layout] @@ -355,7 +356,7 @@ breakChainAt :: BlockId -> BlockChain -> (BlockChain,BlockChain) breakChainAt bid (BlockChain blks) - | not (bid == head rblks) + | not (bid == Partial.head rblks) = panic "Block not in chain" | otherwise = (BlockChain (toOL lblks), @@ -494,7 +495,7 @@ merge :: forall s. [CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain merge [] chains = do chains' <- mapM find =<< (nub <$> (mapM repr $ mapElems chains)) :: ST s [BlockChain] - return $ foldl' chainConcat (head chains') (tail chains') + return $ foldl' chainConcat (Partial.head chains') (Partial.tail chains') merge ((CfgEdge from to _):edges) chains -- | pprTrace "merge" (ppr (from,to) <> ppr chains) False -- = undefined @@ -594,8 +595,8 @@ toChain <- readSTRef toRef let newChain = chainConcat fromChain toChain ref <- newSTRef newChain - let start = head $ takeL 1 newChain - let end = head $ takeR 1 newChain + let start = Partial.head $ takeL 1 newChain + let end = Partial.head $ takeR 1 newChain -- chains <- sequence $ mapMap readSTRef chainStarts -- pprTraceM "pre-fuse chains:" $ ppr chains buildNext @@ -656,7 +657,7 @@ sequenceChain _info _weights [x] = [x] sequenceChain info weights blocks@((BasicBlock entry _):_) = let directEdges :: [CfgEdge] - directEdges = sortBy (flip compare) $ catMaybes . map relevantWeight $ (infoEdgeList weights) + directEdges = sortBy (flip compare) $ mapMaybe relevantWeight (infoEdgeList weights) where -- Apply modifiers to turn edge frequencies into useable weights -- for computing code layout. @@ -759,7 +760,7 @@ -- builds if something slips through. assert (null unplaced) $ --pprTraceIt "placedBlocks" $ - -- ++ [] is stil kinda expensive + -- ++ [] is still kinda expensive if null unplaced then blockList else blockList ++ unplaced getBlock bid = expectJust "Block placement" $ mapLookup bid blockMap in @@ -773,13 +774,13 @@ dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i] dropJumps _ [] = [] -dropJumps info ((BasicBlock lbl ins):todo) - | not . null $ ins --This can happen because of shortcutting - , [dest] <- jumpDestsOfInstr (last ins) - , ((BasicBlock nextLbl _) : _) <- todo +dropJumps info (BasicBlock lbl ins:todo) + | Just ins <- nonEmpty ins --This can happen because of shortcutting + , [dest] <- jumpDestsOfInstr (NE.last ins) + , BasicBlock nextLbl _ : _ <- todo , not (mapMember dest info) , nextLbl == dest - = BasicBlock lbl (init ins) : dropJumps info todo + = BasicBlock lbl (NE.init ins) : dropJumps info todo | otherwise = BasicBlock lbl ins : dropJumps info todo @@ -798,32 +799,29 @@ => NcgImpl statics instr jumpDest -> Maybe CFG -- ^ CFG if we have one. -> NatCmmDecl statics instr -- ^ Function to serialize - -> UniqSM (NatCmmDecl statics instr) - -sequenceTop _ _ top@(CmmData _ _) = pure top -sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks)) = do - let config = ncgConfig ncgImpl - platform = ncgPlatform config - - seq_blocks = - if -- Chain based algorithm - | ncgCfgBlockLayout config - , backendMaintainsCfg platform - , Just cfg <- edgeWeights - -> {-# SCC layoutBlocks #-} sequenceChain info cfg blocks + -> NatCmmDecl statics instr - -- Old algorithm without edge weights - | ncgCfgWeightlessLayout config - || not (backendMaintainsCfg platform) - -> {-# SCC layoutBlocks #-} sequenceBlocks Nothing info blocks +sequenceTop _ _ top@(CmmData _ _) = top +sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks)) + = let + config = ncgConfig ncgImpl + platform = ncgPlatform config - -- Old algorithm with edge weights (if any) - | otherwise - -> {-# SCC layoutBlocks #-} sequenceBlocks edgeWeights info blocks + in CmmProc info lbl live $ ListGraph $ ncgMakeFarBranches ncgImpl info $ + if -- Chain based algorithm + | ncgCfgBlockLayout config + , backendMaintainsCfg platform + , Just cfg <- edgeWeights + -> {-# SCC layoutBlocks #-} sequenceChain info cfg blocks - far_blocks <- (ncgMakeFarBranches ncgImpl) platform info seq_blocks - pure $ CmmProc info lbl live $ ListGraph far_blocks + -- Old algorithm without edge weights + | ncgCfgWeightlessLayout config + || not (backendMaintainsCfg platform) + -> {-# SCC layoutBlocks #-} sequenceBlocks Nothing info blocks + -- Old algorithm with edge weights (if any) + | otherwise + -> {-# SCC layoutBlocks #-} sequenceBlocks edgeWeights info blocks -- The old algorithm: -- It is very simple (and stupid): We make a graph out of @@ -873,10 +871,10 @@ ((target,info):_) | length successors > 2 || edgeWeight info <= 0 -> [] | otherwise -> [target] - | otherwise - = case jumpDestsOfInstr (last instrs) of - [one] -> [one] - _many -> [] + | Just instr <- lastMaybe instrs + , [one] <- jumpDestsOfInstr instr + = [one] + | otherwise = [] seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)] diff --git a/GHC/CmmToAsm/CFG.hs b/GHC/CmmToAsm/CFG.hs --- a/GHC/CmmToAsm/CFG.hs +++ b/GHC/CmmToAsm/CFG.hs @@ -47,7 +47,6 @@ import GHC.Cmm.BlockId import GHC.Cmm as Cmm -import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label @@ -78,7 +77,6 @@ --import GHC.Cmm.DebugBlock --import GHC.Data.OrdList --import GHC.Cmm.DebugBlock.Trace -import GHC.Cmm.Ppr () -- For Outputable instances import Data.List (sort, nub, partition) import Data.STRef.Strict @@ -221,7 +219,7 @@ -- | Check if the nodes in the cfg and the set of blocks are the same. --- In a case of a missmatch we panic and show the difference. +-- In a case of a mismatch we panic and show the difference. sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool sanityCheckCfg m blockSet msg | blockSet == cfgNodes @@ -309,7 +307,7 @@ -- Create a unification variable for each of the nodes in a rewrite 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 the the rewrites in the cuts map + -- 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 -- Then recover the unique representative, which is the result of following @@ -387,10 +385,7 @@ delEdge :: BlockId -> BlockId -> CFG -> CFG delEdge from to m = - mapAlter remDest from m - where - remDest Nothing = Nothing - remDest (Just wm) = Just $ mapDelete to wm + mapAdjust (mapDelete to) from m -- | Destinations from bid ordered by weight (descending) @@ -419,11 +414,11 @@ getEdgeWeight :: CFG -> BlockId -> BlockId -> EdgeWeight getEdgeWeight cfg from to = - edgeWeight $ expectJust "Edgeweight for noexisting block" $ + edgeWeight $ expectJust "Edgeweight for nonexisting block" $ getEdgeInfo from to cfg getTransitionSource :: BlockId -> BlockId -> CFG -> TransitionSource -getTransitionSource from to cfg = transitionSource $ expectJust "Source info for noexisting block" $ +getTransitionSource from to cfg = transitionSource $ expectJust "Source info for nonexisting block" $ getEdgeInfo from to cfg reverseEdges :: CFG -> CFG @@ -665,7 +660,7 @@ (CmmCall { cml_cont = Nothing }) -> [] other -> panic "Foo" $ - assertPpr False (ppr "Unknown successor cause:" <> + assertPpr False (text "Unknown successor cause:" <> (pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other))) $ map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other where @@ -1025,11 +1020,11 @@ loops (lehPredicts) and one to predict that backedges are more likely than any other edge. -The back edge case is special as it superceeds any other heuristic if it +The back edge case is special as it supersedes any other heuristic if it applies. Do NOT rely solely on nofib results for benchmarking this. I recommend at least -comparing megaparsec and container benchmarks. Nofib does not seeem to have +comparing megaparsec and container benchmarks. Nofib does not seem to have many instances of "loopy" Cmm where these make a difference. TODO: @@ -1350,7 +1345,7 @@ vcat (map (\(k,m) -> ppr (k,m :: IM.IntMap Double)) $ IM.toList g) ) - nodeCount = IM.foldl' (\count toMap -> IM.foldlWithKey' countTargets count toMap) (IM.size graph) graph + nodeCount = IM.foldl' (\count toMap -> IM.foldlWithKey' countTargets (count + 1) toMap) 0 graph where countTargets = (\count k _ -> countNode k + count ) countNode n = if IM.member n graph then 0 else 1 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,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Strict #-} @@ -526,10 +527,9 @@ ----------------------------------------------------------------------------- --- Nothing better than reinvinting the state monad. +-- Nothing better than reinventing the state monad. newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o} -instance Functor (S z s) where - fmap f (S g) = S (\k -> g (k . f)) + deriving (Functor) instance Monad (S z s) where return = pure S g >>= f = S (\k -> g (\a -> unS (f a) k)) diff --git a/GHC/CmmToAsm/CPrim.hs b/GHC/CmmToAsm/CPrim.hs --- a/GHC/CmmToAsm/CPrim.hs +++ b/GHC/CmmToAsm/CPrim.hs @@ -87,7 +87,7 @@ atomicRMWLabel :: Width -> AtomicMachOp -> FastString atomicRMWLabel w amop = case amop of -- lots of boring cases, but we do it this way to get shared FastString - -- literals (compared to concatening strings and allocating FastStrings at + -- literals (compared to concatenating strings and allocating FastStrings at -- runtime) AMO_Add -> case w of W8 -> fsLit "hs_atomic_add8" diff --git a/GHC/CmmToAsm/Dwarf.hs b/GHC/CmmToAsm/Dwarf.hs --- a/GHC/CmmToAsm/Dwarf.hs +++ b/GHC/CmmToAsm/Dwarf.hs @@ -26,50 +26,47 @@ import Data.Ord ( comparing ) import qualified Data.Map as Map import System.FilePath -import System.Directory ( getCurrentDirectory ) import qualified GHC.Cmm.Dataflow.Label as H import qualified GHC.Cmm.Dataflow.Collections as H -- | Generate DWARF/debug information -dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] - -> IO (SDoc, UniqSupply) -dwarfGen _ _ us [] = return (empty, us) -dwarfGen config modLoc us blocks = do +dwarfGen :: IsDoc doc => String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] + -> (doc, UniqSupply) +dwarfGen _ _ _ us [] = (empty, us) +dwarfGen compPath config modLoc us blocks = let platform = ncgPlatform config - -- Convert debug data structures to DWARF info records - let procs = debugSplitProcs blocks + -- Convert debug data structures to DWARF info records + procs = debugSplitProcs blocks stripBlocks dbg | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] } | otherwise = dbg - compPath <- getCurrentDirectory - let lowLabel = dblCLabel $ head procs + lowLabel = dblCLabel $ head procs highLabel = mkAsmTempProcEndLabel $ dblCLabel $ last procs dwarfUnit = DwarfCompileUnit { dwChildren = map (procToDwarf config) (map stripBlocks procs) , dwName = fromMaybe "" (ml_hs_file modLoc) , dwCompDir = addTrailingPathSeparator compPath , dwProducer = cProjectName ++ " " ++ cProjectVersion - , dwLowLabel = pdoc platform lowLabel - , dwHighLabel = pdoc platform highLabel - , dwLineLabel = dwarfLineLabel + , dwLowLabel = lowLabel + , dwHighLabel = highLabel } - -- Check whether we have any source code information, so we do not - -- end up writing a pointer to an empty .debug_line section - -- (dsymutil on Mac Os gets confused by this). - let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk) + -- Check whether we have any source code information, so we do not + -- end up writing a pointer to an empty .debug_line section + -- (dsymutil on Mac Os gets confused by this). + haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk) || any haveSrcIn (dblBlocks blk) haveSrc = any haveSrcIn procs -- .debug_abbrev section: Declare the format we're using - let abbrevSct = pprAbbrevDecls platform haveSrc + abbrevSct = pprAbbrevDecls platform haveSrc -- .debug_info section: Information records on procedures and blocks - let -- unique to identify start and end compilation unit .debug_inf + -- unique to identify start and end compilation unit .debug_inf (unitU, us') = takeUniqFromSupply us - infoSct = vcat [ dwarfInfoLabel <> colon + infoSct = vcat [ line (dwarfInfoLabel <> colon) , dwarfInfoSection platform , compileUnitHeader platform unitU , pprDwarfInfo platform haveSrc dwarfUnit @@ -78,21 +75,23 @@ -- .debug_line section: Generated mainly by the assembler, but we -- need to label it - let lineSct = dwarfLineSection platform $$ - dwarfLineLabel <> colon + lineSct = dwarfLineSection platform $$ + line (dwarfLineLabel <> colon) -- .debug_frame section: Information about the layout of the GHC stack - let (framesU, us'') = takeUniqFromSupply us' + (framesU, us'') = takeUniqFromSupply us' frameSct = dwarfFrameSection platform $$ - dwarfFrameLabel <> colon $$ + line (dwarfFrameLabel <> colon) $$ pprDwarfFrame platform (debugFrame framesU procs) -- .aranges section: Information about the bounds of compilation units - let aranges' | ncgSplitSections config = map mkDwarfARange procs + aranges' | ncgSplitSections config = map mkDwarfARange procs | otherwise = [DwarfARange lowLabel highLabel] - let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU + aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU - return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'') + 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 -- | Build an address range entry for one proc. -- With split sections, each proc needs its own entry, since they may get @@ -106,24 +105,24 @@ -- | Header for a compilation unit, establishing global format -- parameters -compileUnitHeader :: Platform -> Unique -> SDoc +compileUnitHeader :: IsDoc doc => Platform -> Unique -> doc compileUnitHeader platform unitU = let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field - length = pdoc platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pdoc platform cuLabel + length = pprAsmLabel platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pprAsmLabel platform cuLabel <> text "-4" -- length of initialLength field - in vcat [ pdoc platform cuLabel <> colon - , text "\t.long " <> length -- compilation unit size + in vcat [ line (pprAsmLabel platform cuLabel <> colon) + , line (text "\t.long " <> length) -- compilation unit size , pprHalf 3 -- DWARF version , sectionOffset platform dwarfAbbrevLabel dwarfAbbrevLabel -- abbrevs offset - , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size + , line (text "\t.byte " <> int (platformWordSizeInBytes platform)) -- word size ] -- | Compilation unit footer, mainly establishing size of debug sections -compileUnitFooter :: Platform -> Unique -> SDoc +compileUnitFooter :: IsDoc doc => Platform -> Unique -> doc compileUnitFooter platform unitU = let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU - in pdoc platform cuEndLabel <> colon + in line (pprAsmLabel platform cuEndLabel <> colon) -- | Splits the blocks by procedures. In the result all nested blocks -- will come from the same procedure as the top-level block. See 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 @@ -144,17 +144,29 @@ -- * Dwarf section declarations dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection, - dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: Platform -> SDoc + dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: IsDoc doc => Platform -> doc dwarfInfoSection platform = dwarfSection platform "info" dwarfAbbrevSection platform = dwarfSection platform "abbrev" dwarfLineSection platform = dwarfSection platform "line" dwarfFrameSection platform = dwarfSection platform "frame" dwarfGhcSection platform = dwarfSection platform "ghc" dwarfARangesSection platform = dwarfSection platform "aranges" +{-# SPECIALIZE dwarfInfoSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfInfoSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfAbbrevSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfAbbrevSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfLineSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfLineSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfFrameSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfFrameSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfGhcSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfGhcSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfARangesSection :: Platform -> SDoc #-} +{-# SPECIALIZE dwarfARangesSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -dwarfSection :: Platform -> String -> SDoc +dwarfSection :: IsDoc doc => Platform -> String -> doc dwarfSection platform name = - case platformOS platform of + line $ case platformOS platform of os | osElfTarget os -> text "\t.section .debug_" <> text name <> text ",\"\"," <> sectionType platform "progbits" @@ -162,13 +174,24 @@ -> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug" | otherwise -> text "\t.section .debug_" <> text name <> text ",\"dr\"" +{-# SPECIALIZE dwarfSection :: Platform -> String -> SDoc #-} +{-# SPECIALIZE dwarfSection :: Platform -> String -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- * Dwarf section labels -dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: SDoc +dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: IsLine doc => doc dwarfInfoLabel = text ".Lsection_info" dwarfAbbrevLabel = text ".Lsection_abbrev" dwarfLineLabel = text ".Lsection_line" dwarfFrameLabel = text ".Lsection_frame" +{-# SPECIALIZE dwarfInfoLabel :: SDoc #-} +{-# SPECIALIZE dwarfInfoLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfAbbrevLabel :: SDoc #-} +{-# SPECIALIZE dwarfAbbrevLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfLineLabel :: SDoc #-} +{-# SPECIALIZE dwarfLineLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable +{-# SPECIALIZE dwarfFrameLabel :: SDoc #-} +{-# SPECIALIZE dwarfFrameLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Mapping of registers to DWARF register numbers dwarfRegNo :: Platform -> Reg -> Word8 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 @@ -59,9 +59,8 @@ , dwName :: String , dwProducer :: String , dwCompDir :: String - , dwLowLabel :: SDoc - , dwHighLabel :: SDoc - , dwLineLabel :: SDoc } + , dwLowLabel :: CLabel + , dwHighLabel :: CLabel } | DwarfSubprogram { dwChildren :: [DwarfInfo] , dwName :: String , dwLabel :: CLabel @@ -88,13 +87,13 @@ deriving (Eq, Enum) -- | Generate assembly for the given abbreviation code -pprAbbrev :: DwarfAbbrev -> SDoc +pprAbbrev :: IsDoc doc => DwarfAbbrev -> doc pprAbbrev = pprLEBWord . fromIntegral . fromEnum -- | Abbreviation declaration. This explains the binary encoding we -- use for representing 'DwarfInfo'. Be aware that this must be updated -- along with 'pprDwarfInfo'. -pprAbbrevDecls :: Platform -> Bool -> SDoc +pprAbbrevDecls :: IsDoc doc => Platform -> Bool -> doc pprAbbrevDecls platform haveDebugLine = let mkAbbrev abbr tag chld flds = let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form @@ -111,7 +110,7 @@ , (dW_AT_frame_base, dW_FORM_block1) ] in dwarfAbbrevSection platform $$ - dwarfAbbrevLabel <> colon $$ + line (dwarfAbbrevLabel <> colon) $$ mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes ([(dW_AT_name, dW_FORM_string) , (dW_AT_producer, dW_FORM_string) @@ -144,9 +143,11 @@ , (dW_AT_ghc_span_end_col, dW_FORM_data2) ] $$ pprByte 0 +{-# SPECIALIZE pprAbbrevDecls :: Platform -> Bool -> SDoc #-} +{-# SPECIALIZE pprAbbrevDecls :: Platform -> Bool -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Generate assembly for DWARF data -pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc +pprDwarfInfo :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc pprDwarfInfo platform haveSrc d = case d of DwarfCompileUnit {} -> hasChildren @@ -159,39 +160,41 @@ vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$ pprDwarfInfoClose noChildren = pprDwarfInfoOpen platform haveSrc d +{-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc #-} +{-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Print a CLabel name in a ".stringz \"LABEL\"" -pprLabelString :: Platform -> CLabel -> SDoc +pprLabelString :: IsDoc doc => Platform -> CLabel -> doc pprLabelString platform label = - pprString' -- we don't need to escape the string as labels don't contain exotic characters - $ pprCLabel platform CStyle label -- pretty-print as C label (foreign labels may be printed differently in Asm) + pprString' -- we don't need to escape the string as labels don't contain exotic characters + $ pprCLabel platform label -- pretty-print as C label (foreign labels may be printed differently in Asm) -- | Prints assembler data corresponding to DWARF info records. Note -- that the binary format of this is parameterized in @abbrevDecls@ and -- has to be kept in synch. -pprDwarfInfoOpen :: Platform -> Bool -> DwarfInfo -> SDoc +pprDwarfInfoOpen :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel - highLabel lineLbl) = + highLabel) = pprAbbrev DwAbbrCompileUnit $$ pprString name $$ pprString producer $$ pprData4 dW_LANG_Haskell $$ pprString compDir -- Offset due to Note [Info Offset] - $$ pprWord platform (lowLabel <> text "-1") - $$ pprWord platform highLabel + $$ pprWord platform (pprAsmLabel platform lowLabel <> text "-1") + $$ pprWord platform (pprAsmLabel platform highLabel) $$ if haveSrc - then sectionOffset platform lineLbl dwarfLineLabel + then sectionOffset platform dwarfLineLabel dwarfLineLabel else empty pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) = - pdoc platform (mkAsmTempDieLabel label) <> colon + line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon) $$ pprAbbrev abbrev $$ pprString name $$ pprLabelString platform label $$ pprFlag (externallyVisibleCLabel label) -- Offset due to Note [Info Offset] - $$ pprWord platform (pdoc platform label <> text "-1") - $$ pprWord platform (pdoc platform $ mkAsmTempProcEndLabel label) + $$ pprWord platform (pprAsmLabel platform label <> text "-1") + $$ pprWord platform (pprAsmLabel platform $ mkAsmTempProcEndLabel label) $$ pprByte 1 $$ pprByte dW_OP_call_frame_cfa $$ parentValue @@ -199,17 +202,17 @@ abbrev = case parent of Nothing -> DwAbbrSubprogram Just _ -> DwAbbrSubprogramWithParent parentValue = maybe empty pprParentDie parent - pprParentDie sym = sectionOffset platform (pdoc platform sym) dwarfInfoLabel + pprParentDie sym = sectionOffset platform (pprAsmLabel platform sym) dwarfInfoLabel pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) = - pdoc platform (mkAsmTempDieLabel label) <> colon + line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon) $$ pprAbbrev DwAbbrBlockWithoutCode $$ pprLabelString platform label pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = - pdoc platform (mkAsmTempDieLabel label) <> colon + line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon) $$ pprAbbrev DwAbbrBlock $$ pprLabelString platform label - $$ pprWord platform (pdoc platform marker) - $$ pprWord platform (pdoc platform $ mkAsmTempEndLabel marker) + $$ pprWord platform (pprAsmLabel platform marker) + $$ pprWord platform (pprAsmLabel platform $ mkAsmTempEndLabel marker) pprDwarfInfoOpen _ _ (DwarfSrcNote ss) = pprAbbrev DwAbbrGhcSrcNote $$ pprString' (ftext $ srcSpanFile ss) @@ -219,7 +222,7 @@ $$ pprHalf (fromIntegral $ srcSpanEndCol ss) -- | Close a DWARF info record with children -pprDwarfInfoClose :: SDoc +pprDwarfInfoClose :: IsDoc doc => doc pprDwarfInfoClose = pprAbbrev DwAbbrNull -- | A DWARF address range. This is used by the debugger to quickly locate @@ -233,7 +236,7 @@ -- | Print assembler directives corresponding to a DWARF @.debug_aranges@ -- address table entry. -pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc +pprDwarfARanges :: IsDoc doc => Platform -> [DwarfARange] -> Unique -> doc pprDwarfARanges platform arngs unitU = let wordSize = platformWordSizeInBytes platform paddingSize = 4 :: Int @@ -243,9 +246,9 @@ pad n = vcat $ replicate n $ pprByte 0 -- Fix for #17428 initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize - in pprDwWord (ppr initialLength) + in pprDwWord (int initialLength) $$ pprHalf 2 - $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel + $$ sectionOffset platform (pprAsmLabel platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel $$ pprByte (fromIntegral wordSize) $$ pprByte 0 $$ pad paddingSize @@ -254,15 +257,17 @@ -- terminus $$ pprWord platform (char '0') $$ pprWord platform (char '0') +{-# SPECIALIZE pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc #-} +{-# SPECIALIZE pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprDwarfARange :: Platform -> DwarfARange -> SDoc +pprDwarfARange :: IsDoc doc => Platform -> DwarfARange -> doc pprDwarfARange platform arng = -- Offset due to Note [Info Offset]. - pprWord platform (pdoc platform (dwArngStartLabel arng) <> text "-1") + pprWord platform (pprAsmLabel platform (dwArngStartLabel arng) <> text "-1") $$ pprWord platform length where - length = pdoc platform (dwArngEndLabel arng) - <> char '-' <> pdoc platform (dwArngStartLabel arng) + length = pprAsmLabel platform (dwArngEndLabel arng) + <> char '-' <> pprAsmLabel platform (dwArngStartLabel arng) -- | Information about unwind instructions for a procedure. This -- corresponds to a "Common Information Entry" (CIE) in DWARF. @@ -293,21 +298,21 @@ -- in the block } -instance OutputableP env CLabel => OutputableP env DwarfFrameBlock where +instance OutputableP Platform DwarfFrameBlock where pdoc env (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> pdoc env unwinds -- | Header for the @.debug_frame@ section. Here we emit the "Common -- Information Entry" record that establishes general call frame -- parameters and the default stack layout. -pprDwarfFrame :: Platform -> DwarfFrame -> SDoc +pprDwarfFrame :: forall doc. IsDoc doc => Platform -> DwarfFrame -> doc pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs} = let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start") cieEndLabel = mkAsmTempEndLabel cieLabel - length = pdoc platform cieEndLabel <> char '-' <> pdoc platform cieStartLabel + length = pprAsmLabel platform cieEndLabel <> char '-' <> pprAsmLabel platform cieStartLabel spReg = dwarfGlobalRegNo platform Sp retReg = dwarfReturnRegNo platform wordSize = platformWordSizeInBytes platform - pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc + pprInit :: (GlobalReg, Maybe UnwindExpr) -> doc pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw) -- Preserve C stack pointer: This necessary to override that default @@ -316,9 +321,9 @@ ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4 ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7 _ -> empty - in vcat [ pdoc platform cieLabel <> colon + in vcat [ line (pprAsmLabel platform cieLabel <> colon) , pprData4' length -- Length of CIE - , pdoc platform cieStartLabel <> colon + , line (pprAsmLabel platform cieStartLabel <> colon) , pprData4' (text "-1") -- Common Information Entry marker (-1 = 0xf..f) , pprByte 3 -- CIE version (we require DWARF 3) @@ -346,41 +351,43 @@ , pprLEBWord 0 ] $$ wordAlign platform $$ - pdoc platform cieEndLabel <> colon $$ + line (pprAsmLabel platform cieEndLabel <> colon) $$ -- Procedure unwind tables vcat (map (pprFrameProc platform cieLabel cieInit) procs) +{-# SPECIALIZE pprDwarfFrame :: Platform -> DwarfFrame -> SDoc #-} +{-# SPECIALIZE pprDwarfFrame :: Platform -> DwarfFrame -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Writes a "Frame Description Entry" for a procedure. This consists -- mainly of referencing the CIE and writing state machine -- instructions to describe how the frame base (CFA) changes. -pprFrameProc :: Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> SDoc +pprFrameProc :: IsDoc doc => Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> doc pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) = let fdeLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde") fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end") procEnd = mkAsmTempProcEndLabel procLbl ifInfo str = if hasInfo then text str else empty -- see Note [Info Offset] - in vcat [ whenPprDebug $ text "# Unwinding for" <+> pdoc platform procLbl <> colon - , pprData4' (pdoc platform fdeEndLabel <> char '-' <> pdoc platform fdeLabel) - , pdoc platform fdeLabel <> colon - , pprData4' (pdoc platform frameLbl <> char '-' <> dwarfFrameLabel) -- Reference to CIE - , pprWord platform (pdoc platform procLbl <> ifInfo "-1") -- Code pointer - , pprWord platform (pdoc platform procEnd <> char '-' <> - pdoc platform procLbl <> ifInfo "+1") -- Block byte length + in vcat [ whenPprDebug $ line $ text "# Unwinding for" <+> pprAsmLabel platform procLbl <> colon + , pprData4' (pprAsmLabel platform fdeEndLabel <> char '-' <> pprAsmLabel platform fdeLabel) + , line (pprAsmLabel platform fdeLabel <> colon) + , pprData4' (pprAsmLabel platform frameLbl <> char '-' <> dwarfFrameLabel) -- Reference to CIE + , pprWord platform (pprAsmLabel platform procLbl <> ifInfo "-1") -- Code pointer + , pprWord platform (pprAsmLabel platform procEnd <> char '-' <> + pprAsmLabel platform procLbl <> ifInfo "+1") -- Block byte length ] $$ vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$ wordAlign platform $$ - pdoc platform fdeEndLabel <> colon + line (pprAsmLabel platform fdeEndLabel <> colon) -- | Generates unwind information for a block. We only generate -- instructions where unwind information actually changes. This small -- optimisations saves a lot of space, as subsequent blocks often have -- the same unwind information. -pprFrameBlock :: Platform -> DwarfFrameBlock -> S.State UnwindTable SDoc +pprFrameBlock :: forall doc. IsDoc doc => Platform -> DwarfFrameBlock -> S.State UnwindTable doc pprFrameBlock platform (DwarfFrameBlock hasInfo uws0) = vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0 where - pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc + pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable doc pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws -> let -- Did a register's unwind expression change? isChanged :: GlobalReg -> Maybe UnwindExpr @@ -402,7 +409,7 @@ then (empty, oldUws) else let -- see Note [Info Offset] needsOffset = firstDecl && hasInfo - lblDoc = pdoc platform lbl <> + lblDoc = pprAsmLabel platform lbl <> if needsOffset then text "-1" else empty doc = pprByte dW_CFA_set_loc $$ pprWord platform lblDoc $$ vcat (map (uncurry $ pprSetUnwind platform) changed) @@ -450,12 +457,12 @@ -- | Generate code for setting the unwind information for a register, -- optimized using its known old value in the table. Note that "Sp" is -- special: We see it as synonym for the CFA. -pprSetUnwind :: Platform +pprSetUnwind :: IsDoc doc => Platform -> GlobalReg -- ^ the register to produce an unwinding table entry for -> (Maybe UnwindExpr, Maybe UnwindExpr) -- ^ the old and new values of the register - -> SDoc + -> doc pprSetUnwind plat g (_, Nothing) = pprUndefUnwind plat g pprSetUnwind _ Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s' @@ -495,13 +502,13 @@ -- | Print the register number of the given 'GlobalReg' as an unsigned LEB128 -- encoded number. -pprLEBRegNo :: Platform -> GlobalReg -> SDoc +pprLEBRegNo :: IsDoc doc => Platform -> GlobalReg -> doc pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat -- | Generates a DWARF expression for the given unwind expression. If -- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets -- mentioned. -pprUnwindExpr :: Platform -> Bool -> UnwindExpr -> SDoc +pprUnwindExpr :: IsDoc doc => Platform -> Bool -> UnwindExpr -> doc pprUnwindExpr platform spIsCFA expr = let pprE (UwConst i) | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i) @@ -513,96 +520,112 @@ pprE (UwReg 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 (pdoc platform l) + pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (pprAsmLabel platform l) pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul - in text "\t.uleb128 2f-1f" $$ -- DW_FORM_block length + in line (text "\t.uleb128 2f-1f") $$ -- DW_FORM_block length -- computed as the difference of the following local labels 2: and 1: - text "1:" $$ + line (text "1:") $$ pprE expr $$ - text "2:" + line (text "2:") -- | Generate code for re-setting the unwind information for a -- register to @undefined@ -pprUndefUnwind :: Platform -> GlobalReg -> SDoc +pprUndefUnwind :: IsDoc doc => Platform -> GlobalReg -> doc pprUndefUnwind plat g = pprByte dW_CFA_undefined $$ pprLEBRegNo plat g -- | Align assembly at (machine) word boundary -wordAlign :: Platform -> SDoc +wordAlign :: IsDoc doc => Platform -> doc wordAlign plat = - text "\t.align " <> case platformOS plat of + line $ text "\t.align " <> case platformOS plat of OSDarwin -> case platformWordSize plat of PW8 -> char '3' PW4 -> char '2' - _other -> ppr (platformWordSizeInBytes plat) + _other -> int (platformWordSizeInBytes plat) +{-# SPECIALIZE wordAlign :: Platform -> SDoc #-} +{-# SPECIALIZE wordAlign :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Assembly for a single byte of constant DWARF data -pprByte :: Word8 -> SDoc -pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word) +pprByte :: IsDoc doc => Word8 -> doc +pprByte x = line $ text "\t.byte " <> integer (fromIntegral x) +{-# SPECIALIZE pprByte :: Word8 -> SDoc #-} +{-# SPECIALIZE pprByte :: Word8 -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Assembly for a two-byte constant integer -pprHalf :: Word16 -> SDoc -pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word) +pprHalf :: IsDoc doc => Word16 -> doc +pprHalf x = line $ text "\t.short" <+> integer (fromIntegral x) +{-# SPECIALIZE pprHalf :: Word16 -> SDoc #-} +{-# SPECIALIZE pprHalf :: Word16 -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Assembly for a constant DWARF flag -pprFlag :: Bool -> SDoc +pprFlag :: IsDoc doc => Bool -> doc pprFlag f = pprByte (if f then 0xff else 0x00) -- | Assembly for 4 bytes of dynamic DWARF data -pprData4' :: SDoc -> SDoc -pprData4' x = text "\t.long " <> x +pprData4' :: IsDoc doc => Line doc -> doc +pprData4' x = line (text "\t.long " <> x) +{-# SPECIALIZE pprData4' :: SDoc -> SDoc #-} +{-# SPECIALIZE pprData4' :: HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Assembly for 4 bytes of constant DWARF data -pprData4 :: Word -> SDoc -pprData4 = pprData4' . ppr +pprData4 :: IsDoc doc => Word -> doc +pprData4 = pprData4' . integer . fromIntegral -- | Assembly for a DWARF word of dynamic data. This means 32 bit, as -- we are generating 32 bit DWARF. -pprDwWord :: SDoc -> SDoc +pprDwWord :: IsDoc doc => Line doc -> doc pprDwWord = pprData4' +{-# SPECIALIZE pprDwWord :: SDoc -> SDoc #-} +{-# SPECIALIZE pprDwWord :: HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Assembly for a machine word of dynamic data. Depends on the -- architecture we are currently generating code for. -pprWord :: Platform -> SDoc -> SDoc +pprWord :: IsDoc doc => Platform -> Line doc -> doc pprWord plat s = - case platformWordSize plat of + line $ case platformWordSize plat of PW4 -> text "\t.long " <> s PW8 -> text "\t.quad " <> s +{-# SPECIALIZE pprWord :: Platform -> SDoc -> SDoc #-} +{-# SPECIALIZE pprWord :: Platform -> HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Prints a number in "little endian base 128" format. The idea is -- to optimize for small numbers by stopping once all further bytes -- would be 0. The highest bit in every byte signals whether there -- are further bytes to read. -pprLEBWord :: Word -> SDoc +pprLEBWord :: IsDoc doc => Word -> doc pprLEBWord x | x < 128 = pprByte (fromIntegral x) | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ pprLEBWord (x `shiftR` 7) +{-# SPECIALIZE pprLEBWord :: Word -> SDoc #-} +{-# SPECIALIZE pprLEBWord :: Word -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Same as @pprLEBWord@, but for a signed number -pprLEBInt :: Int -> SDoc +pprLEBInt :: IsDoc doc => Int -> doc pprLEBInt x | x >= -64 && x < 64 = pprByte (fromIntegral (x .&. 127)) | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$ pprLEBInt (x `shiftR` 7) +{-# SPECIALIZE pprLEBInt :: Int -> SDoc #-} +{-# SPECIALIZE pprLEBInt :: Int -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Generates a dynamic null-terminated string. If required the -- caller needs to make sure that the string is escaped properly. -pprString' :: SDoc -> SDoc -pprString' str = text "\t.asciz \"" <> str <> char '"' +pprString' :: IsDoc doc => Line doc -> doc +pprString' str = line (text "\t.asciz \"" <> str <> char '"') -- | Generate a string constant. We take care to escape the string. -pprString :: String -> SDoc +pprString :: IsDoc doc => String -> doc pprString str = pprString' $ hcat $ map escapeChar $ if str `lengthIs` utf8EncodedLength str then str - else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeString str + else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeByteString str -- | Escape a single non-unicode character -escapeChar :: Char -> SDoc +escapeChar :: IsLine doc => Char -> doc escapeChar '\\' = text "\\\\" escapeChar '\"' = text "\\\"" escapeChar '\n' = text "\\n" @@ -621,9 +644,11 @@ -- us to just reference the target directly, and will figure out on -- their own that we actually need an offset. Finally, Windows has -- a special directive to refer to relative offsets. Fun. -sectionOffset :: Platform -> SDoc -> SDoc -> SDoc +sectionOffset :: IsDoc doc => Platform -> Line doc -> Line doc -> doc sectionOffset plat target section = case platformOS plat of OSDarwin -> pprDwWord (target <> char '-' <> section) - OSMinGW32 -> text "\t.secrel32 " <> target + OSMinGW32 -> line (text "\t.secrel32 " <> target) _other -> pprDwWord target +{-# SPECIALIZE sectionOffset :: Platform -> SDoc -> SDoc -> SDoc #-} +{-# SPECIALIZE sectionOffset :: Platform -> HLine -> HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable diff --git a/GHC/CmmToAsm/Instr.hs b/GHC/CmmToAsm/Instr.hs --- a/GHC/CmmToAsm/Instr.hs +++ b/GHC/CmmToAsm/Instr.hs @@ -15,6 +15,7 @@ import GHC.Cmm.BlockId import GHC.CmmToAsm.Config +import GHC.Data.FastString -- | Holds a list of source and destination registers used by a -- particular instruction. @@ -160,4 +161,4 @@ pprInstr :: Platform -> instr -> SDoc -- Create a comment instruction - mkComment :: SDoc -> [instr] + mkComment :: FastString -> [instr] diff --git a/GHC/CmmToAsm/Monad.hs b/GHC/CmmToAsm/Monad.hs --- a/GHC/CmmToAsm/Monad.hs +++ b/GHC/CmmToAsm/Monad.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} -- ----------------------------------------------------------------------------- -- @@ -20,7 +22,6 @@ addImmediateSuccessorNat, updateCfgNat, getUniqueNat, - mapAccumLNat, setDeltaNat, getConfig, getPlatform, @@ -32,7 +33,6 @@ getPicBaseMaybeNat, getPicBaseNat, getCfgWeights, - getModLoc, getFileId, getDebugBlock, @@ -67,10 +67,9 @@ import GHC.Types.Unique ( Unique ) import GHC.Unit.Module -import Control.Monad ( ap ) - -import GHC.Utils.Outputable (SDoc, ppr) +import GHC.Utils.Outputable (SDoc, HDoc, ppr) import GHC.Utils.Panic (pprPanic) +import GHC.Utils.Monad.State.Strict (State (..), runState, state) import GHC.Utils.Misc import GHC.CmmToAsm.CFG import GHC.CmmToAsm.CFG.Weight @@ -85,15 +84,16 @@ shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, -- | 'Module' is only for printing internal labels. See Note [Internal proc -- labels] in CLabel. - pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc, + pprNatCmmDeclS :: NatCmmDecl statics instr -> SDoc, + pprNatCmmDeclH :: NatCmmDecl statics instr -> HDoc, + -- see Note [pprNatCmmDeclS and pprNatCmmDeclH] maxSpillSlots :: Int, allocatableRegs :: [RealReg], ncgAllocMoreStack :: Int -> NatCmmDecl statics instr -> UniqSM (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], + ncgMakeFarBranches :: LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr], extractUnwindPoints :: [instr] -> [UnwindPoint], -- ^ given the instruction sequence of a block, produce a list of -- the block's 'UnwindPoint's @@ -105,14 +105,45 @@ -- when possible. } +{- Note [pprNatCmmDeclS and pprNatCmmDeclH] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each NcgImpl provides two implementations of its CmmDecl printer, pprNatCmmDeclS +and pprNatCmmDeclH, which are specialized to SDoc and HDoc, respectively +(see Note [SDoc versus HDoc] in GHC.Utils.Outputable). These are both internally +implemented as a single, polymorphic function, but they need to be stored using +monomorphic types to ensure the specialized versions are used, which is +essential for performance (see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable). + +One might wonder why we bother with pprNatCmmDeclS and SDoc at all, since we +have a perfectly serviceable HDoc-based implementation that is more efficient. +However, it turns out we benefit from keeping both, for two (related) reasons: + + 1. Although we absolutely want to take care to use pprNatCmmDeclH for actual + code generation (the improved performance there is why we have HDoc at + all!), we also sometimes print assembly for debug dumps, when requested via + -ddump-asm. In this case, it’s more convenient to produce an SDoc, which + can be concatenated with other SDocs for consistency with the general- + purpose dump file infrastructure. + + 2. Some debug information is sometimes useful to include in -ddump-asm that is + neither necessary nor useful in normal code generation, and it turns out to + be tricky to format neatly using the one-line-at-a-time model of HLine/HDoc. + +Therefore, we provide both pprNatCmmDeclS and pprNatCmmDeclH, and we sometimes +include additional information in the SDoc variant using dualDoc +(see Note [dualLine and dualDoc] in GHC.Utils.Outputable). However, it is +absolutely *critical* that pprNatCmmDeclS is not actually used unless -ddump-asm +is provided, as that would rather defeat the whole point. (Fortunately, the +difference in allocations between the two implementations is so vast that such a +mistake would readily show up in performance tests). -} + data NatM_State = NatM_State { natm_us :: UniqSupply, - natm_delta :: Int, -- ^ Stack offset for unwinding information + natm_delta :: Int, natm_imports :: [(CLabel)], natm_pic :: Maybe Reg, natm_config :: NCGConfig, - natm_modloc :: ModLocation, natm_fileid :: DwarfFiles, natm_debug_map :: LabelMap DebugBlock, natm_cfg :: CFG @@ -123,38 +154,35 @@ type DwarfFiles = UniqFM FastString (FastString, Int) -newtype NatM result = NatM (NatM_State -> (result, NatM_State)) - deriving (Functor) +newtype NatM a = NatM' (State NatM_State a) + deriving stock (Functor) + deriving (Applicative, Monad) via State NatM_State +pattern NatM :: (NatM_State -> (a, NatM_State)) -> NatM a +pattern NatM f <- NatM' (runState -> f) + where NatM f = NatM' (state f) +{-# COMPLETE NatM #-} + unNat :: NatM a -> NatM_State -> (a, NatM_State) unNat (NatM a) = a -mkNatM_State :: UniqSupply -> Int -> NCGConfig -> ModLocation -> +mkNatM_State :: UniqSupply -> Int -> NCGConfig -> DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State mkNatM_State us delta config - = \loc dwf dbg cfg -> + = \dwf dbg cfg -> NatM_State { natm_us = us , natm_delta = delta , natm_imports = [] , natm_pic = Nothing , natm_config = config - , natm_modloc = loc , natm_fileid = dwf , natm_debug_map = dbg , natm_cfg = cfg } initNat :: NatM_State -> NatM a -> (a, NatM_State) -initNat init_st m - = case unNat m init_st of { (r,st) -> (r,st) } - -instance Applicative NatM where - pure = returnNat - (<*>) = ap - -instance Monad NatM where - (>>=) = thenNat +initNat = flip unNat instance MonadUnique NatM where getUniqueSupplyM = NatM $ \st -> @@ -165,27 +193,6 @@ case takeUniqFromSupply (natm_us st) of (uniq, us') -> (uniq, st {natm_us = us'}) -thenNat :: NatM a -> (a -> NatM b) -> NatM b -thenNat expr cont - = NatM $ \st -> case unNat expr st of - (result, st') -> unNat (cont result) st' - -returnNat :: a -> NatM a -returnNat result - = NatM $ \st -> (result, st) - -mapAccumLNat :: (acc -> x -> NatM (acc, y)) - -> acc - -> [x] - -> NatM (acc, [y]) - -mapAccumLNat _ b [] - = return (b, []) -mapAccumLNat f b (x:xs) - = do (b__2, x__2) <- f b x - (b__3, xs__2) <- mapAccumLNat f b__2 xs - return (b__3, x__2:xs__2) - getUniqueNat :: NatM Unique getUniqueNat = NatM $ \ st -> case takeUniqFromSupply $ natm_us st of @@ -245,9 +252,7 @@ getBlockIdNat :: NatM BlockId getBlockIdNat - = do u <- getUniqueNat - return (mkBlockId u) - + = mkBlockId <$> getUniqueNat getNewLabelNat :: NatM CLabel getNewLabelNat @@ -309,10 +314,6 @@ -> do reg <- getNewRegNat rep NatM (\state -> (reg, state { natm_pic = Just reg })) - -getModLoc :: NatM ModLocation -getModLoc - = NatM $ \ st -> (natm_modloc st, st) -- | Get native code generator configuration getConfig :: NatM NCGConfig diff --git a/GHC/CmmToAsm/PIC.hs b/GHC/CmmToAsm/PIC.hs --- a/GHC/CmmToAsm/PIC.hs +++ b/GHC/CmmToAsm/PIC.hs @@ -532,11 +532,11 @@ -- -- We don't need to declare any offset tables. -- However, for PIC on x86, we need a small helper function. -pprGotDeclaration :: NCGConfig -> SDoc +pprGotDeclaration :: NCGConfig -> HDoc pprGotDeclaration config = case (arch,os) of (ArchX86, OSDarwin) | ncgPIC config - -> vcat [ + -> 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", @@ -548,7 +548,7 @@ -- Emit XCOFF TOC section (_, OSAIX) - -> vcat $ [ text ".toc" + -> lines_ [ text ".toc" , text ".tc ghc_toc_table[TC],.LCTOC1" , text ".csect ghc_toc_table[RW]" -- See Note [.LCTOC1 in PPC PIC code] @@ -558,16 +558,16 @@ -- PPC 64 ELF v1 needs a Table Of Contents (TOC) (ArchPPC_64 ELF_V1, _) - -> text ".section \".toc\",\"aw\"" + -> line $ text ".section \".toc\",\"aw\"" -- In ELF v2 we also need to tell the assembler that we want ABI -- version 2. This would normally be done at the top of the file -- right after a file directive, but I could not figure out how -- to do that. (ArchPPC_64 ELF_V2, _) - -> vcat [ text ".abiversion 2", - text ".section \".toc\",\"aw\"" - ] + -> lines_ [ text ".abiversion 2", + text ".section \".toc\",\"aw\"" + ] (arch, os) | osElfTarget os @@ -577,7 +577,7 @@ | osElfTarget os , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2 - -> vcat [ + -> lines_ [ -- See Note [.LCTOC1 in PPC PIC code] text ".section \".got2\",\"aw\"", text ".LCTOC1 = .+32768" ] @@ -595,13 +595,13 @@ -- and one for non-PIC. -- -pprImportedSymbol :: NCGConfig -> CLabel -> SDoc +pprImportedSymbol :: NCGConfig -> CLabel -> HDoc pprImportedSymbol config importedLbl = case (arch,os) of (ArchX86, OSDarwin) | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl -> if not pic then - vcat [ + lines_ [ text ".symbol_stub", text "L" <> ppr_lbl lbl <> text "$stub:", text "\t.indirect_symbol" <+> ppr_lbl lbl, @@ -614,7 +614,7 @@ text "\tjmp dyld_stub_binding_helper" ] else - vcat [ + lines_ [ text ".section __TEXT,__picsymbolstub2," <> text "symbol_stubs,pure_instructions,25", text "L" <> ppr_lbl lbl <> text "$stub:", @@ -631,7 +631,8 @@ text "\tpushl %eax", text "\tjmp dyld_stub_binding_helper" ] - $+$ vcat [ text ".section __DATA, __la_sym_ptr" + $$ 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:", @@ -640,7 +641,7 @@ <> text "$stub_binder"] | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl - -> vcat [ + -> lines_ [ text ".non_lazy_symbol_pointer", char 'L' <> ppr_lbl lbl <> text "$non_lazy_ptr:", text "\t.indirect_symbol" <+> ppr_lbl lbl, @@ -667,7 +668,7 @@ (_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) - -> vcat [ + -> lines_ [ text "LC.." <> ppr_lbl lbl <> char ':', text "\t.long" <+> ppr_lbl lbl ] _ -> empty @@ -705,7 +706,7 @@ | osElfTarget os -> case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) - -> vcat [ + -> lines_ [ text ".LC_" <> ppr_lbl lbl <> char ':', text "\t.quad" <+> ppr_lbl lbl ] _ -> empty @@ -718,7 +719,7 @@ W64 -> text "\t.quad" _ -> panic "Unknown wordRep in pprImportedSymbol" - in vcat [ + in lines_ [ text ".section \".got2\", \"aw\"", text ".LC_" <> ppr_lbl lbl <> char ':', symbolSize <+> ppr_lbl lbl ] @@ -729,7 +730,8 @@ _ -> panic "PIC.pprImportedSymbol: no match" where platform = ncgPlatform config - ppr_lbl = pprCLabel platform AsmStyle + ppr_lbl :: CLabel -> HLine + ppr_lbl = pprAsmLabel platform arch = platformArch platform os = platformOS platform pic = ncgPIC config diff --git a/GHC/CmmToAsm/PPC.hs b/GHC/CmmToAsm/PPC.hs --- a/GHC/CmmToAsm/PPC.hs +++ b/GHC/CmmToAsm/PPC.hs @@ -28,7 +28,8 @@ , canShortcut = PPC.canShortcut , shortcutStatics = PPC.shortcutStatics , shortcutJump = PPC.shortcutJump - , pprNatCmmDecl = PPC.pprNatCmmDecl config + , pprNatCmmDeclH = PPC.pprNatCmmDecl config + , pprNatCmmDeclS = PPC.pprNatCmmDecl config , maxSpillSlots = PPC.maxSpillSlots config , allocatableRegs = PPC.allocatableRegs platform , ncgAllocMoreStack = PPC.allocMoreStack platform 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 @@ -48,7 +48,6 @@ -- Our intermediate code: import GHC.Cmm.BlockId -import GHC.Cmm.Ppr ( pprExpr ) import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch @@ -163,7 +162,7 @@ config <- getConfig platform <- getPlatform case stmt of - CmmComment s -> return (unitOL (COMMENT $ ftext s)) + CmmComment s -> return (unitOL (COMMENT s)) CmmTick {} -> return nilOL CmmUnwind {} -> return nilOL @@ -395,7 +394,7 @@ iselExpr64 expr = do platform <- getPlatform - pprPanic "iselExpr64(powerpc)" (pprExpr platform expr) + pprPanic "iselExpr64(powerpc)" (pdoc platform expr) @@ -408,7 +407,7 @@ getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg)) | OSAIX <- platformOS platform = do let code dst = toOL [ LD II32 dst tocAddr ] - tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]")) + tocAddr = AddrRegImm toc (ImmLit (fsLit "ghc_toc_table[TC]")) return (Any II32 code) | target32Bit platform = do reg <- getPicBaseNat $ archWordFormat (target32Bit platform) @@ -689,7 +688,7 @@ `consOL` (addr_code `snocOL` LD format dst addr) return (Any format code) -getRegister' _ platform other = pprPanic "getRegister(ppc)" (pprExpr platform other) +getRegister' _ platform other = pprPanic "getRegister(ppc)" (pdoc platform other) -- extend?Rep: wrap integer expression of type `from` -- in a conversion to `to` @@ -2146,7 +2145,7 @@ -- 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 santize the high bits + -- We widen to a native-width register to sanitize the high bits indexExpr = CmmMachOp (MO_UU_Conv expr_w (platformWordWidth platform)) [indexExpr0] 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 @@ -33,7 +33,7 @@ ) where -import GHC.Prelude +import GHC.Prelude hiding (head, init, last, tail) import GHC.CmmToAsm.PPC.Regs import GHC.CmmToAsm.PPC.Cond @@ -52,12 +52,14 @@ import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.CLabel -import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.FM (listToUFM, lookupUFM) import GHC.Types.Unique.Supply +import Data.Foldable (toList) +import qualified Data.List.NonEmpty as NE +import GHC.Data.FastString (FastString) import Data.Maybe (fromMaybe) @@ -177,7 +179,7 @@ data Instr -- comment pseudo-op - = COMMENT SDoc + = COMMENT FastString -- location pseudo-op (file, line, col, name) | LOCATION Int Int Int String @@ -675,15 +677,15 @@ -- big, we have to work around this limitation. makeFarBranches - :: Platform - -> LabelMap RawCmmStatics + :: LabelMap RawCmmStatics -> [NatBasicBlock Instr] - -> UniqSM [NatBasicBlock Instr] -makeFarBranches _platform info_env blocks - | last blockAddresses < nearLimit = return blocks - | otherwise = return $ zipWith handleBlock blockAddresses blocks + -> [NatBasicBlock Instr] +makeFarBranches info_env blocks + | NE.last blockAddresses < nearLimit = blocks + | otherwise = zipWith handleBlock blockAddressList blocks where - blockAddresses = scanl (+) 0 $ map blockLen blocks + blockAddresses = NE.scanl (+) 0 $ map blockLen blocks + blockAddressList = toList blockAddresses blockLen (BasicBlock _ instrs) = length instrs handleBlock addr (BasicBlock id instrs) @@ -704,4 +706,4 @@ -- to calculate things exactly nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW - blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses + blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddressList 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 @@ -34,7 +34,6 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform @@ -47,7 +46,7 @@ -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc +pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc pprNatCmmDecl config (CmmData section dats) = pprSectionAlign config section $$ pprDatas (ncgPlatform config) dats @@ -64,15 +63,15 @@ _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null, -- so label needed vcat (map (pprBasicBlock config top_info) blocks) $$ - ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel lbl) - <> char ':' $$ - pprProcEndLabel platform lbl) $$ + ppWhen (ncgDwarfEnabled config) (line (pprAsmLabel platform (mkAsmTempEndLabel lbl) + <> char ':') $$ + line (pprProcEndLabel platform lbl)) $$ pprSizeDecl platform lbl Just (CmmStaticsRaw info_lbl _) -> pprSectionAlign config (Section Text info_lbl) $$ (if platformHasSubsectionsViaSymbols platform - then pdoc platform (mkDeadStripPreventer info_lbl) <> char ':' + then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':') else empty) $$ vcat (map (pprBasicBlock config top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain @@ -80,66 +79,66 @@ (if platformHasSubsectionsViaSymbols platform then -- See Note [Subsections Via Symbols] in X86/Ppr.hs - text "\t.long " - <+> pdoc platform info_lbl - <+> char '-' - <+> pdoc platform (mkDeadStripPreventer info_lbl) + 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 -- | Output the ELF .size directive. -pprSizeDecl :: Platform -> CLabel -> SDoc +pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc pprSizeDecl platform lbl = if osElfTarget (platformOS platform) - then text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl + then line (text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl) else empty where - prettyLbl = pdoc platform lbl + prettyLbl = pprAsmLabel platform lbl codeLbl | platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl | otherwise = prettyLbl -pprFunctionDescriptor :: Platform -> CLabel -> SDoc -pprFunctionDescriptor platform lab = pprGloblDecl platform lab - $$ text "\t.section \".opd\", \"aw\"" - $$ text "\t.align 3" - $$ pdoc platform lab <> char ':' - $$ text "\t.quad ." - <> pdoc platform lab - <> text ",.TOC.@tocbase,0" - $$ text "\t.previous" - $$ text "\t.type" - <+> pdoc platform lab - <> text ", @function" - $$ char '.' <> pdoc platform lab <> char ':' +pprFunctionDescriptor :: IsDoc doc => Platform -> CLabel -> doc +pprFunctionDescriptor platform lab = + vcat [pprGloblDecl platform lab, + line (text "\t.section \".opd\", \"aw\""), + line (text "\t.align 3"), + line (pprAsmLabel platform lab <> char ':'), + line (text "\t.quad ." + <> pprAsmLabel platform lab + <> text ",.TOC.@tocbase,0"), + line (text "\t.previous"), + line (text "\t.type" + <+> pprAsmLabel platform lab + <> text ", @function"), + line (char '.' <> pprAsmLabel platform lab <> char ':')] -pprFunctionPrologue :: Platform -> CLabel ->SDoc -pprFunctionPrologue platform lab = pprGloblDecl platform lab - $$ text ".type " - <> pdoc platform lab - <> text ", @function" - $$ pdoc platform lab <> char ':' - $$ text "0:\taddis\t" <> pprReg toc - <> text ",12,.TOC.-0b@ha" - $$ text "\taddi\t" <> pprReg toc - <> char ',' <> pprReg toc <> text ",.TOC.-0b@l" - $$ text "\t.localentry\t" <> pdoc platform lab - <> text ",.-" <> pdoc platform lab +pprFunctionPrologue :: IsDoc doc => Platform -> CLabel -> doc +pprFunctionPrologue platform lab = + vcat [pprGloblDecl platform lab, + line (text ".type " <> pprAsmLabel platform lab <> text ", @function"), + line (pprAsmLabel platform lab <> char ':'), + line (text "0:\taddis\t" <> pprReg toc <> text ",12,.TOC.-0b@ha"), + line (text "\taddi\t" <> pprReg toc <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"), + line (text "\t.localentry\t" <> pprAsmLabel platform lab <> + text ",.-" <> pprAsmLabel platform lab)] -pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name - -> SDoc +pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name + -> doc pprProcEndLabel platform lbl = - pdoc platform (mkAsmTempProcEndLabel lbl) <> char ':' + pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> char ':' -pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr - -> SDoc +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) instrs) $$ ppWhen (ncgDwarfEnabled config) ( - pdoc platform (mkAsmTempEndLabel asmLbl) <> char ':' - <> pprProcEndLabel platform asmLbl + line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':' + <> pprProcEndLabel platform asmLbl) ) where asmLbl = blockLbl blockid @@ -153,7 +152,7 @@ -pprDatas :: Platform -> RawCmmStatics -> SDoc +pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel @@ -163,38 +162,38 @@ , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' = pprGloblDecl platform alias - $$ text ".equiv" <+> pdoc platform alias <> comma <> pdoc platform (CmmLabel ind') + $$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind') pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) -pprData :: Platform -> CmmStatic -> SDoc +pprData :: IsDoc doc => Platform -> CmmStatic -> doc pprData platform d = case d of - CmmString str -> pprString str - CmmFileEmbed path -> pprFileEmbed path - CmmUninitialised bytes -> text ".space " <> int bytes + CmmString str -> line (pprString str) + CmmFileEmbed path _ -> line (pprFileEmbed path) + CmmUninitialised bytes -> line (text ".space " <> int bytes) CmmStaticLit lit -> pprDataItem platform lit -pprGloblDecl :: Platform -> CLabel -> SDoc +pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".globl " <> pdoc platform lbl + | otherwise = line (text ".globl " <> pprAsmLabel platform lbl) -pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc +pprTypeAndSizeDecl :: IsLine doc => Platform -> CLabel -> doc pprTypeAndSizeDecl platform lbl = if platformOS platform == OSLinux && externallyVisibleCLabel lbl then text ".type " <> - pdoc platform lbl <> text ", @object" + pprAsmLabel platform lbl <> text ", @object" else empty -pprLabel :: Platform -> CLabel -> SDoc +pprLabel :: IsDoc doc => Platform -> CLabel -> doc pprLabel platform lbl = pprGloblDecl platform lbl - $$ pprTypeAndSizeDecl platform lbl - $$ (pdoc platform lbl <> char ':') + $$ line (pprTypeAndSizeDecl platform lbl) + $$ line (pprAsmLabel platform lbl <> char ':') -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -pprReg :: Reg -> SDoc +pprReg :: forall doc. IsLine doc => Reg -> doc pprReg r = case r of @@ -205,7 +204,7 @@ RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u where - ppr_reg_no :: Int -> SDoc + ppr_reg_no :: Int -> doc ppr_reg_no i | i <= 31 = int i -- GPRs | i <= 63 = int (i-32) -- FPRs @@ -213,7 +212,7 @@ -pprFormat :: Format -> SDoc +pprFormat :: IsLine doc => Format -> doc pprFormat x = case x of II8 -> text "b" @@ -224,7 +223,7 @@ FF64 -> text "fd" -pprCond :: Cond -> SDoc +pprCond :: IsLine doc => Cond -> doc pprCond c = case c of { ALWAYS -> text ""; @@ -235,13 +234,13 @@ GU -> text "gt"; LEU -> text "le"; } -pprImm :: Platform -> Imm -> SDoc +pprImm :: IsLine doc => Platform -> Imm -> doc pprImm platform = \case ImmInt i -> int i ImmInteger i -> integer i - ImmCLbl l -> pdoc platform l - ImmIndex l i -> pdoc platform l <> char '+' <> int i - ImmLit s -> s + ImmCLbl l -> pprAsmLabel platform l + ImmIndex l i -> pprAsmLabel platform l <> char '+' <> int i + ImmLit s -> ftext s ImmFloat f -> float $ fromRational f ImmDouble d -> double $ fromRational d ImmConstantSum a b -> pprImm platform a <> char '+' <> pprImm platform b @@ -265,7 +264,7 @@ HIGHESTA i -> pprImm platform i <> text "@highesta" -pprAddr :: Platform -> AddrMode -> SDoc +pprAddr :: IsLine doc => Platform -> AddrMode -> doc pprAddr platform = \case AddrRegReg r1 r2 -> pprReg r1 <> char ',' <+> pprReg r2 AddrRegImm r1 (ImmInt i) -> hcat [ int i, char '(', pprReg r1, char ')' ] @@ -273,14 +272,14 @@ AddrRegImm r1 imm -> hcat [ pprImm platform imm, char '(', pprReg r1, char ')' ] -pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign config sec@(Section seg _) = - pprSectionHeader config sec $$ + line (pprSectionHeader config sec) $$ pprAlignForSection (ncgPlatform config) seg -- | Print appropriate alignment for the given section type. -pprAlignForSection :: Platform -> SectionType -> SDoc -pprAlignForSection platform seg = +pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc +pprAlignForSection platform seg = line $ let ppc64 = not $ target32Bit platform in case seg of Text -> text ".align 2" @@ -296,7 +295,6 @@ UninitialisedData | ppc64 -> text ".align 3" | otherwise -> text ".align 2" - ReadOnlyData16 -> text ".align 4" -- TODO: This is copied from the ReadOnlyData case, but it can likely be -- made more efficient. InitArray -> text ".align 3" @@ -306,9 +304,9 @@ | otherwise -> text ".align 2" OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section" -pprDataItem :: Platform -> CmmLit -> SDoc +pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc pprDataItem platform lit - = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) where imm = litToImm lit archPPC_64 = not $ target32Bit platform @@ -335,21 +333,21 @@ = panic "PPC.Ppr.pprDataItem: no match" -asmComment :: SDoc -> SDoc +asmComment :: IsLine doc => doc -> doc asmComment c = whenPprDebug $ text "#" <+> c -pprInstr :: Platform -> Instr -> SDoc +pprInstr :: IsDoc doc => Platform -> Instr -> doc pprInstr platform instr = case instr of COMMENT s - -> asmComment s + -> line (asmComment (ftext s)) - LOCATION file line col _name - -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col + LOCATION file line' col _name + -> line (text "\t.loc" <+> int file <+> int line' <+> int col) DELTA d - -> asmComment $ text ("\tdelta = " ++ show d) + -> line (asmComment $ text ("\tdelta = " ++ show d)) NEWBLOCK _ -> panic "PprMach.pprInstr: NEWBLOCK" @@ -376,7 +374,7 @@ -} LD fmt reg addr - -> hcat [ + -> line $ hcat [ char '\t', text "l", (case fmt of @@ -405,7 +403,7 @@ -> panic "PPC.Ppr.pprInstr LDFAR: no match" LDR fmt reg1 addr - -> hcat [ + -> line $ hcat [ text "\tl", case fmt of II32 -> char 'w' @@ -418,7 +416,7 @@ ] LA fmt reg addr - -> hcat [ + -> line $ hcat [ char '\t', text "l", (case fmt of @@ -438,7 +436,7 @@ ] ST fmt reg addr - -> hcat [ + -> line $ hcat [ char '\t', text "st", pprFormat fmt, @@ -459,7 +457,7 @@ -> panic "PPC.Ppr.pprInstr STFAR: no match" STU fmt reg addr - -> hcat [ + -> line $ hcat [ char '\t', text "st", pprFormat fmt, @@ -473,7 +471,7 @@ ] STC fmt reg1 addr - -> hcat [ + -> line $ hcat [ text "\tst", case fmt of II32 -> char 'w' @@ -486,7 +484,7 @@ ] LIS reg imm - -> hcat [ + -> line $ hcat [ char '\t', text "lis", char '\t', @@ -496,7 +494,7 @@ ] LI reg imm - -> hcat [ + -> line $ hcat [ char '\t', text "li", char '\t', @@ -507,7 +505,7 @@ MR reg1 reg2 | reg1 == reg2 -> empty - | otherwise -> hcat [ + | otherwise -> line $ hcat [ char '\t', case targetClassOfReg platform reg1 of RcInteger -> text "mr" @@ -519,7 +517,7 @@ ] CMP fmt reg ri - -> hcat [ + -> line $ hcat [ char '\t', op, char '\t', @@ -537,7 +535,7 @@ ] CMPL fmt reg ri - -> hcat [ + -> line $ hcat [ char '\t', op, char '\t', @@ -555,13 +553,13 @@ ] BCC cond blockid prediction - -> hcat [ + -> line $ hcat [ char '\t', text "b", pprCond cond, pprPrediction prediction, char '\t', - pdoc platform lbl + pprAsmLabel platform lbl ] where lbl = mkLocalBlockLabel (getUnique blockid) pprPrediction p = case p of @@ -570,7 +568,7 @@ Just False -> char '-' BCCFAR cond blockid prediction - -> vcat [ + -> lines_ [ hcat [ text "\tb", pprCond (condNegate cond), @@ -579,7 +577,7 @@ ], hcat [ text "\tb\t", - pdoc platform lbl + pprAsmLabel platform lbl ] ] where lbl = mkLocalBlockLabel (getUnique blockid) @@ -592,15 +590,13 @@ -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL" | isForeignLabel lbl -> panic "PPC.Ppr.pprInstr: JMP to ForeignLabel" | otherwise -> - hcat [ -- an alias for b that takes a CLabel - char '\t', - text "b", - char '\t', - pdoc platform lbl + line $ hcat [ -- an alias for b that takes a CLabel + text "\tb\t", + pprAsmLabel platform lbl ] MTCTR reg - -> hcat [ + -> line $ hcat [ char '\t', text "mtctr", char '\t', @@ -608,7 +604,7 @@ ] BCTR _ _ _ - -> hcat [ + -> line $ hcat [ char '\t', text "bctr" ] @@ -625,18 +621,18 @@ -- but when profiling the codegen inserts calls via -- 'emitRtsCallGen' which are 'CmmLabel's even though -- they'd technically be more like 'ForeignLabel's. - hcat [ + line $ hcat [ text "\tbl\t.", - pdoc platform lbl + pprAsmLabel platform lbl ] _ -> - hcat [ + line $ hcat [ text "\tbl\t", - pdoc platform lbl + pprAsmLabel platform lbl ] BCTRL _ - -> hcat [ + -> line $ hcat [ char '\t', text "bctrl" ] @@ -645,7 +641,7 @@ -> pprLogic platform (text "add") reg1 reg2 ri ADDIS reg1 reg2 imm - -> hcat [ + -> line $ hcat [ char '\t', text "addis", char '\t', @@ -675,7 +671,7 @@ -> pprLogic platform (text "subfo") reg1 reg2 (RIReg reg3) SUBFC reg1 reg2 ri - -> hcat [ + -> line $ hcat [ char '\t', text "subf", case ri of @@ -696,7 +692,7 @@ -> pprMul platform fmt reg1 reg2 ri MULLO fmt reg1 reg2 reg3 - -> hcat [ + -> line $ hcat [ char '\t', text "mull", case fmt of @@ -713,13 +709,13 @@ MFOV fmt reg -> vcat [ - hcat [ + line $ hcat [ char '\t', text "mfxer", char '\t', pprReg reg ], - hcat [ + line $ hcat [ char '\t', text "extr", case fmt of @@ -739,7 +735,7 @@ ] MULHU fmt reg1 reg2 reg3 - -> hcat [ + -> line $ hcat [ char '\t', text "mulh", case fmt of @@ -760,7 +756,7 @@ -- for some reason, "andi" doesn't exist. -- we'll use "andi." instead. AND reg1 reg2 (RIImm imm) - -> hcat [ + -> line $ hcat [ char '\t', text "andi.", char '\t', @@ -787,7 +783,7 @@ -> pprLogic platform (text "xor") reg1 reg2 ri ORIS reg1 reg2 imm - -> hcat [ + -> line $ hcat [ char '\t', text "oris", char '\t', @@ -799,7 +795,7 @@ ] XORIS reg1 reg2 imm - -> hcat [ + -> line $ hcat [ char '\t', text "xoris", char '\t', @@ -811,7 +807,7 @@ ] EXTS fmt reg1 reg2 - -> hcat [ + -> line $ hcat [ char '\t', text "exts", pprFormat fmt, @@ -822,7 +818,7 @@ ] CNTLZ fmt reg1 reg2 - -> hcat [ + -> line $ hcat [ char '\t', text "cntlz", case fmt of @@ -883,7 +879,7 @@ in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri) RLWINM reg1 reg2 sh mb me - -> hcat [ + -> line $ hcat [ text "\trlwinm\t", pprReg reg1, text ", ", @@ -897,7 +893,7 @@ ] CLRLI fmt reg1 reg2 n - -> hcat [ + -> line $ hcat [ text "\tclrl", pprFormat fmt, text "i ", @@ -909,7 +905,7 @@ ] CLRRI fmt reg1 reg2 n - -> hcat [ + -> line $ hcat [ text "\tclrr", pprFormat fmt, text "i ", @@ -939,7 +935,7 @@ -> pprUnary (text "fneg") reg1 reg2 FCMP reg1 reg2 - -> hcat [ + -> line $ hcat [ char '\t', text "fcmpu\t0, ", -- Note: we're using fcmpu, not fcmpo @@ -967,7 +963,7 @@ -> pprUnary (text "frsp") reg1 reg2 CRNOR dst src1 src2 - -> hcat [ + -> line $ hcat [ text "\tcrnor\t", int dst, text ", ", @@ -977,7 +973,7 @@ ] MFCR reg - -> hcat [ + -> line $ hcat [ char '\t', text "mfcr", char '\t', @@ -985,7 +981,7 @@ ] MFLR reg - -> hcat [ + -> line $ hcat [ char '\t', text "mflr", char '\t', @@ -993,25 +989,25 @@ ] FETCHPC reg - -> vcat [ + -> lines_ [ text "\tbcl\t20,31,1f", hcat [ text "1:\tmflr\t", pprReg reg ] ] HWSYNC - -> text "\tsync" + -> line $ text "\tsync" ISYNC - -> text "\tisync" + -> line $ text "\tisync" LWSYNC - -> text "\tlwsync" + -> line $ text "\tlwsync" NOP - -> text "\tnop" + -> line $ text "\tnop" -pprLogic :: Platform -> SDoc -> Reg -> Reg -> RI -> SDoc -pprLogic platform op reg1 reg2 ri = hcat [ +pprLogic :: IsDoc doc => Platform -> Line doc -> Reg -> Reg -> RI -> doc +pprLogic platform op reg1 reg2 ri = line $ hcat [ char '\t', op, case ri of @@ -1026,8 +1022,8 @@ ] -pprMul :: Platform -> Format -> Reg -> Reg -> RI -> SDoc -pprMul platform fmt reg1 reg2 ri = hcat [ +pprMul :: IsDoc doc => Platform -> Format -> Reg -> Reg -> RI -> doc +pprMul platform fmt reg1 reg2 ri = line $ hcat [ char '\t', text "mull", case ri of @@ -1045,8 +1041,8 @@ ] -pprDiv :: Format -> Bool -> Reg -> Reg -> Reg -> SDoc -pprDiv fmt sgn reg1 reg2 reg3 = hcat [ +pprDiv :: IsDoc doc => Format -> Bool -> Reg -> Reg -> Reg -> doc +pprDiv fmt sgn reg1 reg2 reg3 = line $ hcat [ char '\t', text "div", case fmt of @@ -1063,8 +1059,8 @@ ] -pprUnary :: SDoc -> Reg -> Reg -> SDoc -pprUnary op reg1 reg2 = hcat [ +pprUnary :: IsDoc doc => Line doc -> Reg -> Reg -> doc +pprUnary op reg1 reg2 = line $ hcat [ char '\t', op, char '\t', @@ -1074,8 +1070,8 @@ ] -pprBinaryF :: SDoc -> Format -> Reg -> Reg -> Reg -> SDoc -pprBinaryF op fmt reg1 reg2 reg3 = hcat [ +pprBinaryF :: IsDoc doc => Line doc -> Format -> Reg -> Reg -> Reg -> doc +pprBinaryF op fmt reg1 reg2 reg3 = line $ hcat [ char '\t', op, pprFFormat fmt, @@ -1087,12 +1083,12 @@ pprReg reg3 ] -pprRI :: Platform -> RI -> SDoc +pprRI :: IsLine doc => Platform -> RI -> doc pprRI _ (RIReg r) = pprReg r pprRI platform (RIImm r) = pprImm platform r -pprFFormat :: Format -> SDoc +pprFFormat :: IsLine doc => Format -> doc pprFFormat FF64 = empty pprFFormat FF32 = char 's' pprFFormat _ = panic "PPC.Ppr.pprFFormat: no match" 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 @@ -47,6 +47,7 @@ where import GHC.Prelude +import GHC.Data.FastString import GHC.Platform.Reg import GHC.Platform.Reg.Class @@ -133,7 +134,7 @@ = ImmInt Int | ImmInteger Integer -- Sigh. | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLit SDoc -- Simple string + | ImmLit FastString | ImmIndex CLabel Int | ImmFloat Rational | ImmDouble Rational @@ -146,8 +147,8 @@ | HIGHESTA Imm -strImmLit :: String -> Imm -strImmLit s = ImmLit (text s) +strImmLit :: FastString -> Imm +strImmLit s = ImmLit s litToImm :: CmmLit -> Imm diff --git a/GHC/CmmToAsm/Ppr.hs b/GHC/CmmToAsm/Ppr.hs --- a/GHC/CmmToAsm/Ppr.hs +++ b/GHC/CmmToAsm/Ppr.hs @@ -27,7 +27,6 @@ import GHC.Cmm import GHC.CmmToAsm.Config import GHC.Utils.Outputable as SDoc -import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Panic import GHC.Platform @@ -89,7 +88,7 @@ -- Print as a string and escape non-printable characters. -- This is similar to charToC in GHC.Utils.Misc -pprASCII :: ByteString -> SDoc +pprASCII :: forall doc. IsLine doc => ByteString -> doc pprASCII str -- Transform this given literal bytestring to escaped string and construct -- the literal SDoc directly. @@ -98,19 +97,19 @@ -- -- We work with a `Doc` instead of an `SDoc` because there is no need to carry -- an `SDocContext` that we don't use. It leads to nicer (STG) code. - = docToSDoc (BS.foldr f Pretty.empty str) + = BS.foldr f empty str where - f :: Word8 -> Pretty.Doc -> Pretty.Doc - f w s = do1 w Pretty.<> s + f :: Word8 -> doc -> doc + f w s = do1 w <> s - do1 :: Word8 -> Pretty.Doc - do1 w | 0x09 == w = Pretty.text "\\t" - | 0x0A == w = Pretty.text "\\n" - | 0x22 == w = Pretty.text "\\\"" - | 0x5C == w = Pretty.text "\\\\" + do1 :: Word8 -> doc + do1 w | 0x09 == w = text "\\t" + | 0x0A == w = text "\\n" + | 0x22 == w = text "\\\"" + | 0x5C == w = text "\\\\" -- ASCII printable characters range - | w >= 0x20 && w <= 0x7E = Pretty.char (chr' w) - | otherwise = Pretty.sizedText 4 xs + | w >= 0x20 && w <= 0x7E = char (chr' w) + | otherwise = text xs where !xs = [ '\\', x0, x1, x2] -- octal !x0 = chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07) @@ -122,20 +121,25 @@ -- so we bypass the check in "chr" chr' :: Word8 -> Char chr' (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#))) - +{-# SPECIALIZE pprASCII :: ByteString -> SDoc #-} +{-# SPECIALIZE pprASCII :: ByteString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Emit a ".string" directive -pprString :: ByteString -> SDoc +pprString :: IsLine doc => ByteString -> doc pprString bs = text "\t.string " <> doubleQuotes (pprASCII bs) +{-# SPECIALIZE pprString :: ByteString -> SDoc #-} +{-# SPECIALIZE pprString :: ByteString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- | Emit a ".incbin" directive -- -- A NULL byte is added after the binary data. -pprFileEmbed :: FilePath -> SDoc +pprFileEmbed :: IsLine doc => FilePath -> doc pprFileEmbed path = text "\t.incbin " <> pprFilePathString path -- proper escape (see #16389) <> text "\n\t.byte 0" +{-# SPECIALIZE pprFileEmbed :: FilePath -> SDoc #-} +{-# SPECIALIZE pprFileEmbed :: FilePath -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable {- Note [Embedding large binary blobs] @@ -193,14 +197,16 @@ -- identical strings in the linker. With -split-sections each string also gets -- a unique section to allow strings from unused code to be GC'd. -pprSectionHeader :: NCGConfig -> Section -> SDoc +pprSectionHeader :: IsLine doc => NCGConfig -> Section -> doc pprSectionHeader config (Section t suffix) = case platformOS (ncgPlatform config) of OSAIX -> pprXcoffSectionHeader t OSDarwin -> pprDarwinSectionHeader t _ -> pprGNUSectionHeader config t suffix +{-# SPECIALIZE pprSectionHeader :: NCGConfig -> Section -> SDoc #-} +{-# SPECIALIZE pprSectionHeader :: NCGConfig -> Section -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc +pprGNUSectionHeader :: IsLine doc => NCGConfig -> SectionType -> CLabel -> doc pprGNUSectionHeader config t suffix = hcat [text ".section ", header, subsection, flags] where @@ -210,7 +216,7 @@ platform = ncgPlatform config splitSections = ncgSplitSections config subsection - | splitSections = sep <> pdoc platform suffix + | splitSections = sep <> pprAsmLabel platform suffix | otherwise = empty header = case t of Text -> text ".text" @@ -224,9 +230,6 @@ -> text ".rdata$rel.ro" | otherwise -> text ".data.rel.ro" UninitialisedData -> text ".bss" - ReadOnlyData16 | OSMinGW32 <- platformOS platform - -> text ".rdata$cst16" - | otherwise -> text ".rodata.cst16" InitArray | OSMinGW32 <- platformOS platform -> text ".ctors" @@ -242,39 +245,38 @@ OtherSection _ -> panic "PprBase.pprGNUSectionHeader: unknown section type" flags = case t of - Text - | OSMinGW32 <- platformOS platform, splitSections - -> text ",\"xr\"" - | splitSections - -> text ",\"ax\"," <> sectionType platform "progbits" CString | OSMinGW32 <- platformOS platform -> empty | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1" _ -> empty +{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc #-} +{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- XCOFF doesn't support relocating label-differences, so we place all -- RO sections into .text[PR] sections -pprXcoffSectionHeader :: SectionType -> SDoc +pprXcoffSectionHeader :: IsLine doc => SectionType -> doc pprXcoffSectionHeader t = case t of Text -> text ".csect .text[PR]" Data -> text ".csect .data[RW]" ReadOnlyData -> text ".csect .text[PR] # ReadOnlyData" RelocatableReadOnlyData -> text ".csect .text[PR] # RelocatableReadOnlyData" - ReadOnlyData16 -> text ".csect .text[PR] # ReadOnlyData16" CString -> text ".csect .text[PR] # CString" UninitialisedData -> text ".csect .data[BS]" _ -> panic "pprXcoffSectionHeader: unknown section type" +{-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> SDoc #-} +{-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprDarwinSectionHeader :: SectionType -> SDoc +pprDarwinSectionHeader :: IsLine doc => SectionType -> doc pprDarwinSectionHeader t = case t of Text -> text ".text" Data -> text ".data" ReadOnlyData -> text ".const" RelocatableReadOnlyData -> text ".const_data" UninitialisedData -> text ".data" - ReadOnlyData16 -> text ".const" InitArray -> text ".section\t__DATA,__mod_init_func,mod_init_funcs" FiniArray -> panic "pprDarwinSectionHeader: fini not supported" CString -> text ".section\t__TEXT,__cstring,cstring_literals" OtherSection _ -> panic "pprDarwinSectionHeader: unknown section type" +{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> SDoc #-} +{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable 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 @@ -355,8 +355,8 @@ in graph2 --- | Add some coalesence edges to the graph --- Coalesences between virtual and real regs are recorded as preferences. +-- | Add some coalescence edges to the graph +-- Coalescences between virtual and real regs are recorded as preferences. graphAddCoalesce :: (Reg, Reg) -> Color.Graph VirtualReg RegClass RealReg 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 @@ -104,12 +104,12 @@ regsC = regsOfClass classC -- all the possible subsets of c which have size < m - regsS = filter (\s -> sizeUniqSet s >= 1 + regsS = filter (\s -> not (isEmptyUniqSet s) && sizeUniqSet s <= neighbors) $ powersetLS regsC -- for each of the subsets of C, the regs which conflict - -- with posiblities for N + -- with possibilities for N regsS_conflict = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS 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 @@ -147,8 +147,7 @@ $ mapLookup blockId slotMap moreSlotsLive = IntSet.fromList - $ catMaybes - $ map (lookupUFM regSlotMap) + $ mapMaybe (lookupUFM regSlotMap) $ nonDetEltsUniqSet regsLive -- See Note [Unique Determinism and code generation] 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 @@ -390,8 +390,7 @@ = do let slotsReloadedByTargets = IntSet.unions - $ catMaybes - $ map (flip mapLookup liveSlotsOnEntry) + $ mapMaybe (flip mapLookup liveSlotsOnEntry) $ targets let noReloads' 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 @@ -130,8 +130,8 @@ -- Increment counts for what regs were read/written from. let (RU read written) = regUsageOfInstr platform instr - mapM_ (incUses scale) $ catMaybes $ map takeVirtualReg $ nub read - mapM_ (incDefs scale) $ catMaybes $ map takeVirtualReg $ nub written + mapM_ (incUses scale) $ mapMaybe takeVirtualReg $ nub read + mapM_ (incDefs scale) $ mapMaybe takeVirtualReg $ nub written -- Compute liveness for entry to next instruction. let liveDieRead_virt = takeVirtuals (liveDieRead live) 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 @@ -116,7 +116,9 @@ 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) @@ -140,7 +142,7 @@ ArchPPC -> 0 ArchPPC_64 _ -> 0 ArchARM _ _ _ -> panic "trivColorable ArchARM" - -- we can in princple address all the float regs as + -- 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 @@ -149,7 +151,9 @@ 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) @@ -181,7 +185,9 @@ 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) 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 @@ -224,7 +224,9 @@ ArchMipseb -> panic "linearRegAlloc ArchMipseb" ArchMipsel -> panic "linearRegAlloc ArchMipsel" ArchRISCV64 -> panic "linearRegAlloc ArchRISCV64" + ArchLoongArch64-> panic "linearRegAlloc ArchLoongArch64" ArchJavaScript -> panic "linearRegAlloc ArchJavaScript" + ArchWasm32 -> panic "linearRegAlloc ArchWasm32" ArchUnknown -> panic "linearRegAlloc ArchUnknown" where go :: (FR regs, Outputable regs) @@ -595,7 +597,7 @@ -- we need to ensure they are emitted in the correct order. We used to only -- emit single instructions in mkSpill/mkReload/mkRegRegMove. -- As such order of spills and reloads didn't matter. However, with - -- mutliple instructions potentially issued by those functions we need to be + -- multiple instructions potentially issued by those functions we need to be -- careful to not break execution order. Reversing the spills (clobber will -- also spill), will ensure they are emitted in the right order. -- @@ -618,7 +620,7 @@ ] -- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do --- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do +-- pprTrace "patched-fixup" ((ppr fixup_blocks)) $ do return (code, fixup_blocks) 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 @@ -35,7 +35,7 @@ -- | - Operates on 32-bit | - Separate reg. bank, | - Separate reg. bank, | -- | GP ARM registers | 32x64-bit NEON regs | 32x128-bit NEON regs | -- | - 8-bit/16-bit integer | - 8/16/32/64-bit int | - 8/16/32/64-bit int | --- | | - Single percision fp | - Single percision fp | +-- | | - Single precision fp | - Single precision fp | -- | | | - Double precision fp | -- | | | - Single/Double fp are | -- | | | IEEE compliant | 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 @@ -77,5 +77,7 @@ ArchMipseb -> panic "maxSpillSlots ArchMipseb" ArchMipsel -> panic "maxSpillSlots ArchMipsel" ArchRISCV64 -> panic "maxSpillSlots ArchRISCV64" + ArchLoongArch64->panic "maxSpillSlots ArchLoongArch64" 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 @@ -31,6 +31,8 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set +import GHC.Utils.Outputable + -- | For a jump instruction at the end of a block, generate fixup code so its -- vregs are in the correct regs for its destination. -- @@ -375,6 +377,5 @@ -- we don't handle memory to memory moves. -- they shouldn't happen because we don't share -- stack slots between vregs. - panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" - ++ show dst ++ ")" - ++ " we don't handle mem->mem moves.") + pprPanic "makeMove: we don't handle mem->mem moves" + (ppr vreg <+> parens (ppr src) <+> parens (ppr dst)) 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 @@ -67,7 +67,7 @@ import GHC.Data.Bag import GHC.Utils.Monad.State.Strict -import Data.List (mapAccumL, groupBy, partition) +import Data.List (mapAccumL, partition) import Data.Maybe import Data.IntSet (IntSet) @@ -911,13 +911,11 @@ -> a -> b -> (a,c) - iterateUntilUnchanged f eq a b - = head $ - concatMap tail $ - groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ - iterate (\(a, _) -> f a b) $ - (a, panic "RegLiveness.livenessSCCs") - + iterateUntilUnchanged f eq aa b = go aa + where + go a = if eq a a' then ac else go a' + where + ac@(a', _) = f a b linearLiveness :: Instruction instr 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 @@ -50,7 +50,9 @@ ArchMipseb -> panic "targetVirtualRegSqueeze ArchMipseb" ArchMipsel -> panic "targetVirtualRegSqueeze ArchMipsel" ArchRISCV64 -> panic "targetVirtualRegSqueeze ArchRISCV64" + ArchLoongArch64->panic "targetVirtualRegSqueeze ArchLoongArch64" ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript" + ArchWasm32 -> panic "targetVirtualRegSqueeze ArchWasm32" ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" @@ -68,7 +70,9 @@ ArchMipseb -> panic "targetRealRegSqueeze ArchMipseb" ArchMipsel -> panic "targetRealRegSqueeze ArchMipsel" ArchRISCV64 -> panic "targetRealRegSqueeze ArchRISCV64" + ArchLoongArch64->panic "targetRealRegSqueeze ArchLoongArch64" ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript" + ArchWasm32 -> panic "targetRealRegSqueeze ArchWasm32" ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" targetClassOfRealReg :: Platform -> RealReg -> RegClass @@ -85,7 +89,9 @@ ArchMipseb -> panic "targetClassOfRealReg ArchMipseb" ArchMipsel -> panic "targetClassOfRealReg ArchMipsel" ArchRISCV64 -> panic "targetClassOfRealReg ArchRISCV64" + ArchLoongArch64->panic "targetClassOfRealReg ArchLoongArch64" ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript" + ArchWasm32 -> panic "targetClassOfRealReg ArchWasm32" ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" targetMkVirtualReg :: Platform -> Unique -> Format -> VirtualReg @@ -102,7 +108,9 @@ ArchMipseb -> panic "targetMkVirtualReg ArchMipseb" ArchMipsel -> panic "targetMkVirtualReg ArchMipsel" ArchRISCV64 -> panic "targetMkVirtualReg ArchRISCV64" + ArchLoongArch64->panic "targetMkVirtualReg ArchLoongArch64" ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript" + ArchWasm32 -> panic "targetMkVirtualReg ArchWasm32" ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" targetRegDotColor :: Platform -> RealReg -> SDoc @@ -119,7 +127,9 @@ ArchMipseb -> panic "targetRegDotColor ArchMipseb" ArchMipsel -> panic "targetRegDotColor ArchMipsel" ArchRISCV64 -> panic "targetRegDotColor ArchRISCV64" + ArchLoongArch64->panic "targetRegDotColor ArchLoongArch64" ArchJavaScript-> panic "targetRegDotColor ArchJavaScript" + ArchWasm32 -> panic "targetRegDotColor ArchWasm32" ArchUnknown -> panic "targetRegDotColor ArchUnknown" diff --git a/GHC/CmmToAsm/Wasm.hs b/GHC/CmmToAsm/Wasm.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Wasm.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +module GHC.CmmToAsm.Wasm (ncgWasm) where + +import Data.ByteString.Builder +import Data.Maybe +import Data.Semigroup +import GHC.Cmm +import GHC.CmmToAsm.Wasm.Asm +import GHC.CmmToAsm.Wasm.FromCmm +import GHC.CmmToAsm.Wasm.Types +import GHC.Data.Stream (Stream, StreamS (..), runStream) +import GHC.Platform +import GHC.Prelude +import GHC.Settings +import GHC.Types.Unique.Supply +import GHC.Unit +import GHC.Utils.CliOption +import System.IO + +ncgWasm :: + 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 + pure r + where + -- See Note [WasmTailCall] + do_tail_call = doTailCall ts + +streamCmmGroups :: + Platform -> + UniqSupply -> + Stream IO RawCmmGroup a -> + IO (a, WasmCodeGenState 'I32) +streamCmmGroups platform us cmms = + go (initialWasmCodeGenState platform us) $ + runStream cmms + 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 + +doTailCall :: ToolSettings -> Bool +doTailCall ts = Option "-mtail-call" `elem` as_args + where + (_, as_args) = toolSettings_pgm_a ts diff --git a/GHC/CmmToAsm/Wasm/Asm.hs b/GHC/CmmToAsm/Wasm/Asm.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Wasm/Asm.hs @@ -0,0 +1,538 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Strict #-} + +module GHC.CmmToAsm.Wasm.Asm (asmTellEverything, execWasmAsmM) where + +import Control.Monad +import Control.Monad.Trans.Reader +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Builder +import Data.Coerce +import Data.Foldable +import qualified Data.IntSet as IS +import Data.Maybe +import Data.Semigroup +import GHC.Cmm +import GHC.CmmToAsm.Ppr +import GHC.CmmToAsm.Wasm.FromCmm +import GHC.CmmToAsm.Wasm.Types +import GHC.CmmToAsm.Wasm.Utils +import GHC.Data.FastString +import GHC.Float +import GHC.Prelude +import GHC.Types.Basic +import GHC.Types.Unique +import GHC.Types.Unique.Map +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) + deriving + ( Functor, + Applicative, + Monad + ) + via (ReaderT Bool (ReaderT Builder (State Builder))) + +instance Semigroup a => Semigroup (WasmAsmM a) where + (<>) = liftA2 (<>) + +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 + +-- | Default indent level is none +execWasmAsmM :: Bool -> WasmAsmM a -> Builder +execWasmAsmM do_tail_call (WasmAsmM m) = + execState (m do_tail_call 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 + +-- | Writes a single line starting with the current indent +asmTellLine :: Builder -> WasmAsmM () +asmTellLine b = WasmAsmM $ \_ t -> modify $ \acc -> acc <> t <> b <> char7 '\n' + +-- | Writes a single line break +asmTellLF :: WasmAsmM () +asmTellLF = WasmAsmM $ \_ _ -> modify $ \acc -> acc <> char7 '\n' + +-- | Writes a line starting with a single tab, ignoring current indent +-- level +asmTellTabLine :: Builder -> WasmAsmM () +asmTellTabLine b = + WasmAsmM $ \_ _ -> modify $ \acc -> acc <> char7 '\t' <> b <> char7 '\n' + +asmFromWasmType :: WasmTypeTag t -> Builder +asmFromWasmType ty = case ty of + TagI32 -> "i32" + TagI64 -> "i64" + TagF32 -> "f32" + TagF64 -> "f64" + +asmFromSomeWasmType :: SomeWasmType -> Builder +asmFromSomeWasmType (SomeWasmType t) = asmFromWasmType t + +asmFromSomeWasmTypes :: [SomeWasmType] -> Builder +asmFromSomeWasmTypes ts = "(" <> builderCommas asmFromSomeWasmType ts <> ")" + +asmFromFuncType :: [SomeWasmType] -> [SomeWasmType] -> Builder +asmFromFuncType arg_tys ret_tys = + asmFromSomeWasmTypes arg_tys <> " -> " <> asmFromSomeWasmTypes ret_tys + +asmTellFuncType :: + SymName -> ([SomeWasmType], [SomeWasmType]) -> WasmAsmM () +asmTellFuncType sym (arg_tys, ret_tys) = + asmTellTabLine $ + ".functype " + <> asmFromSymName sym + <> " " + <> asmFromFuncType arg_tys ret_tys + +asmTellLocals :: [SomeWasmType] -> WasmAsmM () +asmTellLocals [] = mempty +asmTellLocals local_tys = + asmTellTabLine $ ".local " <> builderCommas asmFromSomeWasmType local_tys + +asmFromSymName :: SymName -> Builder +asmFromSymName = shortByteString . coerce fastStringToShortByteString + +asmTellDefSym :: SymName -> WasmAsmM () +asmTellDefSym sym = do + asmTellTabLine $ ".hidden " <> asm_sym + asmTellTabLine $ ".globl " <> asm_sym + where + asm_sym = asmFromSymName sym + +asmTellDataSectionContent :: WasmTypeTag w -> DataSectionContent -> WasmAsmM () +asmTellDataSectionContent ty_word c = asmTellTabLine $ case c of + DataI8 i -> ".int8 0x" <> word8Hex i + DataI16 i -> ".int16 0x" <> word16Hex i + DataI32 i -> ".int32 0x" <> word32Hex i + DataI64 i -> ".int64 0x" <> word64Hex i + DataF32 f -> ".int32 0x" <> word32Hex (castFloatToWord32 f) + DataF64 d -> ".int64 0x" <> word64Hex (castDoubleToWord64 d) + DataSym sym o -> + ( case ty_word of + TagI32 -> ".int32 " + TagI64 -> ".int64 " + _ -> panic "asmTellDataSectionContent: unreachable" + ) + <> asmFromSymName sym + <> ( case compare o 0 of + EQ -> mempty + GT -> "+" <> intDec o + LT -> intDec o + ) + DataSkip i -> ".skip " <> intDec i + DataASCII s + | not (BS.null s) && BS.last s == 0 -> + ".asciz \"" + <> string7 + (showSDocOneLine defaultSDocContext $ pprASCII $ BS.init s) + <> "\"" + | otherwise -> + ".ascii \"" + <> string7 + (showSDocOneLine defaultSDocContext $ pprASCII s) + <> "\"" + DataIncBin f _ -> + ".incbin " + <> string7 + (showSDocOneLine defaultSDocContext $ pprFilePathString f) + +dataSectionContentSize :: WasmTypeTag w -> DataSectionContent -> Int +dataSectionContentSize ty_word c = case c of + DataI8 {} -> 1 + DataI16 {} -> 2 + DataI32 {} -> 4 + DataI64 {} -> 8 + DataF32 {} -> 4 + DataF64 {} -> 8 + DataSym {} -> alignmentBytes $ alignmentFromWordType ty_word + DataSkip i -> i + DataASCII s -> BS.length s + DataIncBin _ l -> l + +dataSectionSize :: WasmTypeTag w -> [DataSectionContent] -> Int +dataSectionSize ty_word = + coerce + . foldMap' + (Sum . dataSectionContentSize ty_word) + +asmTellAlign :: Alignment -> WasmAsmM () +asmTellAlign a = case alignmentBytes a of + 1 -> mempty + i -> asmTellTabLine $ ".p2align " <> intDec (countTrailingZeros i) + +asmTellSectionHeader :: Builder -> WasmAsmM () +asmTellSectionHeader k = asmTellTabLine $ ".section " <> k <> ",\"\",@" + +asmTellDataSection :: + WasmTypeTag w -> IS.IntSet -> SymName -> DataSection -> WasmAsmM () +asmTellDataSection ty_word def_syms sym DataSection {..} = do + when (getKey (getUnique sym) `IS.member` def_syms) $ asmTellDefSym sym + asmTellSectionHeader sec_name + asmTellAlign dataSectionAlignment + asmTellTabLine asm_size + asmTellLine $ asm_sym <> ":" + for_ dataSectionContents $ asmTellDataSectionContent ty_word + asmTellLF + where + asm_sym = asmFromSymName sym + + sec_name = + ( case dataSectionKind of + SectionData -> ".data." + SectionROData -> ".rodata." + ) + <> asm_sym + + asm_size = + ".size " + <> asm_sym + <> ", " + <> intDec + (dataSectionSize ty_word dataSectionContents) + +asmFromWasmBlockType :: WasmTypeTag w -> WasmFunctionType pre post -> Builder +asmFromWasmBlockType + _ + (WasmFunctionType {ft_pops = TypeListNil, ft_pushes = TypeListNil}) = + mempty +asmFromWasmBlockType + TagI32 + ( WasmFunctionType + { ft_pops = TypeListNil, + ft_pushes = TypeListCons TagI32 TypeListNil + } + ) = + " i32" +asmFromWasmBlockType + TagI64 + ( WasmFunctionType + { ft_pops = TypeListNil, + ft_pushes = TypeListCons TagI64 TypeListNil + } + ) = + " i64" +asmFromWasmBlockType _ _ = panic "asmFromWasmBlockType: invalid block type" + +asmFromAlignmentSpec :: AlignmentSpec -> Builder +asmFromAlignmentSpec NaturallyAligned = mempty +asmFromAlignmentSpec Unaligned = ":p2align=0" + +asmTellWasmInstr :: WasmTypeTag w -> WasmInstr w pre post -> WasmAsmM () +asmTellWasmInstr ty_word instr = case instr of + WasmComment c -> asmTellLine $ stringUtf8 $ "# " <> c + WasmNop -> mempty + WasmDrop -> asmTellLine "drop" + WasmUnreachable -> asmTellLine "unreachable" + 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 + WasmLoad ty (Just w) s o align -> + asmTellLine $ + asmFromWasmType ty + <> ".load" + <> intDec w + <> ( case s of + Signed -> "_s" + Unsigned -> "_u" + ) + <> " " + <> intDec o + <> asmFromAlignmentSpec align + WasmLoad ty Nothing _ o align -> + asmTellLine $ + asmFromWasmType ty + <> ".load" + <> " " + <> intDec o + <> asmFromAlignmentSpec align + WasmStore ty (Just w) o align -> + asmTellLine $ + asmFromWasmType ty + <> ".store" + <> intDec w + <> " " + <> intDec o + <> asmFromAlignmentSpec align + WasmStore ty Nothing o align -> + asmTellLine $ + asmFromWasmType ty + <> ".store" + <> " " + <> intDec o + <> asmFromAlignmentSpec align + WasmGlobalGet _ sym -> asmTellLine $ "global.get " <> asmFromSymName sym + WasmGlobalSet _ sym -> asmTellLine $ "global.set " <> asmFromSymName sym + WasmLocalGet _ i -> asmTellLine $ "local.get " <> intDec i + WasmLocalSet _ i -> asmTellLine $ "local.set " <> intDec i + WasmLocalTee _ i -> asmTellLine $ "local.tee " <> intDec i + WasmCCall sym -> asmTellLine $ "call " <> asmFromSymName sym + WasmCCallIndirect arg_tys ret_tys -> + asmTellLine $ + "call_indirect " + <> asmFromFuncType + (someWasmTypesFromTypeList arg_tys) + (someWasmTypesFromTypeList ret_tys) + WasmConcat instr0 instr1 -> do + asmTellWasmInstr ty_word instr0 + asmTellWasmInstr ty_word instr1 + WasmReinterpret t0 t1 -> + asmTellLine $ + asmFromWasmType t1 <> ".reinterpret_" <> asmFromWasmType t0 + WasmTruncSat Signed t0 t1 -> + asmTellLine $ + asmFromWasmType t1 <> ".trunc_sat_" <> asmFromWasmType t0 <> "_s" + WasmTruncSat Unsigned t0 t1 -> + asmTellLine $ + asmFromWasmType t1 <> ".trunc_sat_" <> asmFromWasmType t0 <> "_u" + WasmConvert Signed t0 t1 -> + asmTellLine $ + asmFromWasmType t1 <> ".convert_" <> asmFromWasmType t0 <> "_s" + WasmConvert Unsigned t0 t1 -> + asmTellLine $ + asmFromWasmType t1 <> ".convert_" <> asmFromWasmType t0 <> "_u" + WasmAdd ty -> asmTellLine $ asmFromWasmType ty <> ".add" + WasmSub ty -> asmTellLine $ asmFromWasmType ty <> ".sub" + WasmMul ty -> asmTellLine $ asmFromWasmType ty <> ".mul" + WasmDiv _ TagF32 -> asmTellLine "f32.div" + WasmDiv _ TagF64 -> asmTellLine "f64.div" + WasmDiv Signed ty -> asmTellLine $ asmFromWasmType ty <> ".div_s" + WasmDiv Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".div_u" + WasmRem Signed ty -> asmTellLine $ asmFromWasmType ty <> ".rem_s" + WasmRem Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".rem_u" + WasmAnd ty -> asmTellLine $ asmFromWasmType ty <> ".and" + WasmOr ty -> asmTellLine $ asmFromWasmType ty <> ".or" + WasmXor ty -> asmTellLine $ asmFromWasmType ty <> ".xor" + WasmEq ty -> asmTellLine $ asmFromWasmType ty <> ".eq" + WasmNe ty -> asmTellLine $ asmFromWasmType ty <> ".ne" + WasmLt _ TagF32 -> asmTellLine "f32.lt" + WasmLt _ TagF64 -> asmTellLine "f64.lt" + WasmLt Signed ty -> asmTellLine $ asmFromWasmType ty <> ".lt_s" + WasmLt Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".lt_u" + WasmGt _ TagF32 -> asmTellLine "f32.gt" + WasmGt _ TagF64 -> asmTellLine "f64.gt" + WasmGt Signed ty -> asmTellLine $ asmFromWasmType ty <> ".gt_s" + WasmGt Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".gt_u" + WasmLe _ TagF32 -> asmTellLine "f32.le" + WasmLe _ TagF64 -> asmTellLine "f64.le" + WasmLe Signed ty -> asmTellLine $ asmFromWasmType ty <> ".le_s" + WasmLe Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".le_u" + WasmGe _ TagF32 -> asmTellLine "f32.ge" + WasmGe _ TagF64 -> asmTellLine "f64.ge" + WasmGe Signed ty -> asmTellLine $ asmFromWasmType ty <> ".ge_s" + WasmGe Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".ge_u" + WasmShl ty -> asmTellLine $ asmFromWasmType ty <> ".shl" + WasmShr Signed ty -> asmTellLine $ asmFromWasmType ty <> ".shr_s" + WasmShr Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".shr_u" + WasmI32Extend8S -> asmTellLine "i32.extend8_s" + WasmI32Extend16S -> asmTellLine "i32.extend16_s" + WasmI64Extend8S -> asmTellLine "i64.extend8_s" + WasmI64Extend16S -> asmTellLine "i64.extend16_s" + WasmI64Extend32S -> asmTellLine "i64.extend32_s" + WasmI64ExtendI32 Signed -> asmTellLine "i64.extend_i32_s" + WasmI64ExtendI32 Unsigned -> asmTellLine "i64.extend_i32_u" + WasmI32WrapI64 -> asmTellLine "i32.wrap_i64" + WasmF32DemoteF64 -> asmTellLine "f32.demote_f64" + WasmF64PromoteF32 -> asmTellLine "f64.promote_f32" + WasmAbs ty -> asmTellLine $ asmFromWasmType ty <> ".abs" + WasmNeg ty -> asmTellLine $ asmFromWasmType ty <> ".neg" + WasmCond t -> do + asmTellLine "if" + asmWithTab $ asmTellWasmInstr ty_word t + asmTellLine "end_if" + +asmTellWasmControl :: + WasmTypeTag w -> + WasmControl + (WasmStatements w) + (WasmExpr w a) + pre + post -> + WasmAsmM () +asmTellWasmControl ty_word c = case c of + WasmPush _ (WasmExpr e) -> asmTellWasmInstr ty_word e + WasmBlock bt c -> do + asmTellLine $ "block" <> asmFromWasmBlockType ty_word bt + asmWithTab $ asmTellWasmControl ty_word c + asmTellLine "end_block" + WasmLoop bt c -> do + asmTellLine $ "loop" <> asmFromWasmBlockType ty_word bt + asmWithTab $ asmTellWasmControl ty_word c + asmTellLine "end_loop" + WasmIfTop bt t f -> do + asmTellLine $ "if" <> asmFromWasmBlockType ty_word bt + asmWithTab $ asmTellWasmControl ty_word t + asmTellLine "else" + asmWithTab $ asmTellWasmControl ty_word f + asmTellLine "end_if" + WasmBr i -> asmTellLine $ "br " <> intDec i + WasmFallthrough -> mempty + WasmBrTable (WasmExpr e) _ ts t -> do + asmTellWasmInstr ty_word e + asmTellLine $ "br_table {" <> builderCommas intDec (ts <> [t]) <> "}" + -- See Note [WasmTailCall] + WasmTailCall (WasmExpr e) -> do + do_tail_call <- doTailCall + if + | do_tail_call, + WasmSymConst sym <- e -> + asmTellLine $ "return_call " <> asmFromSymName sym + | do_tail_call -> + do + asmTellWasmInstr ty_word e + asmTellLine $ + "return_call_indirect " + <> asmFromFuncType + [] + [SomeWasmType ty_word] + | otherwise -> + do + asmTellWasmInstr ty_word e + asmTellLine "return" + WasmActions (WasmStatements a) -> asmTellWasmInstr ty_word a + WasmSeq c0 c1 -> do + asmTellWasmControl ty_word c0 + asmTellWasmControl ty_word c1 + +asmTellFunc :: + WasmTypeTag w -> + IS.IntSet -> + SymName -> + (([SomeWasmType], [SomeWasmType]), FuncBody w) -> + WasmAsmM () +asmTellFunc ty_word def_syms sym (func_ty, FuncBody {..}) = do + when (getKey (getUnique sym) `IS.member` def_syms) $ asmTellDefSym sym + asmTellSectionHeader $ ".text." <> asm_sym + asmTellLine $ asm_sym <> ":" + asmTellFuncType sym func_ty + asmTellLocals funcLocals + asmWithTab $ asmTellWasmControl ty_word funcBody + asmTellTabLine "end_function" + asmTellLF + where + asm_sym = asmFromSymName sym + +asmTellGlobals :: WasmTypeTag w -> WasmAsmM () +asmTellGlobals ty_word = do + for_ supportedCmmGlobalRegs $ \reg -> + let (sym, ty) = fromJust $ globalInfoFromCmmGlobalReg ty_word reg + in asmTellTabLine $ + ".globaltype " + <> asmFromSymName sym + <> ", " + <> asmFromSomeWasmType ty + asmTellLF + +asmTellCtors :: WasmTypeTag w -> [SymName] -> WasmAsmM () +asmTellCtors _ [] = mempty +asmTellCtors ty_word syms = do + asmTellSectionHeader ".init_array" + asmTellAlign $ alignmentFromWordType ty_word + for_ syms $ \sym -> + asmTellTabLine $ + ( case ty_word of + TagI32 -> ".int32 " + TagI64 -> ".int64 " + _ -> panic "asmTellCtors: unreachable" + ) + <> asmFromSymName sym + asmTellLF + +asmTellBS :: ByteString -> WasmAsmM () +asmTellBS s = do + asmTellTabLine $ ".int8 " <> intDec (BS.length s) + asmTellTabLine $ + ".ascii \"" + <> string7 + (showSDocOneLine defaultSDocContext $ pprASCII s) + <> "\"" + +asmTellVec :: [WasmAsmM ()] -> WasmAsmM () +asmTellVec xs = do + asmTellTabLine $ ".int8 " <> intDec (length xs) + sequence_ xs + +asmTellProducers :: WasmAsmM () +asmTellProducers = do + asmTellSectionHeader ".custom_section.producers" + asmTellVec + [ do + asmTellBS "processed-by" + asmTellVec + [ do + asmTellBS "ghc" + asmTellBS "9.6" + ] + ] + +asmTellTargetFeatures :: WasmAsmM () +asmTellTargetFeatures = do + do_tail_call <- doTailCall + asmTellSectionHeader ".custom_section.target_features" + asmTellVec + [ do + asmTellTabLine ".int8 0x2b" + asmTellBS feature + | feature <- + ["tail-call" | do_tail_call] + <> [ "bulk-memory", + "mutable-globals", + "nontrapping-fptoint", + "reference-types", + "sign-ext" + ] + ] + +asmTellEverything :: WasmTypeTag w -> WasmCodeGenState w -> WasmAsmM () +asmTellEverything ty_word WasmCodeGenState {..} = do + asmTellGlobals ty_word + asm_functypes + asm_funcs + asm_data_secs + asm_ctors + asmTellProducers + asmTellTargetFeatures + where + asm_functypes = do + for_ + (detEltsUniqMap $ funcTypes `minusUniqMap` funcBodies) + (uncurry asmTellFuncType) + asmTellLF + + asm_funcs = do + for_ + (detEltsUniqMap $ intersectUniqMap_C (,) funcTypes funcBodies) + (uncurry $ asmTellFunc ty_word defaultSyms) + asmTellLF + + asm_data_secs = do + for_ + (detEltsUniqMap dataSections) + (uncurry (asmTellDataSection ty_word defaultSyms)) + asmTellLF + + asm_ctors = asmTellCtors ty_word ctors diff --git a/GHC/CmmToAsm/Wasm/FromCmm.hs b/GHC/CmmToAsm/Wasm/FromCmm.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Wasm/FromCmm.hs @@ -0,0 +1,1686 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use camelCase" #-} +module GHC.CmmToAsm.Wasm.FromCmm + ( alignmentFromWordType, + globalInfoFromCmmGlobalReg, + supportedCmmGlobalRegs, + onCmmGroup, + ) +where + +import Control.Monad +import qualified Data.ByteString as BS +import Data.Foldable +import Data.Functor +import qualified Data.IntSet as IS +import Data.Semigroup +import Data.String +import Data.Traversable +import Data.Type.Equality +import GHC.Cmm +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Label +import GHC.Cmm.InitFini +import GHC.CmmToAsm.Wasm.Types +import GHC.CmmToAsm.Wasm.Utils +import GHC.Float +import GHC.Platform +import GHC.Prelude +import GHC.StgToCmm.CgUtils +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Utils.Panic +import GHC.Wasm.ControlFlow.FromCmm + +-- | Calculate the wasm representation type from a 'CmmType'. This is +-- a lossy conversion, and sometimes we need to pass the original +-- 'CmmType' or at least its 'Width' around, so to properly add +-- subword truncation or extension logic. +someWasmTypeFromCmmType :: CmmType -> SomeWasmType +someWasmTypeFromCmmType t + | isWord32 t = SomeWasmType TagI32 + | isWord64 t = SomeWasmType TagI64 + | t `cmmEqType` b16 = SomeWasmType TagI32 + | t `cmmEqType` b8 = SomeWasmType TagI32 + | isFloat64 t = SomeWasmType TagF64 + | isFloat32 t = SomeWasmType TagF32 + | otherwise = + panic $ + "someWasmTypeFromCmmType: unsupported CmmType " + <> showSDocOneLine defaultSDocContext (ppr t) + +-- | Calculate the optional memory narrowing of a 'CmmLoad' or +-- 'CmmStore'. +wasmMemoryNarrowing :: WasmTypeTag t -> CmmType -> Maybe Int +wasmMemoryNarrowing ty ty_cmm = case (# ty, typeWidth ty_cmm #) of + (# TagI32, W8 #) -> Just 8 + (# TagI32, W16 #) -> Just 16 + (# TagI32, W32 #) -> Nothing + (# TagI64, W8 #) -> Just 8 + (# TagI64, W16 #) -> Just 16 + (# TagI64, W32 #) -> Just 32 + (# TagI64, W64 #) -> Nothing + (# TagF32, W32 #) -> Nothing + (# TagF64, W64 #) -> Nothing + _ -> panic "wasmMemoryNarrowing: unreachable" + +-- | Despite this is used by the WebAssembly native codegen, we use +-- 'pprCLabel' instead of 'pprAsmLabel' when emitting the textual +-- symbol name. Either one would work, but 'pprCLabel' makes the +-- output assembly code looks closer to the unregisterised codegen +-- output, which can be handy when using the unregisterised codegen as +-- a source of truth when debugging the native codegen. +symNameFromCLabel :: CLabel -> SymName +symNameFromCLabel lbl = + fromString $ + showSDocOneLine defaultSDocContext {sdocStyle = PprCode} $ + pprCLabel genericPlatform lbl + +-- | Calculate a symbol's visibility. +symVisibilityFromCLabel :: CLabel -> SymVisibility +symVisibilityFromCLabel lbl + | externallyVisibleCLabel lbl = SymDefault + | otherwise = SymStatic + +-- | Calculate a symbol's kind, see haddock docs of 'SymKind' for more +-- explanation. +symKindFromCLabel :: CLabel -> SymKind +symKindFromCLabel lbl + | isCFunctionLabel lbl = SymFunc + | otherwise = SymData + +-- | Calculate a data section's kind, see haddock docs of +-- 'DataSectionKind' for more explanation. +dataSectionKindFromCmmSection :: Section -> DataSectionKind +dataSectionKindFromCmmSection s = case sectionProtection s of + ReadWriteSection -> SectionData + _ -> SectionROData + +-- | Calculate the natural alignment size given the platform word +-- type. +alignmentFromWordType :: WasmTypeTag w -> Alignment +alignmentFromWordType TagI32 = mkAlignment 4 +alignmentFromWordType TagI64 = mkAlignment 8 +alignmentFromWordType _ = panic "alignmentFromWordType: unreachable" + +-- | Calculate a data section's alignment. As a conservative +-- optimization, a data section with a single CmmString/CmmFileEmbed +-- has no alignment requirement, otherwise we always align to the word +-- size to satisfy pointer tagging requirements and avoid unaligned +-- loads/stores. +alignmentFromCmmSection :: WasmTypeTag w -> [DataSectionContent] -> Alignment +alignmentFromCmmSection _ [DataASCII {}] = mkAlignment 1 +alignmentFromCmmSection _ [DataIncBin {}] = mkAlignment 1 +alignmentFromCmmSection t _ = alignmentFromWordType t + +-- | Lower a 'CmmStatic'. +lower_CmmStatic :: CmmStatic -> WasmCodeGenM w DataSectionContent +lower_CmmStatic s = case s of + CmmStaticLit (CmmInt i W8) -> pure $ DataI8 $ fromInteger $ narrowU W8 i + CmmStaticLit (CmmInt i W16) -> pure $ DataI16 $ fromInteger $ narrowU W16 i + CmmStaticLit (CmmInt i W32) -> pure $ DataI32 $ fromInteger $ narrowU W32 i + CmmStaticLit (CmmInt i W64) -> pure $ DataI64 $ fromInteger $ narrowU W64 i + CmmStaticLit (CmmFloat f W32) -> pure $ DataF32 $ fromRational f + CmmStaticLit (CmmFloat d W64) -> pure $ DataF64 $ fromRational d + CmmStaticLit (CmmLabel lbl) -> + onAnySym lbl + $> DataSym + (symNameFromCLabel lbl) + 0 + CmmStaticLit (CmmLabelOff lbl o) -> + onAnySym lbl + $> DataSym + (symNameFromCLabel lbl) + o + CmmUninitialised i -> pure $ DataSkip i + CmmString b -> pure $ DataASCII b + CmmFileEmbed f l -> pure $ DataIncBin f l + _ -> panic "lower_CmmStatic: unreachable" + +{- +Note [Register mapping on WebAssembly] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Unlike typical ISAs, WebAssembly doesn't expose a fixed set of +registers. For now, we map each Cmm LocalReg to a wasm local, and each +Cmm GlobalReg to a wasm global. The wasm globals are defined in +rts/wasm/Wasm.S, and must be kept in sync with +'globalInfoFromCmmGlobalReg' and 'supportedCmmGlobalRegs' here. + +There are some other Cmm GlobalRegs which are still represented by +StgRegTable fields instead of wasm globals (e.g. HpAlloc). It's cheap +to add wasm globals, but other parts of rts logic only work with the +StgRegTable fields, so we also need to instrument StgRun/StgReturn to +sync the wasm globals with the StgRegTable. It's not really worth the +trouble. + +-} +globalInfoFromCmmGlobalReg :: WasmTypeTag w -> GlobalReg -> Maybe GlobalInfo +globalInfoFromCmmGlobalReg t reg = case reg of + VanillaReg i _ + | i >= 1 && i <= 10 -> Just (fromString $ "__R" <> show i, ty_word) + FloatReg i + | i >= 1 && i <= 6 -> + Just (fromString $ "__F" <> show i, SomeWasmType TagF32) + DoubleReg i + | i >= 1 && i <= 6 -> + Just (fromString $ "__D" <> show i, SomeWasmType TagF64) + LongReg i + | i == 1 -> Just (fromString $ "__L" <> show i, SomeWasmType TagI64) + Sp -> Just ("__Sp", ty_word) + SpLim -> Just ("__SpLim", ty_word) + Hp -> Just ("__Hp", ty_word) + HpLim -> Just ("__HpLim", ty_word) + _ -> Nothing + where + ty_word = SomeWasmType t + +supportedCmmGlobalRegs :: [GlobalReg] +supportedCmmGlobalRegs = + [VanillaReg i VGcPtr | i <- [1 .. 10]] + <> [FloatReg i | i <- [1 .. 6]] + <> [DoubleReg i | i <- [1 .. 6]] + <> [LongReg i | i <- [1 .. 1]] + <> [Sp, SpLim, Hp, HpLim] + +-- | Truncate a subword. +truncSubword :: Width -> WasmTypeTag t -> WasmExpr w t -> WasmExpr w t +truncSubword W8 ty (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmConst ty 0xFF `WasmConcat` WasmAnd ty +truncSubword W16 ty (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmConst ty 0xFFFF `WasmConcat` WasmAnd ty +truncSubword _ _ expr = expr + +-- | Sign-extend a subword. +extendSubword :: Width -> WasmTypeTag t -> WasmExpr w t -> WasmExpr w t +extendSubword W8 TagI32 (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmI32Extend8S +extendSubword W16 TagI32 (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmI32Extend16S +extendSubword W8 TagI64 (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmI64Extend8S +extendSubword W16 TagI64 (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmI64Extend16S +extendSubword W32 TagI64 (WasmExpr instr) = + WasmExpr $ instr `WasmConcat` WasmI64Extend32S +extendSubword _ _ expr = expr + +-- | Lower an unary homogeneous operation. +lower_MO_Un_Homo :: + ( forall pre t. + WasmTypeTag t -> + WasmInstr + w + (t : pre) + (t : pre) + ) -> + CLabel -> + CmmType -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Un_Homo op lbl t0 [x] = case someWasmTypeFromCmmType t0 of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + pure $ + SomeWasmExpr ty $ + WasmExpr $ + x_instr `WasmConcat` op ty +lower_MO_Un_Homo _ _ _ _ = panic "lower_MO_Un_Homo: unreachable" + +-- | Lower a binary homogeneous operation. Homogeneous: result type is +-- the same with operand types. +lower_MO_Bin_Homo :: + ( forall pre t. + WasmTypeTag t -> + WasmInstr + w + (t : t : pre) + (t : pre) + ) -> + CLabel -> + CmmType -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Bin_Homo op lbl t0 [x, y] = case someWasmTypeFromCmmType t0 of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y + pure $ + SomeWasmExpr ty $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` op ty +lower_MO_Bin_Homo _ _ _ _ = panic "lower_MO_Bin_Homo: unreachable" + +-- | Lower a binary homogeneous operation, and truncate the result if +-- it's a subword. +lower_MO_Bin_Homo_Trunc :: + (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)) -> + CLabel -> + Width -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Bin_Homo_Trunc op lbl w0 [x, y] = + case someWasmTypeFromCmmType (cmmBits w0) of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y + pure $ + SomeWasmExpr ty $ + truncSubword w0 ty $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` op ty +lower_MO_Bin_Homo_Trunc _ _ _ _ = panic "lower_MO_Bin_Homo_Trunc: unreachable" + +-- | Lower a binary homogeneous operation, first sign extending the +-- operands, then truncating the result. +lower_MO_Bin_Homo_Ext_Trunc :: + (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)) -> + CLabel -> + Width -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Bin_Homo_Ext_Trunc op lbl w0 [x, y] = + case someWasmTypeFromCmmType (cmmBits w0) of + SomeWasmType ty -> do + WasmExpr x_instr <- + extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- + extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty y + pure $ + SomeWasmExpr ty $ + truncSubword w0 ty $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` op ty +lower_MO_Bin_Homo_Ext_Trunc _ _ _ _ = + panic "lower_MO_Bin_Homo_Ext_Trunc: unreachable" + +-- | Lower a relational binary operation, first sign extending the +-- operands. Relational: result type is a boolean (word type). +lower_MO_Bin_Rel_Ext :: + (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)) -> + CLabel -> + Width -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Bin_Rel_Ext op lbl w0 [x, y] = + case someWasmTypeFromCmmType (cmmBits w0) of + SomeWasmType ty -> do + WasmExpr x_instr <- + extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- + extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty y + ty_word <- wasmWordTypeM + pure $ + SomeWasmExpr ty_word $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` op ty +lower_MO_Bin_Rel_Ext _ _ _ _ = panic "lower_MO_Bin_Rel_Ext: unreachable" + +-- | Lower a relational binary operation. +lower_MO_Bin_Rel :: + ( forall pre t. + WasmTypeTag t -> + WasmInstr + w + (t : t : pre) + (w : pre) + ) -> + CLabel -> + CmmType -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Bin_Rel op lbl t0 [x, y] = case someWasmTypeFromCmmType t0 of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y + ty_word <- wasmWordTypeM + pure $ + SomeWasmExpr ty_word $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` op ty +lower_MO_Bin_Rel _ _ _ _ = panic "lower_MO_Bin_Rel: unreachable" + +-- | Cast a shiftL/shiftR RHS to the same type as LHS. Because we may +-- have a 64-bit LHS and 32-bit RHS, but wasm shift operators are +-- homogeneous. +shiftRHSCast :: + CLabel -> + WasmTypeTag t -> + CmmExpr -> + WasmCodeGenM + w + (WasmExpr w t) +shiftRHSCast lbl t1 x = do + SomeWasmExpr t0 (WasmExpr x_instr) <- lower_CmmExpr lbl x + if + | Just Refl <- t0 `testEquality` t1 -> pure $ WasmExpr x_instr + | TagI32 <- t0, + TagI64 <- t1 -> + pure $ WasmExpr $ x_instr `WasmConcat` WasmI64ExtendI32 Unsigned + | otherwise -> panic "shiftRHSCast: unreachable" + +-- | Lower a 'MO_Shl' operation, truncating the result. +lower_MO_Shl :: + CLabel -> + Width -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_MO_Shl lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- shiftRHSCast lbl ty y + pure $ + SomeWasmExpr ty $ + truncSubword w0 ty $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` WasmShl ty +lower_MO_Shl _ _ _ = panic "lower_MO_Shl: unreachable" + +-- | Lower a 'MO_U_Shr' operation. +lower_MO_U_Shr :: + CLabel -> + Width -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_MO_U_Shr lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- shiftRHSCast lbl ty y + pure $ + SomeWasmExpr ty $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` WasmShr Unsigned ty +lower_MO_U_Shr _ _ _ = panic "lower_MO_U_Shr: unreachable" + +-- | Lower a 'MO_S_Shr' operation, first sign-extending the LHS, then +-- truncating the result. +lower_MO_S_Shr :: + CLabel -> + Width -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_MO_S_Shr lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of + SomeWasmType ty -> do + WasmExpr x_instr <- extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- shiftRHSCast lbl ty y + pure $ + SomeWasmExpr ty $ + truncSubword w0 ty $ + WasmExpr $ + x_instr `WasmConcat` y_instr `WasmConcat` WasmShr Signed ty +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@, +-- otherwise it's quite non-trivial to implement as inline assembly. +lower_MO_MulMayOflo :: + CLabel -> Width -> [CmmExpr] -> WasmCodeGenM w (SomeWasmExpr w) +lower_MO_MulMayOflo lbl w0 [x, y] = case someWasmTypeFromCmmType ty_cmm of + SomeWasmType ty -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y + onFuncSym "hs_mulIntMayOflo" [ty_cmm, ty_cmm] [ty_cmm] + pure $ + SomeWasmExpr ty $ + WasmExpr $ + x_instr + `WasmConcat` y_instr + `WasmConcat` WasmCCall "hs_mulIntMayOflo" + where + ty_cmm = cmmBits w0 +lower_MO_MulMayOflo _ _ _ = panic "lower_MO_MulMayOflo: unreachable" + +-- | Lower an unary conversion operation. +lower_MO_Un_Conv :: + ( forall pre t0 t1. + WasmTypeTag t0 -> + WasmTypeTag t1 -> + WasmInstr w (t0 : pre) (t1 : pre) + ) -> + CLabel -> + CmmType -> + CmmType -> + [CmmExpr] -> + WasmCodeGenM w (SomeWasmExpr w) +lower_MO_Un_Conv op lbl t0 t1 [x] = + case (# someWasmTypeFromCmmType t0, someWasmTypeFromCmmType t1 #) of + (# SomeWasmType ty0, SomeWasmType ty1 #) -> do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty0 x + pure $ SomeWasmExpr ty1 $ WasmExpr $ x_instr `WasmConcat` op ty0 ty1 +lower_MO_Un_Conv _ _ _ _ _ = panic "lower_MO_Un_Conv: unreachable" + +-- | Lower a 'MO_SS_Conv' operation. +lower_MO_SS_Conv :: + CLabel -> + Width -> + Width -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_MO_SS_Conv lbl w0 w1 [x] + | w0 == w1 = lower_CmmExpr lbl x +lower_MO_SS_Conv lbl w0 w1 [CmmLoad ptr _ align] + | w0 < w1, + w1 <= W32 = do + (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr + pure $ + SomeWasmExpr TagI32 $ + truncSubword w1 TagI32 $ + WasmExpr $ + ptr_instr + `WasmConcat` WasmLoad + TagI32 + (wasmMemoryNarrowing TagI32 (cmmBits w0)) + Signed + o + align + | w0 > w1 = + SomeWasmExpr TagI32 + <$> lower_CmmLoad_Typed + lbl + ptr + TagI32 + (cmmBits w1) + align +lower_MO_SS_Conv lbl w0 W64 [CmmLoad ptr _ align] = do + (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr + pure $ + SomeWasmExpr TagI64 $ + WasmExpr $ + ptr_instr + `WasmConcat` WasmLoad + TagI64 + (wasmMemoryNarrowing TagI64 (cmmBits w0)) + Signed + o + align +lower_MO_SS_Conv lbl w0 w1 [x] + | w0 < w1, + w1 <= W32 = do + x_expr <- lower_CmmExpr_Typed lbl TagI32 x + pure $ + SomeWasmExpr TagI32 $ + truncSubword w1 TagI32 $ + extendSubword w0 TagI32 x_expr + | W32 >= w0, + w0 > w1 = do + x_expr <- lower_CmmExpr_Typed lbl TagI32 x + pure $ SomeWasmExpr TagI32 $ truncSubword w1 TagI32 x_expr +lower_MO_SS_Conv lbl W32 W64 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x + pure $ + SomeWasmExpr TagI64 $ + WasmExpr $ + x_instr `WasmConcat` WasmI64ExtendI32 Signed +lower_MO_SS_Conv lbl w0 W64 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x + pure $ + SomeWasmExpr TagI64 $ + extendSubword w0 TagI64 $ + WasmExpr $ + x_instr `WasmConcat` WasmI64ExtendI32 Unsigned +lower_MO_SS_Conv lbl W64 w1 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x + pure $ + SomeWasmExpr TagI32 $ + truncSubword w1 TagI32 $ + WasmExpr $ + x_instr `WasmConcat` WasmI32WrapI64 +lower_MO_SS_Conv _ _ _ _ = panic "lower_MO_SS_Conv: unreachable" + +-- | Lower a 'MO_UU_Conv' operation. +lower_MO_UU_Conv :: + CLabel -> + Width -> + Width -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_MO_UU_Conv lbl w0 w1 [CmmLoad ptr _ align] = + case someWasmTypeFromCmmType (cmmBits w1) of + SomeWasmType ty -> + SomeWasmExpr ty + <$> lower_CmmLoad_Typed + lbl + ptr + ty + (cmmBits (min w0 w1)) + align +lower_MO_UU_Conv lbl w0 w1 [x] + | w0 == w1 = lower_CmmExpr lbl x + | w0 < w1, w1 <= W32 = lower_CmmExpr lbl x + | W32 >= w0, + w0 > w1 = do + x_expr <- lower_CmmExpr_Typed lbl TagI32 x + pure $ SomeWasmExpr TagI32 $ truncSubword w1 TagI32 x_expr +lower_MO_UU_Conv lbl _ W64 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x + pure $ + SomeWasmExpr TagI64 $ + WasmExpr $ + x_instr `WasmConcat` WasmI64ExtendI32 Unsigned +lower_MO_UU_Conv lbl W64 w1 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x + pure $ + SomeWasmExpr TagI32 $ + truncSubword w1 TagI32 $ + WasmExpr $ + x_instr `WasmConcat` WasmI32WrapI64 +lower_MO_UU_Conv _ _ _ _ = panic "lower_MO_UU_Conv: unreachable" + +-- | Lower a 'MO_FF_Conv' operation. +lower_MO_FF_Conv :: + CLabel -> + Width -> + Width -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_MO_FF_Conv lbl W32 W64 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF32 x + pure $ + SomeWasmExpr TagF64 $ + WasmExpr $ + x_instr `WasmConcat` WasmF64PromoteF32 +lower_MO_FF_Conv lbl W64 W32 [x] = do + WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF64 x + pure $ + SomeWasmExpr TagF32 $ + WasmExpr $ + x_instr `WasmConcat` WasmF32DemoteF64 +lower_MO_FF_Conv _ _ _ _ = panic "lower_MO_FF_Conv: unreachable" + +-- | Lower a 'CmmMachOp'. +lower_CmmMachOp :: + CLabel -> + MachOp -> + [CmmExpr] -> + WasmCodeGenM + w + (SomeWasmExpr w) +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 +lower_CmmMachOp lbl (MO_Ne w0) xs = lower_MO_Bin_Rel WasmNe lbl (cmmBits w0) xs +lower_CmmMachOp lbl (MO_Mul w0) xs = lower_MO_Bin_Homo_Trunc WasmMul lbl w0 xs +lower_CmmMachOp lbl (MO_S_MulMayOflo w0) xs = lower_MO_MulMayOflo lbl w0 xs +lower_CmmMachOp lbl (MO_S_Quot w0) xs = + lower_MO_Bin_Homo_Ext_Trunc + (WasmDiv Signed) + lbl + w0 + xs +lower_CmmMachOp lbl (MO_S_Rem w0) xs = + lower_MO_Bin_Homo_Ext_Trunc + (WasmRem Signed) + lbl + w0 + xs +lower_CmmMachOp lbl (MO_S_Neg w0) [x] = + lower_CmmMachOp + lbl + (MO_Sub w0) + [CmmLit $ CmmInt 0 w0, x] +lower_CmmMachOp lbl (MO_U_Quot w0) xs = + lower_MO_Bin_Homo + (WasmDiv Unsigned) + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_U_Rem w0) xs = + lower_MO_Bin_Homo + (WasmRem Unsigned) + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_S_Ge w0) xs = + lower_MO_Bin_Rel_Ext + (WasmGe Signed) + lbl + w0 + xs +lower_CmmMachOp lbl (MO_S_Le w0) xs = + lower_MO_Bin_Rel_Ext + (WasmLe Signed) + lbl + w0 + xs +lower_CmmMachOp lbl (MO_S_Gt w0) xs = + lower_MO_Bin_Rel_Ext + (WasmGt Signed) + lbl + w0 + xs +lower_CmmMachOp lbl (MO_S_Lt w0) xs = + lower_MO_Bin_Rel_Ext + (WasmLt Signed) + lbl + w0 + xs +lower_CmmMachOp lbl (MO_U_Ge w0) xs = + lower_MO_Bin_Rel + (WasmGe Unsigned) + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_U_Le w0) xs = + lower_MO_Bin_Rel + (WasmLe Unsigned) + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_U_Gt w0) xs = + lower_MO_Bin_Rel + (WasmGt Unsigned) + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_U_Lt w0) xs = + lower_MO_Bin_Rel + (WasmLt Unsigned) + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_F_Add w0) xs = + lower_MO_Bin_Homo + WasmAdd + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Sub w0) xs = + lower_MO_Bin_Homo + WasmSub + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Neg w0) xs = + lower_MO_Un_Homo + WasmNeg + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Mul w0) xs = + lower_MO_Bin_Homo + WasmMul + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Quot w0) xs = + lower_MO_Bin_Homo + (WasmDiv Signed) + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Eq w0) xs = + lower_MO_Bin_Rel + WasmEq + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Ne w0) xs = + lower_MO_Bin_Rel + WasmNe + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Ge w0) xs = + lower_MO_Bin_Rel + (WasmGe Signed) + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Le w0) xs = + lower_MO_Bin_Rel + (WasmLe Signed) + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Gt w0) xs = + lower_MO_Bin_Rel + (WasmGt Signed) + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_F_Lt w0) xs = + lower_MO_Bin_Rel + (WasmLt Signed) + lbl + (cmmFloat w0) + xs +lower_CmmMachOp lbl (MO_And w0) xs = + lower_MO_Bin_Homo + WasmAnd + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_Or w0) xs = lower_MO_Bin_Homo WasmOr lbl (cmmBits w0) xs +lower_CmmMachOp lbl (MO_Xor w0) xs = + lower_MO_Bin_Homo + WasmXor + lbl + (cmmBits w0) + xs +lower_CmmMachOp lbl (MO_Not w0) [x] = + lower_CmmMachOp + lbl + (MO_Xor w0) + [x, CmmLit $ CmmInt (widthMax w0) w0] +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_MO_Un_Conv + (WasmConvert Signed) + lbl + (cmmBits w0) + (cmmFloat w1) + xs +lower_CmmMachOp lbl (MO_FS_Conv w0 w1) xs = + lower_MO_Un_Conv + (WasmTruncSat Signed) + lbl + (cmmFloat w0) + (cmmBits w1) + xs +lower_CmmMachOp lbl (MO_SS_Conv w0 w1) xs = lower_MO_SS_Conv lbl w0 w1 xs +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 a 'CmmLit'. Note that we don't emit 'f32.const' or +-- 'f64.const' for the time being, and instead emit their relative bit +-- pattern as int literals, then use an reinterpret cast. This is +-- simpler than dealing with textual representation of floating point +-- values. +lower_CmmLit :: CmmLit -> WasmCodeGenM w (SomeWasmExpr w) +lower_CmmLit lit = do + ty_word <- wasmWordTypeM + case lit of + CmmInt i w -> case someWasmTypeFromCmmType (cmmBits w) of + SomeWasmType ty -> + pure $ + SomeWasmExpr ty $ + WasmExpr $ + WasmConst ty $ + narrowU w i + CmmFloat f W32 -> + pure $ + SomeWasmExpr TagF32 $ + WasmExpr $ + WasmConst + TagI32 + (toInteger $ castFloatToWord32 $ fromRational f) + `WasmConcat` WasmReinterpret TagI32 TagF32 + CmmFloat f W64 -> + pure $ + SomeWasmExpr TagF64 $ + WasmExpr $ + WasmConst + TagI64 + (toInteger $ castDoubleToWord64 $ fromRational f) + `WasmConcat` WasmReinterpret TagI64 TagF64 + CmmLabel lbl' -> do + onAnySym lbl' + let sym = symNameFromCLabel lbl' + pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst sym + CmmLabelOff lbl' o -> do + onAnySym lbl' + let sym = symNameFromCLabel lbl' + pure $ + SomeWasmExpr ty_word $ + WasmExpr $ + WasmSymConst sym + `WasmConcat` WasmConst ty_word (toInteger o) + `WasmConcat` WasmAdd ty_word + CmmBlock bid -> lower_CmmLit $ CmmLabel $ infoTblLbl bid + _ -> panic "lower_CmmLit: unreachable" + +-- | Lower a 'CmmReg'. Some of the logic here wouldn't be needed if +-- we have run 'fixStgRegisters' on the wasm NCG's input Cmm, but we +-- haven't run it yet for certain reasons. +lower_CmmReg :: CLabel -> CmmReg -> WasmCodeGenM w (SomeWasmExpr w) +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 + 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 + | Just (sym_global, SomeWasmType ty) <- + globalInfoFromCmmGlobalReg ty_word reg -> + pure $ SomeWasmExpr ty $ WasmExpr $ WasmGlobalGet ty sym_global + | otherwise -> do + platform <- wasmPlatformM + case someWasmTypeFromCmmType $ globalRegType platform reg of + SomeWasmType ty -> do + (WasmExpr ptr_instr, o) <- + lower_CmmExpr_Ptr lbl $ + get_GlobalReg_addr platform reg + pure $ + SomeWasmExpr ty $ + WasmExpr $ + ptr_instr + `WasmConcat` WasmLoad + ty + Nothing + Unsigned + o + NaturallyAligned + +-- | Lower a 'CmmRegOff'. +lower_CmmRegOff :: CLabel -> CmmReg -> Int -> WasmCodeGenM w (SomeWasmExpr w) +lower_CmmRegOff lbl reg 0 = lower_CmmReg lbl reg +lower_CmmRegOff lbl reg o = do + SomeWasmExpr ty (WasmExpr reg_instr) <- lower_CmmReg lbl reg + pure $ + SomeWasmExpr ty $ + WasmExpr $ + reg_instr + `WasmConcat` WasmConst + ty + (toInteger o) + `WasmConcat` WasmAdd ty + +-- | Lower a 'CmmLoad', passing in the expected wasm representation +-- type, and also the Cmm type (which contains width info needed for +-- memory narrowing). +-- +-- The Cmm type system doesn't track signedness, so all 'CmmLoad's are +-- unsigned loads. However, as an optimization, we do emit signed +-- loads when a 'CmmLoad' result is immediately used as a 'MO_SS_Conv' +-- operand. +lower_CmmLoad_Typed :: + CLabel -> + CmmExpr -> + WasmTypeTag t -> + CmmType -> + AlignmentSpec -> + WasmCodeGenM w (WasmExpr w t) +lower_CmmLoad_Typed lbl ptr_expr ty ty_cmm align = do + (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr_expr + pure $ + WasmExpr $ + ptr_instr + `WasmConcat` WasmLoad + ty + (wasmMemoryNarrowing ty ty_cmm) + Unsigned + o + align + +-- | Lower a 'CmmLoad'. +lower_CmmLoad :: + CLabel -> + CmmExpr -> + CmmType -> + AlignmentSpec -> + WasmCodeGenM + w + (SomeWasmExpr w) +lower_CmmLoad lbl ptr_expr ty_cmm align = case someWasmTypeFromCmmType ty_cmm of + SomeWasmType ty -> + SomeWasmExpr ty <$> lower_CmmLoad_Typed lbl ptr_expr ty ty_cmm align + +-- | Lower a 'CmmExpr'. +lower_CmmExpr :: CLabel -> CmmExpr -> WasmCodeGenM w (SomeWasmExpr w) +lower_CmmExpr lbl expr = case expr of + CmmLit lit -> lower_CmmLit lit + CmmLoad ptr_expr ty_cmm align -> lower_CmmLoad lbl ptr_expr ty_cmm align + CmmReg reg -> lower_CmmReg lbl reg + CmmRegOff reg o -> lower_CmmRegOff lbl reg o + CmmMachOp op xs -> lower_CmmMachOp lbl op xs + _ -> panic "lower_CmmExpr: unreachable" + +-- | Lower a 'CmmExpr', passing in the expected wasm representation +-- type. +lower_CmmExpr_Typed :: + CLabel -> + WasmTypeTag t -> + CmmExpr -> + WasmCodeGenM + w + (WasmExpr w t) +lower_CmmExpr_Typed lbl ty expr = do + SomeWasmExpr ty' r <- lower_CmmExpr lbl expr + if + | Just Refl <- ty' `testEquality` ty -> pure r + | otherwise -> panic "lower_CmmExpr_Typed: unreachable" + +-- | Lower a 'CmmExpr' as a pointer, returning the pair of base +-- pointer and non-negative offset. +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) + +-- | Push a series of values onto the wasm value stack, returning the +-- result stack type. +type family + WasmPushes (ts :: [WasmType]) (pre :: [WasmType]) :: + [WasmType] + where + WasmPushes '[] pre = pre + WasmPushes (t : ts) pre = WasmPushes ts (t : pre) + +-- | Push the arguments onto the wasm value stack before a ccall. +data SomeWasmPreCCall w where + SomeWasmPreCCall :: + TypeList ts -> + (forall pre. WasmInstr w pre (WasmPushes ts pre)) -> + SomeWasmPreCCall w + +-- | Pop the results into locals after a ccall. +data SomeWasmPostCCall w where + SomeWasmPostCCall :: + TypeList ts -> + (forall post. WasmInstr w (WasmPushes ts post) post) -> + SomeWasmPostCCall w + +-- | Lower an unary homogeneous 'CallishMachOp' to a ccall. +lower_CMO_Un_Homo :: + CLabel -> + SymName -> + [CmmFormal] -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_CMO_Un_Homo lbl op [reg] [x] = do + (ri, SomeWasmType ty) <- onCmmLocalReg reg + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + let ty_cmm = localRegType reg + onFuncSym op [ty_cmm] [ty_cmm] + pure $ + WasmStatements $ + x_instr `WasmConcat` WasmCCall op `WasmConcat` WasmLocalSet ty ri +lower_CMO_Un_Homo _ _ _ _ = panic "lower_CMO_Un_Homo: unreachable" + +-- | Lower a binary homogeneous 'CallishMachOp' to a ccall. +lower_CMO_Bin_Homo :: + CLabel -> + SymName -> + [CmmFormal] -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_CMO_Bin_Homo lbl op [reg] [x, y] = do + (ri, SomeWasmType ty) <- onCmmLocalReg reg + WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x + WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y + let ty_cmm = localRegType reg + onFuncSym op [ty_cmm, ty_cmm] [ty_cmm] + pure $ + WasmStatements $ + x_instr + `WasmConcat` y_instr + `WasmConcat` WasmCCall op + `WasmConcat` WasmLocalSet ty ri +lower_CMO_Bin_Homo _ _ _ _ = panic "lower_CMO_Bin_Homo: unreachable" + +-- | Lower a 'MO_UF_Conv' operation. +lower_MO_UF_Conv :: + CLabel -> + Width -> + [CmmFormal] -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_MO_UF_Conv lbl W32 [reg] [x] = do + ri <- onCmmLocalReg_Typed TagF32 reg + SomeWasmExpr ty0 (WasmExpr x_instr) <- lower_CmmExpr lbl x + pure $ + WasmStatements $ + x_instr + `WasmConcat` WasmConvert Unsigned ty0 TagF32 + `WasmConcat` WasmLocalSet TagF32 ri +lower_MO_UF_Conv lbl W64 [reg] [x] = do + ri <- onCmmLocalReg_Typed TagF64 reg + SomeWasmExpr ty0 (WasmExpr x_instr) <- lower_CmmExpr lbl x + pure $ + WasmStatements $ + x_instr + `WasmConcat` WasmConvert Unsigned ty0 TagF64 + `WasmConcat` WasmLocalSet TagF64 ri +lower_MO_UF_Conv _ _ _ _ = panic "lower_MO_UF_Conv: unreachable" + +-- | Lower a 'MO_Cmpxchg' operation to inline assembly. Currently we +-- target wasm without atomics and threads, so it's just lowered to +-- regular memory loads and stores. +lower_MO_Cmpxchg :: + CLabel -> + Width -> + [CmmFormal] -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_MO_Cmpxchg lbl w0 [reg] [ptr, expected, new] = + case someWasmTypeFromCmmType ty_cmm of + SomeWasmType ty -> do + reg_i <- onCmmLocalReg_Typed ty reg + let narrowing = wasmMemoryNarrowing ty ty_cmm + (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr + WasmExpr expected_instr <- lower_CmmExpr_Typed lbl ty expected + WasmExpr new_instr <- lower_CmmExpr_Typed lbl ty new + pure $ + WasmStatements $ + ptr_instr + `WasmConcat` WasmLoad ty narrowing Unsigned o NaturallyAligned + `WasmConcat` WasmLocalTee ty reg_i + `WasmConcat` expected_instr + `WasmConcat` WasmEq ty + `WasmConcat` WasmCond + ( ptr_instr + `WasmConcat` new_instr + `WasmConcat` WasmStore ty narrowing o NaturallyAligned + ) + where + ty_cmm = cmmBits w0 +lower_MO_Cmpxchg _ _ _ _ = panic "lower_MO_Cmpxchg: unreachable" + +-- | Lower a 'CallishMachOp'. +lower_CallishMachOp :: + CLabel -> + CallishMachOp -> + [CmmFormal] -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_CallishMachOp lbl MO_F64_Pwr rs xs = lower_CMO_Bin_Homo lbl "pow" rs xs +lower_CallishMachOp lbl MO_F64_Sin rs xs = lower_CMO_Un_Homo lbl "sin" rs xs +lower_CallishMachOp lbl MO_F64_Cos rs xs = lower_CMO_Un_Homo lbl "cos" rs xs +lower_CallishMachOp lbl MO_F64_Tan rs xs = lower_CMO_Un_Homo lbl "tan" rs xs +lower_CallishMachOp lbl MO_F64_Sinh rs xs = lower_CMO_Un_Homo lbl "sinh" rs xs +lower_CallishMachOp lbl MO_F64_Cosh rs xs = lower_CMO_Un_Homo lbl "cosh" rs xs +lower_CallishMachOp lbl MO_F64_Tanh rs xs = lower_CMO_Un_Homo lbl "tanh" rs xs +lower_CallishMachOp lbl MO_F64_Asin rs xs = lower_CMO_Un_Homo lbl "asin" rs xs +lower_CallishMachOp lbl MO_F64_Acos rs xs = lower_CMO_Un_Homo lbl "acos" rs xs +lower_CallishMachOp lbl MO_F64_Atan rs xs = lower_CMO_Un_Homo lbl "atan" rs xs +lower_CallishMachOp lbl MO_F64_Asinh rs xs = lower_CMO_Un_Homo lbl "asinh" rs xs +lower_CallishMachOp lbl MO_F64_Acosh rs xs = lower_CMO_Un_Homo lbl "acosh" rs xs +lower_CallishMachOp lbl MO_F64_Atanh rs xs = lower_CMO_Un_Homo lbl "atanh" rs xs +lower_CallishMachOp lbl MO_F64_Log rs xs = lower_CMO_Un_Homo lbl "log" rs xs +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_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 +lower_CallishMachOp lbl MO_F32_Tan rs xs = lower_CMO_Un_Homo lbl "tanf" rs xs +lower_CallishMachOp lbl MO_F32_Sinh rs xs = lower_CMO_Un_Homo lbl "sinhf" rs xs +lower_CallishMachOp lbl MO_F32_Cosh rs xs = lower_CMO_Un_Homo lbl "coshf" rs xs +lower_CallishMachOp lbl MO_F32_Tanh rs xs = lower_CMO_Un_Homo lbl "tanhf" rs xs +lower_CallishMachOp lbl MO_F32_Asin rs xs = lower_CMO_Un_Homo lbl "asinf" rs xs +lower_CallishMachOp lbl MO_F32_Acos rs xs = lower_CMO_Un_Homo lbl "acosf" rs xs +lower_CallishMachOp lbl MO_F32_Atan rs xs = lower_CMO_Un_Homo lbl "atanf" rs xs +lower_CallishMachOp lbl MO_F32_Asinh rs xs = + lower_CMO_Un_Homo lbl "asinhf" rs xs +lower_CallishMachOp lbl MO_F32_Acosh rs xs = + lower_CMO_Un_Homo lbl "acoshf" rs xs +lower_CallishMachOp lbl MO_F32_Atanh rs xs = + lower_CMO_Un_Homo lbl "atanhf" rs xs +lower_CallishMachOp lbl MO_F32_Log rs xs = lower_CMO_Un_Homo lbl "logf" rs xs +lower_CallishMachOp lbl MO_F32_Log1P rs xs = + lower_CMO_Un_Homo lbl "log1pf" rs xs +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_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_Touch _ _ = pure $ WasmStatements WasmNop +lower_CallishMachOp _ (MO_Prefetch_Data {}) _ _ = pure $ WasmStatements WasmNop +lower_CallishMachOp lbl (MO_Memcpy {}) [] xs = do + ty_word_cmm <- wasmWordCmmTypeM + lower_CmmUnsafeForeignCall_Drop lbl "memcpy" ty_word_cmm xs +lower_CallishMachOp lbl (MO_Memset {}) [] xs = do + ty_word_cmm <- wasmWordCmmTypeM + lower_CmmUnsafeForeignCall_Drop lbl "memset" ty_word_cmm xs +lower_CallishMachOp lbl (MO_Memmove {}) [] xs = do + ty_word_cmm <- wasmWordCmmTypeM + lower_CmmUnsafeForeignCall_Drop lbl "memmove" ty_word_cmm xs +lower_CallishMachOp lbl (MO_Memcmp {}) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left "memcmp") + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_PopCnt w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_popcnt" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_Pdep w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_pdep" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_Pext w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_pext" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_Clz w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_clz" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_Ctz w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_ctz" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_BSwap w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_bswap" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_BRev w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_bitrev" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_AtomicRMW w0 op) rs xs = + lower_CmmUnsafeForeignCall + lbl + ( Left $ + fromString $ + ( case op of + AMO_Add -> "hs_atomic_add" + AMO_Sub -> "hs_atomic_sub" + AMO_And -> "hs_atomic_and" + AMO_Nand -> "hs_atomic_nand" + AMO_Or -> "hs_atomic_or" + AMO_Xor -> "hs_atomic_xor" + ) + <> show (widthInBits w0) + ) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl (MO_AtomicRead w0 _) [reg] [ptr] = do + SomeWasmExpr ty (WasmExpr ret_instr) <- + lower_CmmLoad + lbl + ptr + (cmmBits w0) + NaturallyAligned + ri <- onCmmLocalReg_Typed ty reg + pure $ WasmStatements $ ret_instr `WasmConcat` WasmLocalSet ty ri +lower_CallishMachOp lbl (MO_AtomicWrite _ _) [] [ptr, val] = + lower_CmmStore lbl ptr val NaturallyAligned +lower_CallishMachOp lbl (MO_Cmpxchg w0) rs xs = lower_MO_Cmpxchg lbl w0 rs xs +lower_CallishMachOp lbl (MO_Xchg w0) rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left $ fromString $ "hs_xchg" <> show (widthInBits w0)) + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl MO_SuspendThread rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left "suspendThread") + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp lbl MO_ResumeThread rs xs = + lower_CmmUnsafeForeignCall + lbl + (Left "resumeThread") + Nothing + CmmMayReturn + rs + xs +lower_CallishMachOp _ _ _ _ = panic "lower_CallishMachOp: unreachable" + +-- | Lower a ccall, but drop the result by assigning it to an unused +-- local. This is only used for lowering 'MO_Memcpy' and such, where +-- the libc functions do have a return value, but the corresponding +-- 'CallishMachOp' does not expect one. +lower_CmmUnsafeForeignCall_Drop :: + CLabel -> + SymName -> + CmmType -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_CmmUnsafeForeignCall_Drop lbl sym_callee ret_cmm_ty arg_exprs = do + ret_uniq <- wasmUniq + let ret_local = LocalReg ret_uniq ret_cmm_ty + lower_CmmUnsafeForeignCall + lbl + (Left sym_callee) + Nothing + CmmMayReturn + [ret_local] + arg_exprs + +-- | Lower a 'CmmUnsafeForeignCall'. The target is 'Either' a symbol, +-- which translates to a direct @call@, or an expression, which +-- translates to a @call_indirect@. The callee function signature is +-- inferred from the passed in arguments here. +lower_CmmUnsafeForeignCall :: + CLabel -> + (Either SymName CmmExpr) -> + Maybe + ([ForeignHint], [ForeignHint]) -> + CmmReturnInfo -> + [CmmFormal] -> + [CmmActual] -> + WasmCodeGenM w (WasmStatements w) +lower_CmmUnsafeForeignCall lbl target mb_hints ret_info ret_locals arg_exprs = do + platform <- wasmPlatformM + SomeWasmPreCCall arg_tys args_instr <- + foldrM + ( \(arg_expr, arg_hint) (SomeWasmPreCCall acc_tys acc_instr) -> do + SomeWasmExpr arg_ty arg_wasm_expr <- lower_CmmExpr lbl arg_expr + let WasmExpr arg_instr = case arg_hint of + SignedHint -> + extendSubword + (cmmExprWidth platform arg_expr) + arg_ty + arg_wasm_expr + _ -> arg_wasm_expr + pure $ + SomeWasmPreCCall (arg_ty `TypeListCons` acc_tys) $ + arg_instr `WasmConcat` acc_instr + ) + (SomeWasmPreCCall TypeListNil WasmNop) + arg_exprs_hints + SomeWasmPostCCall ret_tys ret_instr <- + foldrM + ( \(reg, ret_hint) (SomeWasmPostCCall acc_tys acc_instr) -> do + (reg_i, SomeWasmType reg_ty) <- onCmmLocalReg reg + pure $ + SomeWasmPostCCall (reg_ty `TypeListCons` acc_tys) $ + case (# ret_hint, cmmRegWidth platform $ CmmLocal reg #) of + (# SignedHint, W8 #) -> + acc_instr + `WasmConcat` WasmConst reg_ty 0xFF + `WasmConcat` WasmAnd reg_ty + `WasmConcat` WasmLocalSet reg_ty reg_i + (# SignedHint, W16 #) -> + acc_instr + `WasmConcat` WasmConst reg_ty 0xFFFF + `WasmConcat` WasmAnd reg_ty + `WasmConcat` WasmLocalSet reg_ty reg_i + _ -> acc_instr `WasmConcat` WasmLocalSet reg_ty reg_i + ) + (SomeWasmPostCCall TypeListNil WasmNop) + ret_locals_hints + case target of + Left sym_callee -> do + platform <- wasmPlatformM + let arg_cmm_tys = map (cmmExprType platform) arg_exprs + ret_cmm_tys = map localRegType ret_locals + onFuncSym sym_callee arg_cmm_tys ret_cmm_tys + pure $ + WasmStatements $ + args_instr + `WasmConcat` WasmCCall sym_callee + `WasmConcat` ( case ret_info of + CmmMayReturn -> ret_instr + CmmNeverReturns -> WasmUnreachable + ) + Right fptr_callee -> do + (WasmExpr instr_callee, _) <- lower_CmmExpr_Ptr lbl fptr_callee + pure $ + WasmStatements $ + args_instr + `WasmConcat` instr_callee + `WasmConcat` WasmCCallIndirect arg_tys ret_tys + `WasmConcat` ( case ret_info of + CmmMayReturn -> ret_instr + CmmNeverReturns -> WasmUnreachable + ) + where + (# arg_exprs_hints, ret_locals_hints #) = case mb_hints of + Just (arg_hints, ret_hints) -> + (# zip arg_exprs arg_hints, zip ret_locals ret_hints #) + _ -> (# map (,NoHint) arg_exprs, map (,NoHint) ret_locals #) + +-- | Lower a 'CmmStore'. +lower_CmmStore :: + CLabel -> + CmmExpr -> + CmmExpr -> + AlignmentSpec -> + WasmCodeGenM + w + (WasmStatements w) +lower_CmmStore lbl ptr val align = do + platform <- wasmPlatformM + (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr + let ty_cmm = cmmExprType platform val + SomeWasmExpr ty (WasmExpr val_instr) <- lower_CmmExpr lbl val + pure $ + WasmStatements $ + ptr_instr + `WasmConcat` val_instr + `WasmConcat` WasmStore ty (wasmMemoryNarrowing ty ty_cmm) o align + +-- | Lower a single Cmm action. +lower_CmmAction :: CLabel -> CmmNode O O -> WasmCodeGenM w (WasmStatements w) +lower_CmmAction lbl act = do + ty_word <- wasmWordTypeM + platform <- wasmPlatformM + case act of + CmmComment {} -> pure $ WasmStatements WasmNop + CmmTick {} -> pure $ WasmStatements WasmNop + CmmUnwind {} -> pure $ WasmStatements WasmNop + CmmAssign (CmmLocal reg) e -> do + (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 + | BaseReg <- reg -> pure $ WasmStatements WasmNop + | Just (sym_global, SomeWasmType ty_reg) <- + globalInfoFromCmmGlobalReg ty_word reg -> do + WasmExpr instrs <- lower_CmmExpr_Typed lbl ty_reg e + pure $ + WasmStatements $ + instrs `WasmConcat` WasmGlobalSet ty_reg sym_global + | otherwise -> do + (WasmExpr ptr_instr, o) <- + lower_CmmExpr_Ptr lbl $ get_GlobalReg_addr platform reg + SomeWasmExpr ty_e (WasmExpr instrs) <- lower_CmmExpr lbl e + pure $ + WasmStatements $ + ptr_instr + `WasmConcat` instrs + `WasmConcat` WasmStore ty_e Nothing o NaturallyAligned + CmmStore ptr val align -> lower_CmmStore lbl ptr val align + CmmUnsafeForeignCall + ( ForeignTarget + (CmmLit (CmmLabel lbl_callee)) + (ForeignConvention conv arg_hints ret_hints ret_info) + ) + ret_locals + arg_exprs + | conv `elem` [CCallConv, CApiConv] -> + lower_CmmUnsafeForeignCall + lbl + (Left $ symNameFromCLabel lbl_callee) + (Just (arg_hints, ret_hints)) + ret_info + ret_locals + arg_exprs + CmmUnsafeForeignCall + (ForeignTarget target_expr (ForeignConvention conv arg_hints ret_hints ret_info)) + ret_locals + arg_exprs + | conv `elem` [CCallConv, CApiConv] -> + lower_CmmUnsafeForeignCall + lbl + (Right target_expr) + (Just (arg_hints, ret_hints)) + ret_info + ret_locals + arg_exprs + CmmUnsafeForeignCall (PrimTarget op) ret_locals arg_exprs -> + lower_CallishMachOp lbl op ret_locals arg_exprs + _ -> panic "lower_CmmAction: unreachable" + +-- | Lower a block of Cmm actions. +lower_CmmActions :: + CLabel -> + Label -> + Block CmmNode O O -> + WasmCodeGenM + w + (WasmStatements w) +lower_CmmActions lbl _ blk = + foldlM + ( \(WasmStatements acc) act -> + (\(WasmStatements stmts) -> WasmStatements $ acc `WasmConcat` stmts) + <$> lower_CmmAction lbl act + ) + (WasmStatements WasmNop) + acts + where + acts = blockToList blk + +-- | Lower a 'CmmGraph'. +lower_CmmGraph :: CLabel -> CmmGraph -> WasmCodeGenM w (FuncBody w) +lower_CmmGraph lbl g = do + ty_word <- wasmWordTypeM + platform <- wasmPlatformM + body <- + structuredControl + platform + (\_ -> lower_CmmExpr_Typed lbl ty_word) + (lower_CmmActions lbl) + g + locals <- wasmStateM $ \s -> + (# + map snd $ detEltsUFM $ localRegs s, + s {localRegs = emptyUFM, localRegsCount = 0} + #) + pure FuncBody {funcLocals = locals, funcBody = wasmControlCast $ body} + +-- | Invoked once for each 'CLabel' which indexes a 'CmmData' or +-- 'CmmProc'. +onTopSym :: CLabel -> WasmCodeGenM w () +onTopSym lbl = case sym_vis of + SymDefault -> wasmModifyM $ \s -> + s + { defaultSyms = + IS.insert + (getKey $ getUnique sym) + $ defaultSyms s + } + _ -> pure () + where + sym = symNameFromCLabel lbl + + sym_vis = symVisibilityFromCLabel lbl + +-- | Invoked for each function 'CLabel' with known type (e.g. a +-- 'CmmProc', or callee of 'CmmUnsafeForeignCall'). +onFuncSym :: SymName -> [CmmType] -> [CmmType] -> WasmCodeGenM w () +onFuncSym sym arg_tys ret_tys = wasmModifyM $ + \s@WasmCodeGenState {..} -> + s + { funcTypes = + addToUniqMap + funcTypes + sym + ( map someWasmTypeFromCmmType arg_tys, + map someWasmTypeFromCmmType ret_tys + ) + } + +-- | Invoked for all other 'CLabel's along the way, e.g. in +-- 'CmmStatic's or 'CmmExpr's. +onAnySym :: CLabel -> WasmCodeGenM w () +onAnySym lbl = case sym_kind of + SymFunc -> do + ty_word <- wasmWordTypeM + wasmModifyM $ \s@WasmCodeGenState {..} -> + s {funcTypes = addToUniqMap_C const funcTypes sym ([], [SomeWasmType ty_word])} + _ -> pure () + where + sym = symNameFromCLabel lbl + + sym_kind = symKindFromCLabel lbl + +-- | Invoked for each 'LocalReg', returning its wasm local id and +-- representation type. +onCmmLocalReg :: LocalReg -> WasmCodeGenM w LocalInfo +onCmmLocalReg reg = wasmStateM $ \s@WasmCodeGenState {..} -> + let reg_info = + (localRegsCount, someWasmTypeFromCmmType $ localRegType reg) + in case addToUFM_L (\_ i _ -> i) reg reg_info localRegs of + (Just i, _) -> (# i, s #) + (_, localRegs') -> + (# + reg_info, + s + { localRegs = localRegs', + localRegsCount = + localRegsCount + 1 + } + #) + +-- | Invoked for each 'LocalReg' with expected representation type, +-- only returning its wasm local id. +onCmmLocalReg_Typed :: WasmTypeTag t -> LocalReg -> WasmCodeGenM w Int +onCmmLocalReg_Typed ty reg = do + (i, SomeWasmType ty') <- onCmmLocalReg reg + if + | Just Refl <- ty' `testEquality` ty -> pure i + | otherwise -> panic "onCmmLocalReg_Typed: unreachable" + +-- | Invoked for dtors. We don't bother to implement dtors yet; +-- there's no native @.fini_array@ support for wasm, and the way +-- @clang@ handles dtors is generating a ctor that calls @atexit()@ +-- for dtors. Which makes some sense, but we don't need to do the same +-- thing yet. +onFini :: [SymName] -> WasmCodeGenM w () +onFini syms = do + let n_finis = length syms + when (n_finis /= 0) $ panic "dtors unsupported by wasm32 NCG" + +-- | Invoked for ctors and dtors. +onCmmInitFini :: InitOrFini -> [CLabel] -> WasmCodeGenM w () +onCmmInitFini iof lbls = do + for_ lbls $ \lbl -> onFuncSym (symNameFromCLabel lbl) [] [] + case iof of + IsInitArray -> wasmModifyM $ \s -> s {ctors = syms <> ctors s} + IsFiniArray -> onFini syms + where + syms = map symNameFromCLabel lbls + +-- | Invoked for each data section. +onCmmData :: CLabel -> Section -> [CmmStatic] -> WasmCodeGenM w () +onCmmData lbl s statics = do + ty_word <- wasmWordTypeM + onTopSym lbl + cs <- for statics lower_CmmStatic + let sym = symNameFromCLabel lbl + sec = + DataSection + { dataSectionKind = + dataSectionKindFromCmmSection s, + dataSectionAlignment = + alignmentFromCmmSection ty_word cs, + dataSectionContents = + case cs of + [DataASCII buf] -> [DataASCII $ buf `BS.snoc` 0] + [DataIncBin p l] -> [DataIncBin p l, DataI8 0] + _ -> cs + } + wasmModifyM $ \s -> + s + { dataSections = + addToUniqMap (dataSections s) sym sec + } + +-- | Invoked for each 'CmmProc'. +onCmmProc :: CLabel -> CmmGraph -> WasmCodeGenM w () +onCmmProc lbl g = do + ty_word <- wasmWordCmmTypeM + onTopSym lbl + onFuncSym sym [] [ty_word] + body <- lower_CmmGraph lbl g + wasmModifyM $ \s -> s {funcBodies = addToUniqMap (funcBodies s) sym body} + where + sym = symNameFromCLabel lbl + +-- | Invoked for each 'RawCmmDecl'. +onCmmDecl :: RawCmmDecl -> WasmCodeGenM w () +onCmmDecl decl + | Just (iof, lbls) <- isInitOrFiniArray decl = onCmmInitFini iof lbls +onCmmDecl (CmmData s (CmmStaticsRaw lbl statics)) = onCmmData lbl s statics +onCmmDecl (CmmProc _ lbl _ g) = onCmmProc lbl g + +-- | Invoked for each 'RawCmmGroup'. +onCmmGroup :: RawCmmGroup -> WasmCodeGenM w () +onCmmGroup cmms = wasmStateM $ \s0 -> + (# (), foldl' (\s cmm -> wasmExecM (onCmmDecl cmm) s) s0 cmms #) diff --git a/GHC/CmmToAsm/Wasm/Types.hs b/GHC/CmmToAsm/Wasm/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Wasm/Types.hs @@ -0,0 +1,475 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHC.CmmToAsm.Wasm.Types + ( WasmType (..), + WasmTypeTag (..), + SomeWasmType (..), + TypeList (..), + someWasmTypesFromTypeList, + WasmFunctionType (..), + SymName (..), + SymVisibility (..), + SymKind (..), + DataSectionKind (..), + DataSectionContent (..), + DataSection (..), + GlobalInfo, + LocalInfo, + FuncBody (..), + Signage (..), + WasmInstr (..), + WasmExpr (..), + SomeWasmExpr (..), + WasmStatements (..), + WasmControl (..), + BrTableInterval (..), + wasmControlCast, + WasmCodeGenState (..), + initialWasmCodeGenState, + WasmCodeGenM (..), + wasmGetsM, + wasmPlatformM, + wasmWordTypeM, + wasmWordCmmTypeM, + wasmStateM, + wasmModifyM, + wasmExecM, + wasmUniq, + ) +where + +import Control.Applicative +import Data.ByteString (ByteString) +import Data.Coerce +import Data.Functor +import qualified Data.IntSet as IS +import Data.Kind +import Data.String +import Data.Type.Equality +import Data.Word +import GHC.Cmm +import GHC.Data.FastString +import GHC.Float +import GHC.Platform +import GHC.Prelude +import GHC.Types.Basic +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map +import GHC.Types.Unique.Supply +import GHC.Utils.Monad.State.Strict +import GHC.Utils.Outputable hiding ((<>)) +import Unsafe.Coerce + +-- | WebAssembly type of a WebAssembly value that WebAssembly code +-- could either expect on the evaluation stack or leave on the +-- evaluation stack. +data WasmType = I32 | I64 | F32 | F64 + +-- | Singleton type useful for programming with `WasmType` at the type +-- level. +data WasmTypeTag :: WasmType -> Type where + TagI32 :: WasmTypeTag 'I32 + TagI64 :: WasmTypeTag 'I64 + TagF32 :: WasmTypeTag 'F32 + TagF64 :: WasmTypeTag 'F64 + +deriving instance Show (WasmTypeTag t) + +instance TestEquality WasmTypeTag where + TagI32 `testEquality` TagI32 = Just Refl + TagI64 `testEquality` TagI64 = Just Refl + TagF32 `testEquality` TagF32 = Just Refl + TagF64 `testEquality` TagF64 = Just Refl + _ `testEquality` _ = Nothing + +data SomeWasmType where + SomeWasmType :: WasmTypeTag t -> SomeWasmType + +instance Eq SomeWasmType where + SomeWasmType ty0 == SomeWasmType ty1 + | Just Refl <- ty0 `testEquality` ty1 = True + | otherwise = False + +-- | List of WebAssembly types used to describe the sequence of +-- WebAssembly values that a block of code may expect on the stack or +-- leave on the stack. +data TypeList :: [WasmType] -> Type where + TypeListNil :: TypeList '[] + TypeListCons :: WasmTypeTag t -> TypeList ts -> TypeList (t : ts) + +someWasmTypesFromTypeList :: TypeList ts -> [SomeWasmType] +someWasmTypesFromTypeList TypeListNil = [] +someWasmTypesFromTypeList (ty `TypeListCons` tys) = + SomeWasmType ty : someWasmTypesFromTypeList tys + +-- | The type of a WebAssembly function, loop, block, or conditional. +-- This type says what values the code expects to pop off the stack +-- and what values it promises to push. The WebAssembly standard +-- requires that this type appear explicitly in the code. +data WasmFunctionType pre post = WasmFunctionType {ft_pops :: TypeList pre, ft_pushes :: TypeList post} + +-- | For simplicity, we record other metadata in 'WasmCodeGenState' by +-- need, instead of carrying them along with 'SymName'. +newtype SymName = SymName FastString + deriving (Eq, IsString, Show, Uniquable) via FastString + deriving (Ord) via LexicalFastString + +data SymVisibility + = -- | Not defined in the current compilation unit. + -- + -- @[ undefined binding=global vis=default ]@ + SymUndefined + | -- | Defined, not visible to other compilation units. + -- + -- @[ binding=local vis=default ]@ + SymStatic + | -- | Defined, visible to other compilation units. + -- + -- Adds @.hidden@ & @.globl@ directives in the output assembly. + -- + -- @[ binding=global vis=hidden ]@ + SymDefault + +-- | Represents whether a symbol is a data symbol or a function +-- symbol. Unlike linkers for other targets, @wasm-ld@ does panic at +-- link-time if it finds symbol kind inconsistency between the +-- definition site and other use sites. +-- +-- Currently we solely rely on 'isCFunctionLabel' to determine a +-- symbol's kind, but it does take extra effort to make it work. The +-- main source of inconsistency arises from hand-written Cmm sources, +-- where it's possible to refer to external entities like @xxx_info@ +-- and @xxx_closure@ without explicit @import CLOSURE@ declarations. +-- The Cmm parser will implicitly assume those are foreign function +-- labels, and then this will break the WebAssembly backend. #22368 +-- provides more context on this issue. +-- +-- tl;dr for any GHC contributor that accidentally triggers @wasm-ld@ +-- errors when hacking Cmm: whatever data symbols are used in new +-- code, just add the corresponding @import CLOSURE@ declarations at +-- the top of that Cmm file. +data SymKind = SymData | SymFunc + deriving (Eq) + +-- | WebAssembly doesn't really have proper read-only memory regions +-- yet. Neverthless we add the .rodata logic here, wasm-ld will +-- aggregate all .rodata sections into a single one, which adds +-- possibility for runtime checks later, either via a customized +-- runtime, or via code instrumentation. See +-- +data DataSectionKind = SectionData | SectionROData + +-- | Neither Cmm or Wasm type system takes integer signedness into +-- account, therefore we always round up a 'CmmLit' to the right width +-- and handle it as an untyped integer. +data DataSectionContent + = DataI8 Word8 + | DataI16 Word16 + | DataI32 Word32 + | DataI64 Word64 + | DataF32 Float + | DataF64 Double + | DataSym SymName Int + | DataSkip Int + | DataASCII ByteString + | DataIncBin FilePath Int + +data DataSection = DataSection + { dataSectionKind :: DataSectionKind, + dataSectionAlignment :: + Alignment, + dataSectionContents :: [DataSectionContent] + } + +-- | We need to remember the symbols. Determinism is achieved by +-- sorting symbols before writing the assembly. +type SymMap = UniqMap SymName + +-- | No need to remember the symbols. +type SymSet = IS.IntSet + +type GlobalInfo = (SymName, SomeWasmType) + +type LocalInfo = (Int, SomeWasmType) + +data FuncBody w = FuncBody + { funcLocals :: [SomeWasmType], + -- | Most are Cmm functions, but may also contain synthesized + -- function of other types, sigh. + funcBody :: WasmControl (WasmStatements w) (WasmExpr w w) '[] '[w] + } + +data Signage = Signed | Unsigned + +-- | The @w@ type variable in the Wasm IR stands for "platform word +-- type", so 'TagI32' on wasm32, and 'TagI64' on wasm64. This way, we +-- can make the codegen logic work on both wasm32/wasm64 in a +-- type-safe manner. +data WasmInstr :: WasmType -> [WasmType] -> [WasmType] -> Type where + WasmComment :: String -> WasmInstr w pre pre + WasmNop :: WasmInstr w pre pre + WasmDrop :: WasmInstr w (t : pre) pre + WasmUnreachable :: WasmInstr w pre post + WasmConst :: WasmTypeTag t -> Integer -> WasmInstr w pre (t : pre) + WasmSymConst :: SymName -> WasmInstr w pre (w : pre) + WasmLoad :: + WasmTypeTag t -> + Maybe Int -> + Signage -> + Int -> + AlignmentSpec -> + WasmInstr w (w : pre) (t : pre) + WasmStore :: + WasmTypeTag t -> + Maybe Int -> + Int -> + AlignmentSpec -> + WasmInstr + w + (t : w : pre) + pre + WasmGlobalGet :: WasmTypeTag t -> SymName -> WasmInstr w pre (t : pre) + WasmGlobalSet :: WasmTypeTag t -> SymName -> WasmInstr w (t : pre) pre + WasmLocalGet :: WasmTypeTag t -> Int -> WasmInstr w pre (t : pre) + WasmLocalSet :: WasmTypeTag t -> Int -> WasmInstr w (t : pre) pre + WasmLocalTee :: WasmTypeTag t -> Int -> WasmInstr w (t : pre) (t : pre) + WasmCCall :: SymName -> WasmInstr w pre post + WasmCCallIndirect :: + TypeList arg_tys -> + TypeList ret_tys -> + WasmInstr + w + (w : pre) + post + WasmConcat :: + WasmInstr w pre mid -> + WasmInstr w mid post -> + WasmInstr w pre post + WasmReinterpret :: + WasmTypeTag t0 -> + WasmTypeTag t1 -> + WasmInstr + w + (t0 : pre) + (t1 : pre) + WasmTruncSat :: + Signage -> + WasmTypeTag t0 -> + WasmTypeTag t1 -> + WasmInstr + w + (t0 : pre) + (t1 : pre) + WasmConvert :: + Signage -> + WasmTypeTag t0 -> + WasmTypeTag t1 -> + WasmInstr + w + (t0 : pre) + (t1 : pre) + WasmAdd :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmSub :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmMul :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmDiv :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmRem :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmAnd :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmOr :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmXor :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmEq :: WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre) + WasmNe :: WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre) + WasmLt :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre) + WasmGt :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre) + WasmLe :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre) + WasmGe :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre) + WasmShl :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmShr :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre) + WasmI32Extend8S :: WasmInstr w ('I32 : pre) ('I32 : pre) + WasmI32Extend16S :: WasmInstr w ('I32 : pre) ('I32 : pre) + WasmI64Extend8S :: WasmInstr w ('I64 : pre) ('I64 : pre) + WasmI64Extend16S :: WasmInstr w ('I64 : pre) ('I64 : pre) + WasmI64Extend32S :: WasmInstr w ('I64 : pre) ('I64 : pre) + WasmI64ExtendI32 :: Signage -> WasmInstr w ('I32 : pre) ('I64 : pre) + WasmI32WrapI64 :: WasmInstr w ('I64 : pre) ('I32 : pre) + WasmF32DemoteF64 :: WasmInstr w ('F64 : pre) ('F32 : pre) + WasmF64PromoteF32 :: WasmInstr w ('F32 : pre) ('F64 : pre) + WasmAbs :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre) + WasmNeg :: WasmTypeTag t -> WasmInstr w (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)) + +data SomeWasmExpr w where + SomeWasmExpr :: WasmTypeTag t -> WasmExpr w t -> SomeWasmExpr w + +newtype WasmStatements w = WasmStatements (forall pre. WasmInstr w pre pre) + +-- | Representation of WebAssembly control flow. +-- Normally written as +-- @ +-- WasmControl s e pre post +-- @ +-- Type parameter `s` is the type of (unspecified) statements. +-- It might be instantiated with an open Cmm block or with a sequence +-- of Wasm instructions. +-- Parameter `e` is the type of expressions. +-- Parameter `pre` represents the values that are expected on the +-- WebAssembly stack when the code runs, and `post` represents +-- the state of the stack on completion. +data WasmControl :: Type -> Type -> [WasmType] -> [WasmType] -> Type where + WasmPush :: WasmTypeTag t -> e -> WasmControl s e stack (t : stack) + WasmBlock :: + WasmFunctionType pre post -> + WasmControl s e pre post -> + WasmControl s e pre post + WasmLoop :: + WasmFunctionType pre post -> + WasmControl s e pre post -> + WasmControl s e pre post + WasmIfTop :: + WasmFunctionType pre post -> + WasmControl s e pre post -> + WasmControl s e pre post -> + WasmControl s e ('I32 : pre) post + WasmBr :: Int -> WasmControl s e dropped destination -- not typechecked + WasmFallthrough :: WasmControl s e dropped destination + -- generates no code, but has the same type as a branch + WasmBrTable :: + e -> + BrTableInterval -> -- for testing + [Int] -> -- targets + Int -> -- default target + WasmControl s e dropped destination + -- invariant: the table interval is contained + -- within [0 .. pred (length targets)] + + -- Note [WasmTailCall] + -- ~~~~~~~~~~~~~~~~~~~ + -- This represents the exit point of each CmmGraph: tail calling the + -- destination in CmmCall. The STG stack may grow before the call, + -- but it's always a tail call in the sense that the C call stack is + -- guaranteed not to grow. + -- + -- In the wasm backend, WasmTailCall is lowered to different + -- assembly code given whether the wasm tail-call extension is + -- enabled: + -- + -- When tail-call is not enabled (which is the default as of today), + -- a WasmTailCall is lowered to code that pushes the callee function + -- pointer onto the value stack and returns immediately. The actual + -- call is done by the trampoline in StgRun. + -- + -- When tail-call is indeed enabled via passing -mtail-call in + -- CONF_CC_OPTS_STAGE2 at configure time, a WasmTailCall is lowered + -- to return_call/return_call_indirect, thus tail calling into its + -- callee without returning to StgRun. + WasmTailCall :: + e -> + WasmControl s e t1star t2star -- as per type system + WasmActions :: + s -> + WasmControl s e stack stack -- basic block: one entry, one exit + WasmSeq :: + WasmControl s e pre mid -> + WasmControl s e mid post -> + WasmControl s e pre post + +data BrTableInterval = BrTableInterval {bti_lo :: Integer, bti_count :: Integer} + deriving (Show) + +instance Outputable BrTableInterval where + ppr range = + brackets $ + hcat + [integer (bti_lo range), text "..", integer hi] + where + hi = bti_lo range + bti_count range - 1 + +wasmControlCast :: WasmControl s e pre post -> WasmControl s e pre' post' +wasmControlCast = unsafeCoerce + +data WasmCodeGenState w = WasmCodeGenState + { -- | Target platform + wasmPlatform :: Platform, + -- | Defined symbols with 'SymDefault' visibility. + defaultSyms :: SymSet, + -- | Function types, defined or not. There may exist a function + -- whose type is unknown (e.g. as a function pointer), in that + -- case we fall back to () -> (), it's imperfect but works with + -- wasm-ld. + funcTypes :: SymMap ([SomeWasmType], [SomeWasmType]), + -- | Defined function bodies. + funcBodies :: SymMap (FuncBody w), + -- | Defined data sections. + dataSections :: SymMap DataSection, + -- | ctors in the current compilation unit. + ctors :: [SymName], + localRegs :: + UniqFM LocalReg LocalInfo, + localRegsCount :: + Int, + wasmUniqSupply :: UniqSupply + } + +initialWasmCodeGenState :: Platform -> UniqSupply -> WasmCodeGenState w +initialWasmCodeGenState platform us = + WasmCodeGenState + { wasmPlatform = + platform, + defaultSyms = IS.empty, + funcTypes = emptyUniqMap, + funcBodies = + emptyUniqMap, + dataSections = emptyUniqMap, + ctors = + [], + localRegs = emptyUFM, + localRegsCount = 0, + wasmUniqSupply = us + } + +newtype WasmCodeGenM w a = WasmCodeGenM (State (WasmCodeGenState w) a) + deriving newtype (Functor, Applicative, Monad) + +wasmGetsM :: (WasmCodeGenState w -> a) -> WasmCodeGenM w a +wasmGetsM = coerce . gets + +wasmPlatformM :: WasmCodeGenM w Platform +wasmPlatformM = wasmGetsM wasmPlatform + +wasmWordTypeM :: WasmCodeGenM w (WasmTypeTag w) +wasmWordTypeM = wasmGetsM $ \s -> + if target32Bit $ wasmPlatform s + then unsafeCoerce TagI32 + else unsafeCoerce TagI64 + +wasmWordCmmTypeM :: WasmCodeGenM w CmmType +wasmWordCmmTypeM = wasmGetsM (bWord . wasmPlatform) + +wasmStateM :: + (WasmCodeGenState w -> (# a, WasmCodeGenState w #)) -> + WasmCodeGenM w a +wasmStateM = coerce . State + +wasmModifyM :: (WasmCodeGenState w -> WasmCodeGenState w) -> WasmCodeGenM w () +wasmModifyM = coerce . modify + +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} #) diff --git a/GHC/CmmToAsm/Wasm/Utils.hs b/GHC/CmmToAsm/Wasm/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/CmmToAsm/Wasm/Utils.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Strict #-} + +module GHC.CmmToAsm.Wasm.Utils + ( widthMax, + detEltsUFM, + detEltsUniqMap, + builderCommas, + ) +where + +import Data.ByteString.Builder +import Data.List (intersperse, sortOn) +import GHC.Cmm +import GHC.Prelude +import GHC.Types.Unique.FM +import GHC.Types.Unique.Map + +widthMax :: Width -> Integer +widthMax w = (1 `shiftL` widthInBits w) - 1 + +detEltsUFM :: Ord k => UniqFM k0 (k, a) -> [(k, a)] +detEltsUFM = sortOn fst . nonDetEltsUFM + +detEltsUniqMap :: Ord k => UniqMap k a -> [(k, a)] +detEltsUniqMap = sortOn fst . nonDetEltsUniqMap + +builderCommas :: (a -> Builder) -> [a] -> Builder +builderCommas f xs = mconcat (intersperse ", " (map f xs)) diff --git a/GHC/CmmToAsm/X86.hs b/GHC/CmmToAsm/X86.hs --- a/GHC/CmmToAsm/X86.hs +++ b/GHC/CmmToAsm/X86.hs @@ -33,11 +33,12 @@ , canShortcut = X86.canShortcut , shortcutStatics = X86.shortcutStatics , shortcutJump = X86.shortcutJump - , pprNatCmmDecl = X86.pprNatCmmDecl config + , pprNatCmmDeclS = X86.pprNatCmmDecl config + , pprNatCmmDeclH = X86.pprNatCmmDecl config , maxSpillSlots = X86.maxSpillSlots config , allocatableRegs = X86.allocatableRegs platform , ncgAllocMoreStack = X86.allocMoreStack platform - , ncgMakeFarBranches = \_p _i bs -> pure bs + , ncgMakeFarBranches = const id , extractUnwindPoints = X86.extractUnwindPoints , invertCondBranches = X86.invertCondBranches } 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 @@ -326,7 +326,7 @@ -> genForeignCall target result_regs args bid _ -> (,Nothing) <$> case stmt of - CmmComment s -> return (unitOL (COMMENT $ ftext s)) + CmmComment s -> return (unitOL (COMMENT s)) CmmTick {} -> return nilOL CmmUnwind regs -> do @@ -1979,10 +1979,10 @@ -- Use ASSERT so we don't break releases if -- LTT/LE creep in somehow. LTT -> - assertPpr False (ppr "Should have been turned into >") + assertPpr False (text "Should have been turned into >") and_ordered LE -> - assertPpr False (ppr "Should have been turned into >=") + assertPpr False (text "Should have been turned into >=") and_ordered _ -> and_ordered @@ -2892,25 +2892,10 @@ let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) - offsetReg <- getNewRegNat (intFormat (platformWordWidth platform)) - return $ if is32bit || os == OSDarwin - then e_code `appOL` t_code `appOL` toOL [ + return $ e_code `appOL` t_code `appOL` toOL [ ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg), JMP_TBL (OpReg tableReg) ids rosection lbl ] - else -- HACK: On x86_64 binutils<2.17 is only able to generate - -- PC32 relocations, hence we only get 32-bit offsets in - -- the jump table. As these offsets are always negative - -- we need to properly sign extend them to 64-bit. This - -- hack should be removed in conjunction with the hack in - -- PprMach.hs/pprDataItem once binutils 2.17 is standard. - e_code `appOL` t_code `appOL` toOL [ - MOVSxL II32 op (OpReg offsetReg), - ADD (intFormat (platformWordWidth platform)) - (OpReg offsetReg) - (OpReg tableReg), - JMP_TBL (OpReg tableReg) ids rosection lbl - ] else do (reg,e_code) <- getSomeReg indexExpr lbl <- getNewLabelNat @@ -3032,7 +3017,7 @@ -- ja _c2g2 -- jmp _c2g1 -- --- Removing the jump reduces the pressure on the branch predidiction system +-- 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 @@ -3052,9 +3037,9 @@ GU -> plain_test dst GEU -> plain_test dst -- Use ASSERT so we don't break releases if these creep in. - LTT -> assertPpr False (ppr "Should have been turned into >") $ + LTT -> assertPpr False (text "Should have been turned into >") $ and_ordered dst - LE -> assertPpr False (ppr "Should have been turned into >=") $ + LE -> assertPpr False (text "Should have been turned into >=") $ and_ordered dst _ -> and_ordered dst) @@ -3317,9 +3302,9 @@ invert bs where invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr] - invert ((BasicBlock lbl1 ins@(_:_:_xs)):b2@(BasicBlock lbl2 _):bs) + invert (BasicBlock lbl1 ins:b2@(BasicBlock lbl2 _):bs) | --pprTrace "Block" (ppr lbl1) True, - (jmp1,jmp2) <- last2 ins + Just (jmp1,jmp2) <- last2 ins , JXX cond1 target1 <- jmp1 , target1 == lbl2 --, pprTrace "CutChance" (ppr b1) True 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 @@ -38,6 +38,7 @@ where import GHC.Prelude +import GHC.Data.FastString import GHC.CmmToAsm.X86.Cond import GHC.CmmToAsm.X86.Regs @@ -170,7 +171,7 @@ data Instr -- comment pseudo-op - = COMMENT SDoc + = COMMENT FastString -- location pseudo-op (file, line, col, name) | LOCATION Int Int Int String @@ -868,7 +869,7 @@ case platformArch platform of ArchX86 | needs_probe_call platform amount -> [ MOV II32 (OpImm (ImmInt amount)) (OpReg eax) - , CALL (Left $ strImmLit "___chkstk_ms") [eax] + , CALL (Left $ strImmLit (fsLit "___chkstk_ms")) [eax] , SUB II32 (OpReg eax) (OpReg esp) ] | otherwise -> @@ -877,7 +878,7 @@ ] ArchX86_64 | needs_probe_call platform amount -> [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax) - , CALL (Left $ strImmLit "___chkstk_ms") [rax] + , CALL (Left $ strImmLit (fsLit "___chkstk_ms")) [rax] , SUB II64 (OpReg rax) (OpReg rsp) ] | otherwise -> 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 @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- @@ -11,11 +12,7 @@ module GHC.CmmToAsm.X86.Ppr ( pprNatCmmDecl, - pprData, pprInstr, - pprFormat, - pprImm, - pprDataItem, ) where @@ -39,6 +36,7 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.BlockId import GHC.Cmm.CLabel +import GHC.Cmm.DebugBlock (pprUnwindTable) import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Types.Unique ( pprUniqueAlways ) @@ -65,12 +63,12 @@ -- .subsections_via_symbols and -dead_strip can be found at -- -pprProcAlignment :: NCGConfig -> SDoc +pprProcAlignment :: IsDoc doc => NCGConfig -> doc pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config) where platform = ncgPlatform config -pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc +pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> doc pprNatCmmDecl config (CmmData section dats) = pprSectionAlign config section $$ pprDatas config dats @@ -85,7 +83,7 @@ pprProcLabel config lbl $$ pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock config top_info) blocks) $$ - ppWhen (ncgDwarfEnabled config) (pprBlockEndLabel platform lbl $$ pprProcEndLabel platform lbl) $$ + ppWhen (ncgDwarfEnabled config) (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl)) $$ pprSizeDecl platform lbl Just (CmmStaticsRaw info_lbl _) -> @@ -93,48 +91,51 @@ pprProcAlignment config $$ pprProcLabel config lbl $$ (if platformHasSubsectionsViaSymbols platform - then pdoc platform (mkDeadStripPreventer info_lbl) <> colon + then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> colon) else empty) $$ vcat (map (pprBasicBlock config top_info) blocks) $$ - ppWhen (ncgDwarfEnabled config) (pprProcEndLabel platform info_lbl) $$ + 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] - text "\t.long " - <+> pdoc platform info_lbl + line + $ text "\t.long " + <+> pprAsmLabel platform info_lbl <+> char '-' - <+> pdoc platform (mkDeadStripPreventer info_lbl) + <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl) else empty) $$ pprSizeDecl platform info_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 :: NCGConfig -> CLabel -> SDoc +pprProcLabel :: IsDoc doc => NCGConfig -> CLabel -> doc pprProcLabel config lbl | ncgExposeInternalSymbols config , Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl - = lbl' <> colon + = line (lbl' <> colon) | otherwise = empty -pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name - -> SDoc +pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name + -> doc pprProcEndLabel platform lbl = - pdoc platform (mkAsmTempProcEndLabel lbl) <> colon + pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon -pprBlockEndLabel :: Platform -> CLabel -- ^ Block name - -> SDoc +pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name + -> doc pprBlockEndLabel platform lbl = - pdoc platform (mkAsmTempEndLabel lbl) <> colon + pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon -- | Output the ELF .size directive. -pprSizeDecl :: Platform -> CLabel -> SDoc +pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc pprSizeDecl platform lbl = if osElfTarget (platformOS platform) - then text "\t.size" <+> pdoc platform lbl <> text ", .-" <> pdoc platform lbl + then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl) else empty -pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc +pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> doc pprBasicBlock config info_env (BasicBlock blockid instrs) = maybe_infotable $ pprLabel platform asmLbl $$ @@ -142,8 +143,8 @@ ppWhen (ncgDwarfEnabled config) ( -- Emit both end labels since this may end up being a standalone -- top-level block - pprBlockEndLabel platform asmLbl - <> pprProcEndLabel platform asmLbl + line (pprBlockEndLabel platform asmLbl + <> pprProcEndLabel platform asmLbl) ) where asmLbl = blockLbl blockid @@ -156,7 +157,7 @@ vcat (map (pprData config) info) $$ pprLabel platform infoLbl $$ c $$ - ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> colon) + ppWhen (ncgDwarfEnabled config) (line (pprAsmLabel platform (mkAsmTempEndLabel infoLbl) <> colon)) -- Make sure the info table has the right .loc for the block -- coming right after it. See Note [Info Offset] @@ -165,7 +166,7 @@ _other -> empty -pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc +pprDatas :: IsDoc doc => NCGConfig -> (Alignment, 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 @@ -175,31 +176,32 @@ , Just ind' <- labelInd ind , alias `mayRedirectTo` ind' = pprGloblDecl (ncgPlatform config) alias - $$ text ".equiv" <+> pdoc (ncgPlatform config) alias <> comma <> pdoc (ncgPlatform config) (CmmLabel ind') + $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind') pprDatas config (align, (CmmStaticsRaw lbl dats)) = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats) where platform = ncgPlatform config -pprData :: NCGConfig -> CmmStatic -> SDoc -pprData _config (CmmString str) = pprString str -pprData _config (CmmFileEmbed path) = pprFileEmbed path +pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc +pprData _config (CmmString str) = line (pprString str) +pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path) pprData config (CmmUninitialised bytes) - = let platform = ncgPlatform config + = 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 :: Platform -> CLabel -> SDoc +pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = text ".globl " <> pdoc platform lbl + | otherwise = line (text ".globl " <> pprAsmLabel platform lbl) -pprLabelType' :: Platform -> CLabel -> SDoc +pprLabelType' :: IsLine doc => Platform -> CLabel -> doc pprLabelType' platform lbl = if isCFunctionLabel lbl || functionOkInfoTable then text "@function" @@ -254,24 +256,24 @@ but mess up with the relocation. https://phabricator.haskell.org/D4730 -} functionOkInfoTable = platformTablesNextToCode platform && - isInfoTableLabel lbl && not (isConInfoTableLabel lbl) + isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl) -pprTypeDecl :: Platform -> CLabel -> SDoc +pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc pprTypeDecl platform lbl = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl - then text ".type " <> pdoc platform lbl <> text ", " <> pprLabelType' platform lbl + then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl) else empty -pprLabel :: Platform -> CLabel -> SDoc +pprLabel :: IsDoc doc => Platform -> CLabel -> doc pprLabel platform lbl = pprGloblDecl platform lbl $$ pprTypeDecl platform lbl - $$ (pdoc platform lbl <> colon) + $$ line (pprAsmLabel platform lbl <> colon) -pprAlign :: Platform -> Alignment -> SDoc +pprAlign :: IsDoc doc => Platform -> Alignment -> doc pprAlign platform alignment - = text ".align " <> int (alignmentOn platform) + = line $ text ".align " <> int (alignmentOn platform) where bytes = alignmentBytes alignment alignmentOn platform = if platformOS platform == OSDarwin @@ -285,7 +287,7 @@ log2 8 = 3 log2 n = 1 + log2 (n `quot` 2) -pprReg :: Platform -> Format -> Reg -> SDoc +pprReg :: forall doc. IsLine doc => Platform -> Format -> Reg -> doc pprReg platform f r = case r of RegReal (RealRegSingle i) -> @@ -297,7 +299,7 @@ RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u where - ppr32_reg_no :: Format -> Int -> SDoc + 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 @@ -327,7 +329,7 @@ _ -> ppr_reg_float i } - ppr64_reg_no :: Format -> Int -> SDoc + 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 @@ -385,7 +387,7 @@ _ -> ppr_reg_float i } -ppr_reg_float :: Int -> SDoc +ppr_reg_float :: IsLine doc => Int -> doc ppr_reg_float i = case i of 16 -> text "%xmm0" ; 17 -> text "%xmm1" 18 -> text "%xmm2" ; 19 -> text "%xmm3" @@ -397,7 +399,7 @@ 30 -> text "%xmm14"; 31 -> text "%xmm15" _ -> text "very naughty x86 register" -pprFormat :: Format -> SDoc +pprFormat :: IsLine doc => Format -> doc pprFormat x = case x of II8 -> text "b" II16 -> text "w" @@ -406,14 +408,14 @@ FF32 -> text "ss" -- "scalar single-precision float" (SSE2) FF64 -> text "sd" -- "scalar double-precision float" (SSE2) -pprFormat_x87 :: Format -> SDoc +pprFormat_x87 :: IsLine doc => Format -> doc pprFormat_x87 x = case x of FF32 -> text "s" FF64 -> text "l" _ -> panic "X86.Ppr.pprFormat_x87" -pprCond :: Cond -> SDoc +pprCond :: IsLine doc => Cond -> doc pprCond c = case c of { GEU -> text "ae"; LU -> text "b"; EQQ -> text "e"; GTT -> text "g"; @@ -426,13 +428,13 @@ ALWAYS -> text "mp"} -pprImm :: Platform -> Imm -> SDoc +pprImm :: IsLine doc => Platform -> Imm -> doc pprImm platform = \case ImmInt i -> int i ImmInteger i -> integer i - ImmCLbl l -> pdoc platform l - ImmIndex l i -> pdoc platform l <> char '+' <> int i - ImmLit s -> s + ImmCLbl l -> pprAsmLabel platform l + ImmIndex l i -> pprAsmLabel platform l <> char '+' <> int i + ImmLit s -> ftext s ImmFloat f -> float $ fromRational f ImmDouble d -> double $ fromRational d ImmConstantSum a b -> pprImm platform a <> char '+' <> pprImm platform b @@ -440,7 +442,7 @@ -pprAddr :: Platform -> AddrMode -> SDoc +pprAddr :: IsLine doc => Platform -> AddrMode -> doc pprAddr platform (ImmAddr imm off) = let pp_imm = pprImm platform imm in @@ -471,28 +473,26 @@ ppr_disp imm = pprImm platform imm -- | Print section header and appropriate alignment for that section. -pprSectionAlign :: NCGConfig -> Section -> SDoc +pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign _config (Section (OtherSection _) _) = panic "X86.Ppr.pprSectionAlign: unknown section" pprSectionAlign config sec@(Section seg _) = - pprSectionHeader config sec $$ + line (pprSectionHeader config sec) $$ pprAlignForSection (ncgPlatform config) seg -- | Print appropriate alignment for the given section type. -pprAlignForSection :: Platform -> SectionType -> SDoc -pprAlignForSection platform seg = +pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc +pprAlignForSection platform seg = line $ text ".align " <> case platformOS platform of -- Darwin: alignments are given as shifts. OSDarwin | target32Bit platform -> case seg of - ReadOnlyData16 -> int 4 CString -> int 1 _ -> int 2 | otherwise -> case seg of - ReadOnlyData16 -> int 4 CString -> int 1 _ -> int 3 -- Other: alignments are given as bytes. @@ -500,18 +500,16 @@ | target32Bit platform -> case seg of Text -> text "4,0x90" - ReadOnlyData16 -> int 16 CString -> int 1 _ -> int 4 | otherwise -> case seg of - ReadOnlyData16 -> int 16 CString -> int 1 _ -> int 8 -pprDataItem :: NCGConfig -> CmmLit -> SDoc +pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc pprDataItem config lit - = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) + = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit) where platform = ncgPlatform config imm = litToImm lit @@ -536,51 +534,29 @@ <> int (fromIntegral (fromIntegral (x `shiftR` 32) :: Word32))] _ -> panic "X86.Ppr.ppr_item: no match for II64" - | otherwise -> - [text "\t.quad\t" <> pprImm platform imm] - _ - | target32Bit platform -> - [text "\t.quad\t" <> pprImm platform imm] - | otherwise -> - -- x86_64: binutils can't handle the R_X86_64_PC64 - -- relocation type, which means we can't do - -- pc-relative 64-bit addresses. Fortunately we're - -- assuming the small memory model, in which all such - -- offsets will fit into 32 bits, so we have to stick - -- to 32-bit offset fields and modify the RTS - -- appropriately - -- - -- See Note [x86-64-relative] in rts/include/rts/storage/InfoTables.h - -- - case lit of - -- A relative relocation: - CmmLabelDiffOff _ _ _ _ -> - [text "\t.long\t" <> pprImm platform imm, - text "\t.long\t0"] - _ -> - [text "\t.quad\t" <> pprImm platform imm] + _ -> [text "\t.quad\t" <> pprImm platform imm] -asmComment :: SDoc -> SDoc +asmComment :: IsLine doc => doc -> doc asmComment c = whenPprDebug $ text "# " <> c -pprInstr :: Platform -> Instr -> SDoc +pprInstr :: forall doc. IsDoc doc => Platform -> Instr -> doc pprInstr platform i = case i of COMMENT s - -> asmComment s + -> line (asmComment (ftext s)) - LOCATION file line col _name - -> text "\t.loc " <> ppr file <+> ppr line <+> ppr col + LOCATION file line' col _name + -> line (text "\t.loc " <> int file <+> int line' <+> int col) DELTA d - -> asmComment $ text ("\tdelta = " ++ show d) + -> line (asmComment $ text ("\tdelta = " ++ show d)) NEWBLOCK _ -> panic "pprInstr: NEWBLOCK" UNWIND lbl d - -> asmComment (text "\tunwind = " <> pdoc platform d) - $$ pdoc platform lbl <> colon + -> line (asmComment (text "\tunwind = " <> pprUnwindTable platform d)) + $$ line (pprAsmLabel platform lbl <> colon) LDATA _ _ -> panic "pprInstr: LDATA" @@ -798,19 +774,19 @@ -- POPA -> text "\tpopal" NOP - -> text "\tnop" + -> line $ text "\tnop" CLTD II8 - -> text "\tcbtw" + -> line $ text "\tcbtw" CLTD II16 - -> text "\tcwtd" + -> line $ text "\tcwtd" CLTD II32 - -> text "\tcltd" + -> line $ text "\tcltd" CLTD II64 - -> text "\tcqto" + -> line $ text "\tcqto" CLTD x -> panic $ "pprInstr: CLTD " ++ show x @@ -822,26 +798,26 @@ -> pprFormatOpReg (text "xchg") format src val JXX cond blockid - -> pprCondInstr (text "j") cond (pdoc platform lab) + -> pprCondInstr (text "j") cond (pprAsmLabel platform lab) where lab = blockLbl blockid JXX_GBL cond imm -> pprCondInstr (text "j") cond (pprImm platform imm) JMP (OpImm imm) _ - -> text "\tjmp " <> pprImm platform imm + -> line $ text "\tjmp " <> pprImm platform imm JMP op _ - -> text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op + -> line $ text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op JMP_TBL op _ _ _ -> pprInstr platform (JMP op []) CALL (Left imm) _ - -> text "\tcall " <> pprImm platform imm + -> line $ text "\tcall " <> pprImm platform imm CALL (Right reg) _ - -> text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg + -> line $ text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg IDIV fmt op -> pprFormatOp (text "idiv") fmt op @@ -885,20 +861,20 @@ -- FETCHGOT for PIC on ELF platforms FETCHGOT reg - -> vcat [ text "\tcall 1f", - hcat [ text "1:\tpopl\t", pprReg platform II32 reg ], - hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ", - pprReg platform II32 reg ] - ] + -> lines_ [ text "\tcall 1f", + hcat [ text "1:\tpopl\t", pprReg platform II32 reg ], + hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ", + pprReg platform II32 reg ] + ] -- FETCHPC for PIC on Darwin/x86 -- get the instruction pointer into a register -- (Terminology note: the IP is called Program Counter on PPC, -- and it's a good thing to use the same name on both platforms) FETCHPC reg - -> vcat [ text "\tcall 1f", - hcat [ text "1:\tpopl\t", pprReg platform II32 reg ] - ] + -> lines_ [ text "\tcall 1f", + hcat [ text "1:\tpopl\t", pprReg platform II32 reg ] + ] -- the -- GST fmt src addr ==> FLD dst ; FSTPsz addr @@ -907,10 +883,10 @@ -- Atomics LOCK i - -> text "\tlock" $$ pprInstr platform i + -> line (text "\tlock") $$ pprInstr platform i MFENCE - -> text "\tmfence" + -> line $ text "\tmfence" XADD format src dst -> pprFormatOpOp (text "xadd") format src dst @@ -920,46 +896,46 @@ where - gtab :: SDoc + gtab :: Line doc gtab = char '\t' - gsp :: SDoc + gsp :: Line doc gsp = char ' ' - pprX87 :: Instr -> SDoc -> SDoc + pprX87 :: Instr -> Line doc -> doc pprX87 fake actual - = (char '#' <> pprX87Instr fake) $$ actual + = line (char '#' <> pprX87Instr fake) $$ line actual - pprX87Instr :: Instr -> SDoc + pprX87Instr :: Instr -> Line doc pprX87Instr (X87Store fmt dst) = pprFormatAddr (text "gst") fmt dst pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match" - pprDollImm :: Imm -> SDoc + pprDollImm :: Imm -> Line doc pprDollImm i = text "$" <> pprImm platform i - pprOperand :: Platform -> Format -> Operand -> SDoc + pprOperand :: Platform -> Format -> Operand -> Line doc pprOperand platform f op = case op of OpReg r -> pprReg platform f r OpImm i -> pprDollImm i OpAddr ea -> pprAddr platform ea - pprMnemonic_ :: SDoc -> SDoc + pprMnemonic_ :: Line doc -> Line doc pprMnemonic_ name = char '\t' <> name <> space - pprMnemonic :: SDoc -> Format -> SDoc + pprMnemonic :: Line doc -> Format -> Line doc pprMnemonic name format = char '\t' <> name <> pprFormat format <> space - pprFormatImmOp :: SDoc -> Format -> Imm -> Operand -> SDoc + pprFormatImmOp :: Line doc -> Format -> Imm -> Operand -> doc pprFormatImmOp name format imm op1 - = hcat [ + = line $ hcat [ pprMnemonic name format, char '$', pprImm platform imm, @@ -968,24 +944,24 @@ ] - pprFormatOp_ :: SDoc -> Format -> Operand -> SDoc + pprFormatOp_ :: Line doc -> Format -> Operand -> doc pprFormatOp_ name format op1 - = hcat [ + = line $ hcat [ pprMnemonic_ name , pprOperand platform format op1 ] - pprFormatOp :: SDoc -> Format -> Operand -> SDoc + pprFormatOp :: Line doc -> Format -> Operand -> doc pprFormatOp name format op1 - = hcat [ + = line $ hcat [ pprMnemonic name format, pprOperand platform format op1 ] - pprFormatOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc + pprFormatOpOp :: Line doc -> Format -> Operand -> Operand -> doc pprFormatOpOp name format op1 op2 - = hcat [ + = line $ hcat [ pprMnemonic name format, pprOperand platform format op1, comma, @@ -993,18 +969,18 @@ ] - pprOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc + pprOpOp :: Line doc -> Format -> Operand -> Operand -> doc pprOpOp name format op1 op2 - = hcat [ + = line $ hcat [ pprMnemonic_ name, pprOperand platform format op1, comma, pprOperand platform format op2 ] - pprRegReg :: SDoc -> Reg -> Reg -> SDoc + pprRegReg :: Line doc -> Reg -> Reg -> doc pprRegReg name reg1 reg2 - = hcat [ + = line $ hcat [ pprMnemonic_ name, pprReg platform (archWordFormat (target32Bit platform)) reg1, comma, @@ -1012,18 +988,18 @@ ] - pprFormatOpReg :: SDoc -> Format -> Operand -> Reg -> SDoc + pprFormatOpReg :: Line doc -> Format -> Operand -> Reg -> doc pprFormatOpReg name format op1 reg2 - = hcat [ + = line $ hcat [ pprMnemonic name format, pprOperand platform format op1, comma, pprReg platform (archWordFormat (target32Bit platform)) reg2 ] - pprCondOpReg :: SDoc -> Format -> Cond -> Operand -> Reg -> SDoc + pprCondOpReg :: Line doc -> Format -> Cond -> Operand -> Reg -> doc pprCondOpReg name format cond op1 reg2 - = hcat [ + = line $ hcat [ char '\t', name, pprCond cond, @@ -1033,18 +1009,18 @@ pprReg platform format reg2 ] - pprFormatFormatOpReg :: SDoc -> Format -> Format -> Operand -> Reg -> SDoc + pprFormatFormatOpReg :: Line doc -> Format -> Format -> Operand -> Reg -> doc pprFormatFormatOpReg name format1 format2 op1 reg2 - = hcat [ + = line $ hcat [ pprMnemonic name format2, pprOperand platform format1 op1, comma, pprReg platform format2 reg2 ] - pprFormatOpOpReg :: SDoc -> Format -> Operand -> Operand -> Reg -> SDoc + pprFormatOpOpReg :: Line doc -> Format -> Operand -> Operand -> Reg -> doc pprFormatOpOpReg name format op1 op2 reg3 - = hcat [ + = line $ hcat [ pprMnemonic name format, pprOperand platform format op1, comma, @@ -1055,7 +1031,7 @@ - pprFormatAddr :: SDoc -> Format -> AddrMode -> SDoc + pprFormatAddr :: Line doc -> Format -> AddrMode -> Line doc pprFormatAddr name format op = hcat [ pprMnemonic name format, @@ -1063,9 +1039,9 @@ pprAddr platform op ] - pprShift :: SDoc -> Format -> Operand -> Operand -> SDoc + pprShift :: Line doc -> Format -> Operand -> Operand -> doc pprShift name format src dest - = hcat [ + = line $ hcat [ pprMnemonic name format, pprOperand platform II8 src, -- src is 8-bit sized comma, @@ -1073,15 +1049,15 @@ ] - pprFormatOpOpCoerce :: SDoc -> Format -> Format -> Operand -> Operand -> SDoc + pprFormatOpOpCoerce :: Line doc -> Format -> Format -> Operand -> Operand -> doc pprFormatOpOpCoerce name format1 format2 op1 op2 - = hcat [ char '\t', name, pprFormat format1, pprFormat format2, space, + = line $ hcat [ char '\t', name, pprFormat format1, pprFormat format2, space, pprOperand platform format1 op1, comma, pprOperand platform format2 op2 ] - pprCondInstr :: SDoc -> Cond -> SDoc -> SDoc + pprCondInstr :: Line doc -> Cond -> Line doc -> doc pprCondInstr name cond arg - = hcat [ char '\t', name, pprCond cond, space, arg] + = line $ hcat [ char '\t', name, pprCond cond, space, arg] 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 @@ -48,6 +48,7 @@ where import GHC.Prelude +import GHC.Data.FastString import GHC.Platform.Regs import GHC.Platform.Reg @@ -55,7 +56,6 @@ import GHC.Cmm import GHC.Cmm.CLabel ( CLabel ) -import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform @@ -111,15 +111,15 @@ = ImmInt Int | ImmInteger Integer -- Sigh. | ImmCLbl CLabel -- AbstractC Label (with baggage) - | ImmLit SDoc -- Simple string + | ImmLit FastString | ImmIndex CLabel Int | ImmFloat Rational | ImmDouble Rational | ImmConstantSum Imm Imm | ImmConstantDiff Imm Imm -strImmLit :: String -> Imm -strImmLit s = ImmLit (text s) +strImmLit :: FastString -> Imm +strImmLit s = ImmLit s litToImm :: CmmLit -> Imm diff --git a/GHC/CmmToC.hs b/GHC/CmmToC.hs --- a/GHC/CmmToC.hs +++ b/GHC/CmmToC.hs @@ -1,6 +1,9 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- @@ -33,8 +36,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel -import GHC.Cmm hiding (pprBBlock) -import GHC.Cmm.Ppr () -- For Outputable instances +import GHC.Cmm hiding (pprBBlock, pprStatic) import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph @@ -49,16 +51,16 @@ import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Monad.State.Strict (State (..), runState, state) import GHC.Utils.Misc -import GHC.Utils.Trace import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Char import Data.List (intersperse) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Map (Map) import qualified Data.Map as Map -import Control.Monad (ap) import GHC.Float -- -------------------------------------------------------------------------- @@ -85,7 +87,7 @@ blankLine, extern_decls, (if (externallyVisibleCLabel clbl) - then mkFN_ else mkIF_) (pprCLabel platform CStyle clbl) <+> lbrace, + then mkFN_ else mkIF_) (pprCLabel platform clbl) <+> lbrace, nest 8 temp_decls, vcat (map (pprBBlock platform) blocks), rbrace ] @@ -107,14 +109,14 @@ (CmmData section (CmmStaticsRaw lbl [CmmString str])) -> pprExternDecl platform lbl $$ hcat [ - pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle lbl, + pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform lbl, text "[] = ", pprStringInCStyle str, semi ] (CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) -> pprExternDecl platform lbl $$ hcat [ - pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle lbl, + pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform lbl, brackets (int size), semi ] @@ -131,7 +133,7 @@ -- BasicBlocks are self-contained entities: they always end in a jump. -- -- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn --- as many jumps as possible into fall throughs. +-- as many jumps as possible into fallthroughs. -- pprBBlock :: Platform -> CmmBlock -> SDoc @@ -150,7 +152,7 @@ = -- TODO: align closures only pprExternDecl platform lbl $$ hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord" - , space, pprCLabel platform CStyle lbl, text "[]" + , space, pprCLabel platform lbl, text "[]" -- See Note [StgWord alignment] , pprAlignment (wordWidth platform) , text "= {" ] @@ -242,16 +244,16 @@ case fn of CmmLit (CmmLabel lbl) | StdCallConv <- cconv -> - pprCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs + 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 + pprCall platform cast_fn cconv hresults hargs <> semi <> text "__builtin_unreachable();" | not (isMathFun lbl) -> - pprForeignCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs + pprForeignCall platform (pprCLabel platform lbl) cconv hresults hargs _ -> pprCall platform cast_fn cconv hresults hargs <> semi -- for a dynamic call, no declaration is necessary. @@ -345,7 +347,7 @@ rep = typeWidth (cmmExprType platform e) -- fall through case - caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix + caseify (ix:|ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix where do_fallthrough ix = hsep [ text "case" , pprHexVal platform ix rep <> colon , @@ -355,8 +357,6 @@ hsep [ text "case" , pprHexVal platform ix rep <> colon , text "goto" , (pprBlockId ident) <> semi ] - caseify (_ , _ ) = panic "pprSwitch: switch with no cases!" - def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi | otherwise = text "default: __builtin_unreachable();" @@ -382,8 +382,8 @@ CmmRegOff reg 0 -> pprCastReg reg -- CmmRegOff is an alias of MO_Add - CmmRegOff reg i -> pprCastReg reg <> char '+' <> - pprHexVal platform (fromIntegral i) (wordWidth platform) + CmmRegOff reg i -> pprExpr platform $ CmmMachOp (MO_Add w) [CmmReg reg, CmmLit $ CmmInt (toInteger i) w] + where w = cmmRegWidth platform reg CmmMachOp mop args -> pprMachOpApp platform mop args @@ -430,8 +430,7 @@ pprMachOpApp platform op args | isMulMayOfloOp op = text "mulIntMayOflo" <> parens (commafy (map (pprExpr platform) args)) - where isMulMayOfloOp (MO_U_MulMayOflo _) = True - isMulMayOfloOp (MO_S_MulMayOflo _) = True + where isMulMayOfloOp (MO_S_MulMayOflo _) = True isMulMayOfloOp _ = False pprMachOpApp platform mop args @@ -594,7 +593,7 @@ -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i where - pprCLabelAddr lbl = char '&' <> pprCLabel platform CStyle lbl + pprCLabelAddr lbl = char '&' <> pprCLabel platform lbl pprLit1 :: Platform -> CmmLit -> SDoc pprLit1 platform lit = case lit of @@ -775,10 +774,6 @@ (text "MO_S_MulMayOflo") (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo" ++ " should have been handled earlier!") - MO_U_MulMayOflo _ -> pprTrace "offending mop:" - (text "MO_U_MulMayOflo") - (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo" - ++ " should have been handled earlier!") MO_V_Insert {} -> pprTrace "offending mop:" (text "MO_V_Insert") @@ -854,7 +849,7 @@ (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot" ++ " should have been handled earlier!") - MO_AlignmentCheck {} -> panic "-falignment-santisation not supported by unregisterised backend" + MO_AlignmentCheck {} -> panic "-falignment-sanitisation not supported by unregisterised backend" signedOp :: MachOp -> Bool -- Argument type(s) are signed ints signedOp (MO_S_Quot _) = True @@ -969,39 +964,37 @@ -- Not adding it for now (MO_Prefetch_Data _ ) -> unsupported - MO_I64_ToI -> dontReach64 - MO_I64_FromI -> dontReach64 - MO_W64_ToW -> dontReach64 - MO_W64_FromW -> dontReach64 - MO_x64_Neg -> dontReach64 - MO_x64_Add -> dontReach64 - MO_x64_Sub -> dontReach64 - MO_x64_Mul -> dontReach64 - MO_I64_Quot -> dontReach64 - MO_I64_Rem -> dontReach64 - MO_W64_Quot -> dontReach64 - MO_W64_Rem -> dontReach64 - MO_x64_And -> dontReach64 - MO_x64_Or -> dontReach64 - MO_x64_Xor -> dontReach64 - MO_x64_Not -> dontReach64 - MO_x64_Shl -> dontReach64 - MO_I64_Shr -> dontReach64 - MO_W64_Shr -> dontReach64 - MO_x64_Eq -> dontReach64 - MO_x64_Ne -> dontReach64 - MO_I64_Ge -> dontReach64 - MO_I64_Gt -> dontReach64 - MO_I64_Le -> dontReach64 - MO_I64_Lt -> dontReach64 - MO_W64_Ge -> dontReach64 - MO_W64_Gt -> dontReach64 - MO_W64_Le -> dontReach64 - MO_W64_Lt -> dontReach64 + MO_I64_ToI -> text "hs_int64ToInt" + MO_I64_FromI -> text "hs_intToInt64" + MO_W64_ToW -> text "hs_word64ToWord" + MO_W64_FromW -> text "hs_wordToWord64" + MO_x64_Neg -> text "hs_neg64" + MO_x64_Add -> text "hs_add64" + MO_x64_Sub -> text "hs_sub64" + MO_x64_Mul -> text "hs_mul64" + MO_I64_Quot -> text "hs_quotInt64" + MO_I64_Rem -> text "hs_remInt64" + MO_W64_Quot -> text "hs_quotWord64" + MO_W64_Rem -> text "hs_remWord64" + MO_x64_And -> text "hs_and64" + MO_x64_Or -> text "hs_or64" + MO_x64_Xor -> text "hs_xor64" + MO_x64_Not -> text "hs_not64" + MO_x64_Shl -> text "hs_uncheckedShiftL64" + MO_I64_Shr -> text "hs_uncheckedIShiftRA64" + MO_W64_Shr -> text "hs_uncheckedShiftRL64" + MO_x64_Eq -> text "hs_eq64" + MO_x64_Ne -> text "hs_ne64" + MO_I64_Ge -> text "hs_geInt64" + MO_I64_Gt -> text "hs_gtInt64" + MO_I64_Le -> text "hs_leInt64" + MO_I64_Lt -> text "hs_ltInt64" + MO_W64_Ge -> text "hs_geWord64" + MO_W64_Gt -> text "hs_gtWord64" + MO_W64_Le -> text "hs_leWord64" + MO_W64_Lt -> text "hs_ltWord64" where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop ++ " not supported!") - dontReach64 = panic ("pprCallishMachOp_for_C: " ++ show mop - ++ " should be not be encountered because the regular primop for this 64-bit operation is used instead.") -- --------------------------------------------------------------------- -- Useful #defines @@ -1210,7 +1203,7 @@ | not (needsCDecl lbl) = empty | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz | otherwise = - hcat [ visibility, label_type lbl , lparen, pprCLabel platform CStyle lbl, text ");" + hcat [ visibility, label_type lbl , lparen, pprCLabel platform lbl, text ");" -- occasionally useful to see label type -- , text "/* ", pprDebugCLabel lbl, text " */" ] @@ -1233,19 +1226,19 @@ -- 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 CStyle lbl + 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 { unTE :: TEState -> (a, TEState) } deriving (Functor) - -instance Applicative TE where - pure a = TE $ \s -> (a, s) - (<*>) = ap +newtype TE a = TE' (State TEState a) + deriving stock (Functor) + deriving (Applicative, Monad) via State TEState -instance Monad TE where - TE m >>= k = TE $ \s -> case m s of (a, s') -> unTE (k a) s' +pattern TE :: (TEState -> (a, TEState)) -> TE a +pattern TE f <- TE' (runState -> f) + where TE f = TE' (state f) +{-# COMPLETE TE #-} te_lbl :: CLabel -> TE () te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls)) @@ -1503,8 +1496,8 @@ <> text "void _hs_" <> attribute <> text "()" <> braces body where - body = vcat [ pprCLabel platform CStyle lbl <> text " ();" | lbl <- lbls ] - decls = vcat [ text "void" <+> pprCLabel platform CStyle lbl <> text " (void);" | lbl <- lbls ] + 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" diff --git a/GHC/CmmToLlvm.hs b/GHC/CmmToLlvm.hs --- a/GHC/CmmToLlvm.hs +++ b/GHC/CmmToLlvm.hs @@ -11,7 +11,7 @@ ) where -import GHC.Prelude +import GHC.Prelude hiding ( head ) import GHC.Llvm import GHC.CmmToLlvm.Base @@ -25,7 +25,6 @@ import GHC.StgToCmm.CgUtils ( fixStgRegisters ) import GHC.Cmm import GHC.Cmm.Dataflow.Collections -import GHC.Cmm.Ppr import GHC.Utils.BufHandle import GHC.Driver.Session @@ -38,6 +37,7 @@ import qualified GHC.Data.Stream as Stream import Control.Monad ( when, forM_ ) +import Data.List.NonEmpty ( head ) import Data.Maybe ( fromMaybe, catMaybes ) import System.IO @@ -69,7 +69,7 @@ "System LLVM version: " <> text (llvmVersionStr ver) $$ "We will try though..." let isS390X = platformArch (llvmCgPlatform cfg) == ArchS390X - let major_ver = head . llvmVersionList $ ver + let major_ver = head . llvmVersionNE $ ver when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $ "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+> "You are using LLVM version: " <> text (llvmVersionStr ver) @@ -110,8 +110,8 @@ header = let target = llvmCgLlvmTarget cfg llvmCfg = llvmCgLlvmConfig cfg - in text ("target datalayout = \"" ++ getDataLayout llvmCfg target ++ "\"") - $+$ text ("target triple = \"" ++ target ++ "\"") + in (text "target datalayout = \"" <> text (getDataLayout llvmCfg target) <> text "\"") + $+$ (text "target triple = \"" <> text target <> text "\"") getDataLayout :: LlvmConfig -> String -> String getDataLayout config target = diff --git a/GHC/CmmToLlvm/Base.hs b/GHC/CmmToLlvm/Base.hs --- a/GHC/CmmToLlvm/Base.hs +++ b/GHC/CmmToLlvm/Base.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -15,10 +15,6 @@ LiveGlobalRegs, LlvmUnresData, LlvmData, UnresLabel, UnresStatic, - LlvmVersion, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, - llvmVersionSupported, parseLlvmVersion, - llvmVersionStr, llvmVersionList, - LlvmM, runLlvm, withClearVars, varLookup, varInsert, markStackReg, checkStackReg, @@ -39,8 +35,6 @@ aliasify, llvmDefLabel ) where -#include "ghc-llvm-version.h" - import GHC.Prelude import GHC.Utils.Panic @@ -49,7 +43,6 @@ import GHC.CmmToLlvm.Config import GHC.Cmm.CLabel -import GHC.Cmm.Ppr.Expr () import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe ) import GHC.Driver.Session import GHC.Data.FastString @@ -65,11 +58,10 @@ import GHC.Utils.Logger import Data.Maybe (fromJust) -import Control.Monad (ap) -import Data.Char (isDigit) -import Data.List (sortBy, groupBy, intercalate, isPrefixOf) -import Data.Ord (comparing) +import Control.Monad.Trans.State (StateT (..)) +import Data.List (isPrefixOf) import qualified Data.List.NonEmpty as NE +import Data.Ord (comparing) -- ---------------------------------------------------------------------------- -- * Some Data Types @@ -201,7 +193,7 @@ -- 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 = groupBy sharesClass fprLive + 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 @@ -211,10 +203,10 @@ -- E.g. sortedRs = [ F2, XMM4, D5] -- output = [D1, D3] padded = concatMap padClass classes - padClass rs = go sortedRs [1..] + padClass rs = go (NE.toList sortedRs) 1 where - sortedRs = sortBy (comparing fpr_num) rs - maxr = last sortedRs + sortedRs = NE.sortBy (comparing fpr_num) rs + maxr = NE.last sortedRs ctor = fpr_ctor maxr go [] _ = [] @@ -225,10 +217,9 @@ 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:fs) - | fpr_num c == f = go cs fs -- already covered by a real register - | otherwise = ctor f : go (c:cs) fs -- add padding register - go _ _ = undefined -- unreachable + 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 fpr_ctor :: GlobalReg -> Int -> GlobalReg fpr_ctor (FloatReg _) = FloatReg @@ -261,42 +252,6 @@ llvmPtrBits platform = widthInBits $ typeWidth $ gcWord platform -- ---------------------------------------------------------------------------- --- * Llvm Version --- - -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 - --- ---------------------------------------------------------------------------- -- * Environment Handling -- @@ -321,15 +276,8 @@ -- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) } - deriving (Functor) - -instance Applicative LlvmM where - pure x = LlvmM $ \env -> return (x, env) - (<*>) = ap - -instance Monad LlvmM where - m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env - runLlvmM (f x) env' + deriving stock (Functor) + deriving (Applicative, Monad) via StateT LlvmEnv IO instance HasLogger LlvmM where getLogger = LlvmM $ \env -> return (envLogger env, env) @@ -492,8 +440,8 @@ strCLabel_llvm lbl = do ctx <- llvmCgContext <$> getConfig platform <- getPlatform - let sdoc = pprCLabel platform CStyle lbl - str = Outp.renderWithContext ctx sdoc + let sdoc = pprCLabel platform lbl + str = Outp.showSDocOneLine ctx sdoc return (fsLit str) -- ---------------------------------------------------------------------------- diff --git a/GHC/CmmToLlvm/CodeGen.hs b/GHC/CmmToLlvm/CodeGen.hs --- a/GHC/CmmToLlvm/CodeGen.hs +++ b/GHC/CmmToLlvm/CodeGen.hs @@ -19,7 +19,6 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm -import GHC.Cmm.Ppr as PprCmm import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm.Dataflow.Block @@ -760,7 +759,7 @@ let (vars', stmts) = unzip done return (vars', toOL stmts) --- | Cast an LLVM variable to a specific type, panicing if it can't be done. +-- | Cast an LLVM variable to a specific type, panicking if it can't be done. castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement) castVar signage v t | getVarType v == t = return (v, Nop) @@ -1205,10 +1204,10 @@ other -> pprPanic "genStore: ptr not right type!" - (PprCmm.pprExpr platform addr <+> text ( - "Size of Ptr: " ++ show (llvmPtrBits platform) ++ - ", Size of var: " ++ show (llvmWidthInBits platform other) ++ - ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg vaddr))) + (pdoc platform addr $$ + text "Size of Ptr:" <+> ppr (llvmPtrBits platform) $$ + text "Size of var:" <+> ppr (llvmWidthInBits platform other) $$ + text "Var:" <+> ppVar cfg vaddr) mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> LlvmStatement mkStore vval vptr alignment = @@ -1257,7 +1256,7 @@ lit = LMLitVar $ LMIntLit expLit expTy llvmExpectName - | isInt expTy = fsLit $ "llvm.expect." ++ renderWithContext (llvmCgContext cfg) (ppr expTy) + | isInt expTy = fsLit $ "llvm.expect." ++ showSDocOneLine (llvmCgContext cfg) (ppr expTy) | otherwise = panic "genExpectedLit: Type not an int!" (llvmExpect, stmts, top) <- @@ -1453,7 +1452,6 @@ MO_S_MulMayOflo _ -> panicOp MO_S_Quot _ -> panicOp MO_S_Rem _ -> panicOp - MO_U_MulMayOflo _ -> panicOp MO_U_Quot _ -> panicOp MO_U_Rem _ -> panicOp @@ -1635,8 +1633,6 @@ MO_Sub _ -> genBinMach LM_MO_Sub MO_Mul _ -> genBinMach LM_MO_Mul - MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!" - MO_S_MulMayOflo w -> isSMulOK w x y MO_S_Quot _ -> genBinMach LM_MO_SDiv @@ -1707,7 +1703,6 @@ where binLlvmOp ty binOp allow_y_cast = do - cfg <- getConfig platform <- getPlatform runExprData $ do vx <- exprToVarW x @@ -1723,13 +1718,7 @@ doExprW (ty vx) $ binOp vx vy' | otherwise - -> do - -- Error. Continue anyway so we can debug the generated ll file. - let render = renderWithContext (llvmCgContext cfg) - cmmToStr = (lines . render . PprCmm.pprExpr platform) - statement $ Comment $ map fsLit $ cmmToStr x - statement $ Comment $ map fsLit $ cmmToStr y - doExprW (ty vx) $ binOp vx vy + -> pprPanic "binLlvmOp types" (pdoc platform x $$ pdoc platform y) binCastLlvmOp ty binOp = runExprData $ do vx <- exprToVarW x @@ -1883,10 +1872,10 @@ doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic ptr align) other -> pprPanic "exprToVar: CmmLoad expression is not right type!" - (PprCmm.pprExpr platform e <+> text ( - "Size of Ptr: " ++ show (llvmPtrBits platform) ++ - ", Size of var: " ++ show (llvmWidthInBits platform other) ++ - ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg iptr))) + (pdoc platform e $$ + text "Size of Ptr:" <+> ppr (llvmPtrBits platform) $$ + text "Size of var:" <+> ppr (llvmWidthInBits platform other) $$ + text "Var:" <+> (ppVar cfg iptr)) {- Note [Alignment of vector-typed values] diff --git a/GHC/CmmToLlvm/Config.hs b/GHC/CmmToLlvm/Config.hs --- a/GHC/CmmToLlvm/Config.hs +++ b/GHC/CmmToLlvm/Config.hs @@ -1,20 +1,35 @@ +{-# 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.Driver.Session +import GHC.Settings.Utils +import GHC.Utils.Panic +import Data.Char (isDigit) +import Data.List (intercalate) import qualified Data.List.NonEmpty as NE - -newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } - deriving (Eq, Ord) +import System.FilePath data LlvmCgConfig = LlvmCgConfig { llvmCgPlatform :: !Platform -- ^ Target platform @@ -25,7 +40,96 @@ , llvmCgLlvmVersion :: Maybe LlvmVersion -- ^ version of Llvm we're using , llvmCgDoWarn :: !Bool -- ^ True ==> warn unsupported Llvm version , llvmCgLlvmTarget :: !String -- ^ target triple passed to LLVM - , llvmCgLlvmConfig :: !LlvmConfig -- ^ mirror DynFlags LlvmConfig. - -- see Note [LLVM configuration] in "GHC.SysTools". This can be strict since - -- GHC.Driver.Config.CmmToLlvm.initLlvmCgConfig verifies the files are present. + , llvmCgLlvmConfig :: !LlvmConfig -- ^ Supported LLVM configurations. + -- see Note [LLVM configuration] } + +data LlvmTarget = LlvmTarget + { lDataLayout :: String + , lCPU :: String + , lAttributes :: [String] + } + +-- Note [LLVM configuration] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain +-- information needed by the LLVM backend to invoke `llc` and `opt`. +-- Specifically: +-- +-- * llvm-targets maps autoconf host triples to the corresponding LLVM +-- `data-layout` declarations. This information is extracted from clang using +-- the script in utils/llvm-targets/gen-data-layout.sh and should be updated +-- whenever we target a new version of LLVM. +-- +-- * llvm-passes maps GHC optimization levels to sets of LLVM optimization +-- flags that GHC should pass to `opt`. +-- +-- This information is contained in files rather the GHC source to allow users +-- to add new targets to GHC without having to recompile the compiler. +-- + +initLlvmConfig :: FilePath -> IO LlvmConfig +initLlvmConfig top_dir + = do + targets <- readAndParse "llvm-targets" + passes <- readAndParse "llvm-passes" + return $ LlvmConfig + { llvmTargets = fmap mkLlvmTarget <$> targets + , llvmPasses = passes + } + where + readAndParse :: Read a => String -> IO a + readAndParse name = do + let f = top_dir name + llvmConfigStr <- readFile f + case maybeReadFuzzy llvmConfigStr of + Just s -> return s + Nothing -> pgmError ("Can't parse LLVM config file: " ++ show f) + + mkLlvmTarget :: (String, String, String) -> LlvmTarget + mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs) + +data LlvmConfig = LlvmConfig + { 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 @@ -138,9 +138,6 @@ RelocatableReadOnlyData -> case platformOS p of OSMinGW32 -> fsLit ".rdata$rel.ro" _ -> fsLit ".data.rel.ro" - ReadOnlyData16 -> case platformOS p of - OSMinGW32 -> fsLit ".rdata$cst16" - _ -> fsLit ".rodata.cst16" Data -> fsLit ".data" UninitialisedData -> fsLit ".bss" CString -> case platformOS p of diff --git a/GHC/CmmToLlvm/Ppr.hs b/GHC/CmmToLlvm/Ppr.hs --- a/GHC/CmmToLlvm/Ppr.hs +++ b/GHC/CmmToLlvm/Ppr.hs @@ -56,7 +56,7 @@ funDec <- llvmFunSig live lbl link cfg <- getConfig platform <- getPlatform - let buildArg = fsLit . renderWithContext (llvmCgContext cfg). ppPlainName cfg + let buildArg = fsLit . showSDocOneLine (llvmCgContext cfg). ppPlainName cfg funArgs = map buildArg (llvmFunArgs platform live) funSect = llvmFunSection cfg (decName funDec) diff --git a/GHC/Core.hs b/GHC/Core.hs --- a/GHC/Core.hs +++ b/GHC/Core.hs @@ -7,9 +7,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection module GHC.Core ( -- * Main data types @@ -42,9 +39,11 @@ -- ** Simple 'Expr' access functions and predicates bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, + foldBindersOfBindStrict, foldBindersOfBindsStrict, collectBinders, collectTyBinders, collectTyAndValBinders, - collectNBinders, + collectNBinders, collectNValBinders_maybe, collectArgs, stripNArgs, collectArgsTicks, flattenBinds, + collectFunSimple, exprToType, wrapLamBody, @@ -64,7 +63,8 @@ maybeUnfoldingTemplate, otherCons, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, - isStableUnfolding, isInlineUnfolding, isBootUnfolding, + isStableUnfolding, isStableUserUnfolding, isStableSystemUnfolding, + isInlineUnfolding, isBootUnfolding, hasCoreUnfolding, hasSomeUnfolding, canUnfold, neverUnfoldGuidance, isStableSource, @@ -82,9 +82,8 @@ IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor, -- * Core rule data types - CoreRule(..), RuleBase, - RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, - RuleEnv(..), RuleOpts(..), mkRuleEnv, emptyRuleEnv, + CoreRule(..), + RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts, -- ** Operations on 'CoreRule's ruleArity, ruleName, ruleIdName, ruleActivation, @@ -99,9 +98,9 @@ import GHC.Types.Var import GHC.Core.Type import GHC.Core.Coercion +import GHC.Core.Rules.Config ( RuleOpts ) import GHC.Types.Name import GHC.Types.Name.Set -import GHC.Types.Name.Env( NameEnv ) import GHC.Types.Literal import GHC.Types.Tickish import GHC.Core.DataCon @@ -175,7 +174,6 @@ -- * Primitive literals -- -- * Applications: note that the argument may be a 'Type'. --- See Note [Core let/app invariant] -- See Note [Representation polymorphism invariants] -- -- * Lambda abstraction @@ -186,7 +184,7 @@ -- bound and then executing the sub-expression. -- -- See Note [Core letrec invariant] --- See Note [Core let/app invariant] +-- See Note [Core let-can-float invariant] -- See Note [Representation polymorphism invariants] -- See Note [Core type and coercion invariant] -- @@ -383,6 +381,25 @@ For the non-top-level, non-recursive case see Note [Core let-can-float invariant]. +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. + +* In the source language, there is no way to bind a primitive string literal + at the top level. + +* 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. + +* In STG, top-level string literals are explicitly represented in the syntax + tree. + +* 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. + Note [Core let-can-float invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The let-can-float invariant: @@ -479,47 +496,6 @@ 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 - -This means that the let can be floated around -without difficulty. For example, this is OK: - - y::Int# = x +# 1# - -But this is not, as it may affect termination if the -expression is floated out: - - y::Int# = fac 4# - -In this situation you should use @case@ rather than a @let@. The function -'GHC.Core.Utils.needsCaseBinding' can help you determine which to generate, or -alternatively use 'GHC.Core.Make.mkCoreLet' rather than this constructor directly, -which will generate a @case@ if necessary - -The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in -GHC.Core.Make. - -* 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 @@ -797,18 +773,18 @@ the binder. Reason: if we want to push a continuation into the RHS we must push it into the unfolding as well. - 2b. The Arity (in the IdInfo) of a join point is the number of value - binders in the top n lambdas, where n is the join arity. + 2b. The Arity (in the IdInfo) of a join point varies independently of the + join-arity. For example, we could have + j x = case x of { T -> \y.y; F -> \y.3 } + Its join-arity is 1, but its idArity is 2; and we do not eta-expand + join points: see Note [Do not eta-expand join points] in + GHC.Core.Opt.Simplify.Utils. - So arity <= join arity; the former counts only value binders - while the latter counts all binders. - e.g. Suppose $j has join arity 1 - let j = \x y. e in case x of { A -> j 1; B -> j 2 } - Then its ordinary arity is also 1, not 2. + Allowing the idArity to be bigger than the join-arity is + important in arityType; see GHC.Core.Opt.Arity + Note [Arity for recursive join bindings] - The arity of a join point isn't very important; but short of setting - it to zero, it is helpful to have an invariant. E.g. #17294. - See also Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils. + Historical note: see #17294. 3. If the binding is recursive, then all other bindings in the recursive group must also be join points. @@ -819,11 +795,11 @@ However, join points have simpler invariants in other ways 5. A join point can have an unboxed type without the RHS being - ok-for-speculation (i.e. drop the let/app invariant) + ok-for-speculation (i.e. drop the let-can-float invariant) e.g. let j :: Int# = factorial x in ... 6. The RHS of join point is not required to have a fixed runtime representation, - e.g. let j :: r :: TYPE l = fail void# in ... + e.g. let j :: r :: TYPE l = fail (##) in ... This happened in an intermediate program #13394 Examples: @@ -1111,6 +1087,12 @@ M. But it's painful, because it means we need to keep track of all the orphan modules below us. + * The "visible orphan modules" are all the orphan module in the transitive + closure of the imports of this module. + + * During instance lookup, we filter orphan instances depending on + whether or not the instance is in a visible orphan module. + * A non-orphan is not finger-printed separately. Instead, for fingerprinting purposes it is treated as part of the entity it mentions on the LHS. For example @@ -1125,12 +1107,20 @@ Orphan-hood is computed * For class instances: - when we make a ClsInst - (because it is needed during instance lookup) + when we make a ClsInst in GHC.Core.InstEnv.mkLocalInstance + (because it is needed during instance lookup) + See Note [When exactly is an instance decl an orphan?] + in GHC.Core.InstEnv - * For rules and family instances: - when we generate an IfaceRule (GHC.Iface.Make.coreRuleToIfaceRule) - or IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst) + * For rules + when we generate a CoreRule (GHC.Core.Rules.mkRule) + + * For family instances: + when we generate an IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst) + +Orphan-hood is persisted into interface files, in ClsInst, FamInst, +and CoreRules. + -} {- @@ -1145,50 +1135,7 @@ representation. -} --- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules -type RuleBase = NameEnv [CoreRule] - -- The rules are unordered; - -- we sort out any overlaps on lookup --- | A full rule environment which we can apply rules from. Like a 'RuleBase', --- but it also includes the set of visible orphans we use to filter out orphan --- rules which are not visible (even though we can see them...) -data RuleEnv - = RuleEnv { re_base :: [RuleBase] -- See Note [Why re_base is a list] - , re_visible_orphs :: ModuleSet - } - -mkRuleEnv :: RuleBase -> [Module] -> RuleEnv -mkRuleEnv rules vis_orphs = RuleEnv [rules] (mkModuleSet vis_orphs) - -emptyRuleEnv :: RuleEnv -emptyRuleEnv = RuleEnv [] emptyModuleSet - -{- -Note [Why re_base is a list] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In Note [Overall plumbing for rules], it is explained that the final -RuleBase which we must consider is combined from 4 different sources. - -During simplifier runs, the fourth source of rules is constantly being updated -as new interfaces are loaded into the EPS. Therefore just before we check to see -if any rules match we get the EPS RuleBase and combine it with the existing RuleBase -and then perform exactly 1 lookup into the new map. - -It is more efficient to avoid combining the environments and store the uncombined -environments as we can instead perform 1 lookup into each environment and then combine -the results. - -Essentially we use the identity: - -> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2) -> = lookupNameEnv n rb1 ++ lookupNameEnv n rb2 - -The latter being more efficient as we don't construct an intermediate -map. --} - -- | A 'CoreRule' is: -- -- * \"Local\" if the function it is a rule for is defined in the @@ -1203,7 +1150,7 @@ -- Rough-matching stuff -- see comments with InstEnv.ClsInst( is_cls, is_rough ) - ru_fn :: Name, -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule + ru_fn :: !Name, -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side -- Proper-matching stuff @@ -1254,18 +1201,11 @@ } -- See Note [Extra args in the target] in GHC.Core.Rules --- | 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 - } +type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr -- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are -- currently in scope. See Note [The InScopeSet invariant]. -type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr -type InScopeEnv = (InScopeSet, IdUnfoldingFun) +data InScopeEnv = ISE InScopeSet IdUnfoldingFun type IdUnfoldingFun = Id -> Unfolding -- A function that embodies how to unfold an Id if you need @@ -1389,36 +1329,6 @@ -- uf_guidance: Tells us about the /size/ of the unfolding template ------------------------------------------------- -data UnfoldingSource - = -- See also Note [Historical note: unfoldings for wrappers] - - InlineRhs -- The current rhs of the function - -- Replace uf_tmpl each time around - - | InlineStable -- From an INLINE or INLINABLE pragma - -- INLINE if guidance is UnfWhen - -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever - -- (well, technically an INLINABLE might be made - -- UnfWhen if it was small enough, and then - -- it will behave like INLINE outside the current - -- module, but that is the way automatic unfoldings - -- work so it is consistent with the intended - -- meaning of INLINABLE). - -- - -- uf_tmpl may change, but only as a result of - -- gentle simplification, it doesn't get updated - -- to the current RHS during compilation as with - -- InlineRhs. - -- - -- See Note [InlineStable] - - | InlineCompulsory -- Something that *has* no binding, so you *must* inline it - -- Only a few primop-like things have this property - -- (see "GHC.Types.Id.Make", calls to mkCompulsoryUnfolding). - -- Inline absolutely always, however boring the context. - - -- | Properties of a 'CoreUnfolding' that could be computed on-demand from its template. -- See Note [UnfoldingCache] data UnfoldingCache @@ -1555,18 +1465,12 @@ mkOtherCon :: [AltCon] -> Unfolding mkOtherCon = OtherCon -isStableSource :: UnfoldingSource -> Bool --- Keep the unfolding template -isStableSource InlineCompulsory = True -isStableSource InlineStable = True -isStableSource InlineRhs = False - -- | 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 wnen specialising, and we do +-- maybeUnfoldingTemplate is used mainly when specialising, and we do -- want to specialise DFuns, so it's important to return a template -- for DFunUnfoldings maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr @@ -1588,6 +1492,7 @@ isValueUnfolding :: Unfolding -> Bool -- Returns False for OtherCon isValueUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache +isValueUnfolding (DFunUnfolding {}) = True isValueUnfolding _ = False -- | Determines if it possibly the case that the unfolding will @@ -1595,9 +1500,10 @@ -- for 'OtherCon' isEvaldUnfolding :: Unfolding -> Bool -- Returns True for OtherCon -isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (DFunUnfolding {}) = True isEvaldUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache -isEvaldUnfolding _ = False +isEvaldUnfolding _ = False -- | @True@ if the unfolding is a constructor application, the application -- of a CONLIKE function or 'OtherCon' @@ -1625,8 +1531,8 @@ expandUnfolding_maybe _ = Nothing isCompulsoryUnfolding :: Unfolding -> Bool -isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True -isCompulsoryUnfolding _ = False +isCompulsoryUnfolding (CoreUnfolding { uf_src = src }) = isCompulsorySource src +isCompulsoryUnfolding _ = False isStableUnfolding :: Unfolding -> Bool -- True of unfoldings that should not be overwritten @@ -1635,6 +1541,16 @@ isStableUnfolding (DFunUnfolding {}) = True isStableUnfolding _ = False +isStableUserUnfolding :: Unfolding -> Bool +-- True of unfoldings that arise from an INLINE or INLINEABLE pragma +isStableUserUnfolding (CoreUnfolding { uf_src = src }) = isStableUserSource src +isStableUserUnfolding _ = False + +isStableSystemUnfolding :: Unfolding -> Bool +-- True of unfoldings that arise from an INLINE or INLINEABLE pragma +isStableSystemUnfolding (CoreUnfolding { uf_src = src }) = isStableSystemSource src +isStableSystemUnfolding _ = False + isInlineUnfolding :: Unfolding -> Bool -- ^ True of a /stable/ unfolding that is -- (a) always inlined; that is, with an `UnfWhen` guidance, or @@ -1691,8 +1607,8 @@ We consider even a StableUnfolding as fragile, because it needs substitution. -Note [InlineStable] -~~~~~~~~~~~~~~~~~ +Note [Stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~ When you say {-# INLINE f #-} f x = @@ -1702,10 +1618,11 @@ leaving the original unfolding intact in Unfolding of 'f'. For example all xs = foldr (&&) True xs any p = all . map p {-# INLINE any #-} -We optimise any's RHS fully, but leave the InlineRule saying "all . map p", -which deforests well at the call site. +We optimise any's RHS fully, but leave the stable unfolding for `any` +saying "all . map p", which deforests well at the call site. -So INLINE pragma gives rise to an InlineRule, which captures the original RHS. +So INLINE pragma gives rise to a stable unfolding, which captures the +original RHS. Moreover, it's only used when 'f' is applied to the specified number of arguments; that is, the number of argument on @@ -1719,9 +1636,6 @@ it'd only inline when applied to three arguments. This slightly-experimental change was requested by Roman, but it seems to make sense. -See also Note [Inlining an InlineRule] in GHC.Core.Unfold. - - Note [OccInfo in unfoldings and rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In unfoldings and rules, we guarantee that the template is occ-analysed, @@ -1953,8 +1867,8 @@ mkDoubleLitDouble d = Lit (mkLitDouble (toRational d)) -- | Bind all supplied binding groups over an expression in a nested let expression. Assumes --- that the rhs satisfies the let/app invariant. Prefer to use 'GHC.Core.Make.mkCoreLets' if --- possible, which does guarantee the invariant +-- that the rhs satisfies the let-can-float invariant. Prefer to use +-- 'GHC.Core.Make.mkCoreLets' if possible, which does guarantee the invariant mkLets :: [Bind b] -> Expr b -> Expr b -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to -- use 'GHC.Core.Make.mkCoreLams' if possible @@ -2036,6 +1950,21 @@ bindersOfBinds :: [Bind b] -> [b] bindersOfBinds binds = foldr ((++) . bindersOf) [] binds +-- We inline this to avoid unknown function calls. +{-# INLINE foldBindersOfBindStrict #-} +foldBindersOfBindStrict :: (a -> b -> a) -> a -> Bind b -> a +foldBindersOfBindStrict f + = \z bind -> case bind of + NonRec b _rhs -> f z b + Rec pairs -> foldl' f z $ map fst pairs + +{-# INLINE foldBindersOfBindsStrict #-} +foldBindersOfBindsStrict :: (a -> b -> a) -> a -> [Bind b] -> a +foldBindersOfBindsStrict f = \z binds -> foldl' fold_bind z binds + where + fold_bind = (foldBindersOfBindStrict f) + + rhssOfBind :: Bind b -> [Expr b] rhssOfBind (NonRec _ rhs) = [rhs] rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] @@ -2057,10 +1986,12 @@ collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) collectValBinders :: CoreExpr -> ([Id], CoreExpr) collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) --- | Strip off exactly N leading lambdas (type or value). Good for use with --- join points. -collectNBinders :: Int -> Expr b -> ([b], Expr b) +-- | Strip off exactly N leading lambdas (type or value). +-- Good for use with join points. +-- Panic if there aren't enough +collectNBinders :: JoinArity -> Expr b -> ([b], Expr b) + collectBinders expr = go [] expr where @@ -2092,6 +2023,18 @@ go n bs (Lam b e) = go (n-1) (b:bs) e go _ _ _ = pprPanic "collectNBinders" $ int orig_n +-- | Strip off exactly N leading value lambdas +-- returning all the binders found up to that point +-- Return Nothing if there aren't enough +collectNValBinders_maybe :: Arity -> CoreExpr -> Maybe ([Var], CoreExpr) +collectNValBinders_maybe orig_n orig_expr + = go orig_n [] orig_expr + where + go 0 bs expr = Just (reverse bs, expr) + go n bs (Lam b e) | isId b = go (n-1) (b:bs) e + | otherwise = go n (b:bs) e + go _ _ _ = Nothing + -- | Takes a nested application expression and returns the function -- being applied and the arguments to which it is applied collectArgs :: Expr b -> (Expr b, [Arg b]) @@ -2100,6 +2043,19 @@ where go (App f a) as = go f (a:as) go e as = (e, as) + +-- | Takes a nested application expression and returns the function +-- being applied. Looking through casts and ticks to find it. +collectFunSimple :: Expr b -> Expr b +collectFunSimple expr + = go expr + where + go expr' = + case expr' of + App f _a -> go f + Tick _t e -> go e + Cast e _co -> go e + e -> e -- | fmap on the body of a lambda. -- wrapLamBody f (\x -> body) == (\x -> f body) diff --git a/GHC/Core.hs-boot b/GHC/Core.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core.hs-boot @@ -0,0 +1,8 @@ +module GHC.Core where +import {-# SOURCE #-} GHC.Types.Var + +data Expr a + +type CoreBndr = Var + +type CoreExpr = Expr CoreBndr diff --git a/GHC/Core/Coercion.hs b/GHC/Core/Coercion.hs --- a/GHC/Core/Coercion.hs +++ b/GHC/Core/Coercion.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,7 +13,9 @@ -- module GHC.Core.Coercion ( -- * Main data type - Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionN, MCoercionR, + Coercion, CoercionN, CoercionR, CoercionP, + MCoercion(..), MCoercionN, MCoercionR, + CoSel(..), FunSel(..), UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar, LeftOrRight(..), @@ -34,8 +37,10 @@ mkAxInstLHS, mkUnbranchedAxInstLHS, mkPiCo, mkPiCos, mkCoCast, mkSymCo, mkTransCo, - mkNthCo, mkNthCoFunCo, nthCoRole, mkLRCo, - mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkFunResCo, + mkSelCo, getNthFun, getNthFromType, mkLRCo, + mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, + mkFunCo1, mkFunCo2, mkFunCoNoFTF, mkFunResCo, + mkNakedFunCo1, mkNakedFunCo2, mkForAllCo, mkForAllCos, mkHomoForAllCos, mkPhantomCo, mkHoleCo, mkUnivCo, mkSubCo, @@ -44,28 +49,24 @@ mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, mkKindCo, castCoercionKind, castCoercionKind1, castCoercionKind2, - mkFamilyTyConAppCo, - mkHeteroCoercionType, mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, -- ** Decomposition instNewTyCon_maybe, - NormaliseStepper, NormaliseStepResult(..), composeSteppers, - mapStepResult, unwrapNewTypeStepper, + NormaliseStepper, NormaliseStepResult(..), composeSteppers, unwrapNewTypeStepper, topNormaliseNewType_maybe, topNormaliseTypeX, decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe, - splitTyConAppCo_maybe, splitAppCo_maybe, splitFunCo_maybe, splitForAllCo_maybe, splitForAllCo_ty_maybe, splitForAllCo_co_maybe, - nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, - + tyConRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, + tyConRoleListX, tyConRoleListRepresentational, funRole, pickLR, isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, @@ -78,7 +79,6 @@ -- ** Coercion variables mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, - isCoVar_maybe, -- ** Free variables tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, @@ -98,7 +98,7 @@ liftCoSubstVarBndrUsing, isMappedByLC, mkSubstLiftingContext, zapLiftingContext, - substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet, + substForAllCoBndrUsingLC, lcSubst, lcInScopeSet, LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, @@ -121,7 +121,7 @@ -- * Other promoteCoercion, buildCoercion, - multToCo, + multToCo, mkRuntimeRepCo, hasCoercionHoleTy, hasCoercionHoleCo, hasThisCoercionHoleTy, @@ -138,17 +138,18 @@ 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 {-# SOURCE #-} GHC.Core.Utils ( mkFunctionType ) 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 @@ -156,6 +157,8 @@ 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 @@ -248,7 +251,7 @@ -> TyCon -> CoAxBranch -> SDoc ppr_co_ax_branch ppr_rhs fam_tc branch = foldr1 (flip hangNotEmpty 2) - [ pprUserForAll (mkTyCoVarBinders Inferred bndrs') + [ 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 @@ -293,7 +296,7 @@ (env', bndr') = tidyVarBndr env bndr env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) wild_bndr = setVarName bndr $ - tidyNameOcc (varName bndr) (mkTyVarOcc "_") + tidyNameOcc (varName bndr) (mkTyVarOccFS (fsLit "_")) -- Tidy the binder to "_" is_wildcard :: Var -> Bool @@ -311,7 +314,7 @@ 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 dicussion on this point +-- See #19815 for a bit of data and discussion on this point coToMCo co | isReflCo co = MRefl | otherwise = MCo co @@ -366,9 +369,9 @@ mkPiMCos _ MRefl = MRefl mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co) -mkFunResMCo :: Scaled Type -> MCoercionR -> MCoercionR +mkFunResMCo :: Id -> MCoercionR -> MCoercionR mkFunResMCo _ MRefl = MRefl -mkFunResMCo arg_ty (MCo co) = MCo (mkFunResCo Representational arg_ty co) +mkFunResMCo arg_id (MCo co) = MCo (mkFunResCo Representational arg_id co) mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion mkGReflLeftMCo r ty MRefl = mkReflCo r ty @@ -393,48 +396,35 @@ Destructing coercions %* * %************************************************************************ - -Note [Function coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Remember that - (->) :: forall {r1} {r2}. TYPE r1 -> TYPE r2 -> TYPE LiftedRep -whose `RuntimeRep' arguments are intentionally marked inferred to -avoid type application. - -Hence - FunCo r mult co1 co2 :: (s1->t1) ~r (s2->t2) -is short for - TyConAppCo (->) mult co_rep1 co_rep2 co1 co2 -where co_rep1, co_rep2 are the coercions on the representations. -} - -- | 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 - -> [Role] -- the roles of the output coercions - -- this must have at least as many - -- entries as the Arity provided + -> Infinite Role -- the roles of the output coercions -> [Coercion] decomposeCo arity co rs - = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ] - -- Remember, Nth is zero-indexed + = [mkSelCo (SelTyCon n r) co | (n,r) <- [0..(arity-1)] `zip` Inf.toList rs ] + -- Remember, SelTyCon is zero-indexed decomposeFunCo :: HasDebugCallStack - => Role -- Role of the input coercion - -> Coercion -- Input coercion + => Coercion -- Input coercion -> (CoercionN, Coercion, Coercion) --- Expects co :: (s1 -> t1) ~ (s2 -> t2) --- Returns (co1 :: s1~s2, co2 :: t1~t2) --- See Note [Function coercions] for the "3" and "4" +-- 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 _ w co1 co2) = (w, co1, co2) - -- Short-circuits the calls to mkNthCo +decomposeFunCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) + = (w, co1, co2) + -- Short-circuits the calls to mkSelCo -decomposeFunCo r co = assertPpr all_ok (ppr co) - (mkNthCo Nominal 0 co, mkNthCo r 3 co, mkNthCo r 4 co) +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 @@ -474,13 +464,13 @@ 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 = mkEmptyTCvSubst $ mkInScopeSet $ + orig_subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co go :: [CoercionN] -- accumulator for argument coercions, reversed - -> (TCvSubst,Kind) -- Lhs kind of coercion + -> (Subst,Kind) -- Lhs kind of coercion -> CoercionN -- coercion originally applied to the function - -> (TCvSubst,Kind) -- Rhs kind of coercion + -> (Subst,Kind) -- Rhs kind of coercion -> [Type] -- Arguments to that function -> ([CoercionN], Coercion) -- Invariant: co :: subst1(k1) ~ subst2(k2) @@ -495,55 +485,45 @@ -- ty :: s2 -- need arg_co :: s2 ~ s1 -- res_co :: t1[ty |> arg_co / a] ~ t2[ty / b] - = let arg_co = mkNthCo Nominal 0 (mkSymCo co) + = 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 (_w1, _s1, t1) <- splitFunTy_maybe k1 - , Just (_w1, _s2, t2) <- splitFunTy_maybe k2 + | 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 Nominal co - -- It should be fine to ignore the multiplicity bit of the coercion - -- for a Nominal coercion. - arg_co = mkSymCo sym_arg_co + = 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 (zapTCvSubst subst1, substTy subst1 k1) + = go acc_arg_cos (zapSubst subst1, substTy subst1 k1) co - (zapTCvSubst subst2, substTy subst1 k2) + (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) --- | Attempts to obtain the type variable underlying a 'Coercion' +-- | 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 --- | Attempts to tease a coercion apart into a type constructor and the application --- of a number of coercion arguments to that constructor -splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) -splitTyConAppCo_maybe co - | Just (ty, r) <- isReflCo_maybe co - = do { (tc, tys) <- splitTyConApp_maybe ty - ; let args = zipWith mkReflCo (tyConRolesX r tc) tys - ; return (tc, args) } -splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos) -splitTyConAppCo_maybe (FunCo _ w arg res) = Just (funTyCon, cos) - where cos = [w, mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res] -splitTyConAppCo_maybe _ = Nothing - multToCo :: Mult -> Coercion multToCo r = mkNomReflCo r @@ -556,10 +536,10 @@ , Just (args', arg') <- snocView args = Just ( mkTyConAppCo r tc args', arg' ) - | not (mustBeSaturated tc) + | not (tyConMustBeSaturated tc) -- Never create unsaturated type family apps! , Just (args', arg') <- snocView args - , Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg' + , 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 @@ -572,7 +552,7 @@ -- Only used in specialise/Rules splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) -splitFunCo_maybe (FunCo _ _ arg res) = Just (arg, res) +splitFunCo_maybe (FunCo { fco_arg = arg, fco_res = res }) = Just (arg, res) splitFunCo_maybe _ = Nothing splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion) @@ -632,15 +612,41 @@ | otherwise = pprPanic "eqTyConRole: unknown tycon" (ppr tc) --- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@, --- produce a coercion @rep_co :: r1 ~ r2@. +-- | 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 - = mkNthCo Nominal 0 kind_co + = assert (isTYPEorCONSTRAINT k1 && isTYPEorCONSTRAINT k2) $ + mkSelCo (SelTyCon 0 Nominal) kind_co where kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2 - -- (up to silliness with Constraint) + 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 @@ -712,7 +718,6 @@ Note [Role twiddling functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - There are a plethora of functions for twiddling roles: mkSubCo: Requires a nominal input coercion and always produces a @@ -778,15 +783,11 @@ -- caller's responsibility to get the roles correct on argument coercions. mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkTyConAppCo r tc cos - | [w, _rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions] - , isFunTyCon tc - = -- (a :: TYPE ra) -> (b :: TYPE rb) ~ (c :: TYPE rc) -> (d :: TYPE rd) - -- rep1 :: ra ~ rc rep2 :: rb ~ rd - -- co1 :: a ~ c co2 :: b ~ d - mkFunCo r w co1 co2 + | Just co <- tyConAppFunCo_maybe r tc cos + = co - -- Expand type synonyms - | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos + -- 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 @@ -795,17 +796,86 @@ | 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)@. -mkFunCo :: Role -> CoercionN -> Coercion -> Coercion -> Coercion -mkFunCo r w co1 co2 - -- See Note [Refl invariant] - | Just (ty1, _) <- isReflCo_maybe co1 - , Just (ty2, _) <- isReflCo_maybe co2 - , Just (w, _) <- isReflCo_maybe w - = mkReflCo r (mkVisFunTy w ty1 ty2) - | otherwise = FunCo r w co1 co2 +-- 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. @@ -822,15 +892,14 @@ -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102) = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) where - zip_roles (r1:_) [] = [downgradeRole r1 Nominal arg] - zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys - zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... + 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) !! (length args) + 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 @@ -878,7 +947,7 @@ 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-list. We *have* proved that the +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. -} @@ -889,7 +958,7 @@ -- See Note [Unused coercion variable in ForAllCo] mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion mkForAllCo v kind_co co - | assert (varType v `eqType` (pFst $ coercionKind kind_co)) True + | assert (varType v `eqType` (coercionLKind kind_co)) True , assert (isTyVar v || almostDevoidCoVarOfCo v co) True , Just (ty, r) <- isReflCo_maybe co , isGReflCo kind_co @@ -902,12 +971,12 @@ -- 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` (pFst $ coercionKind kind_co)) True - , assert (isTyVar v || almostDevoidCoVarOfCo v co) True + | 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) - = FunCo (coercionRole co) (multToCo Many) kind_co co + = mkFunCoNoFTF (coercionRole co) (multToCo ManyTy) kind_co co -- Functions from coercions are always unrestricted | otherwise = ForAllCo v kind_co co @@ -957,16 +1026,9 @@ optCoercion. Not a big deal either way. -} --- | 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.) -isCoVar_maybe :: Coercion -> Maybe CoVar -isCoVar_maybe (CoVarCo cv) = Just cv -isCoVar_maybe _ = Nothing - mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Coercion --- mkAxInstCo can legitimately be called over-staturated; +-- 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 $ @@ -1075,142 +1137,85 @@ = GRefl r t1 (MCo $ mkTransCo co1 co2) mkTransCo co1 co2 = TransCo co1 co2 -mkNthCo :: HasDebugCallStack - => Role -- The role of the coercion you're creating - -> Int -- Zero-indexed +mkSelCo :: HasDebugCallStack + => CoSel -> Coercion -> Coercion -mkNthCo r n co - = assertPpr good_call bad_call_msg $ - go n co +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 0 co - | Just (ty, _) <- isReflCo_maybe co - , Just (tv, _) <- splitForAllTyCoVar_maybe ty - = -- works for both tyvar and covar - assert (r == Nominal) $ - mkNomReflCo (varType tv) - - go n co - | Just (ty, r0) <- isReflCo_maybe co - , let tc = tyConAppTyCon ty - = assertPpr (ok_tc_app ty n) (ppr n $$ ppr ty) $ - assert (nthRole r0 tc n == r) $ - mkReflCo r (tyConAppArgN n ty) - where ok_tc_app :: Type -> Int -> Bool - ok_tc_app ty n - | Just (_, tys) <- splitTyConApp_maybe ty - = tys `lengthExceeds` n - | isForAllTy ty -- nth:0 pulls out a kind coercion from a hetero forall - = n == 0 - | otherwise - = False + go cs co + | Just (ty, r) <- isReflCo_maybe co + = Just (mkReflCo r (getNthFromType cs ty)) - go 0 (ForAllCo _ kind_co _) - = assert (r == Nominal) - kind_co + go SelForAll (ForAllCo _ kind_co _) + = Just kind_co -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) - -- then (nth 0 co :: k1 ~N k2) + -- then (nth SelForAll co :: k1 ~N k2) -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) - -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) + -- then (nth SelForAll co :: (t1 ~ t2) ~N (t3 ~ t4)) - go n (FunCo _ w arg res) - = mkNthCoFunCo n w arg res + go (SelFun fs) (FunCo _ _ _ w arg res) + = Just (getNthFun fs w arg res) - go n (TyConAppCo r0 tc arg_cos) = assertPpr (r == nthRole r0 tc n) - (vcat [ ppr tc - , ppr arg_cos - , ppr r0 - , ppr n - , ppr r ]) $ - arg_cos `getNth` n + 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 n (SymCo co) -- Recurse, hoping to get to a TyConAppCo or FunCo - = mkSymCo (go n co) + go cs (SymCo co) -- Recurse, hoping to get to a TyConAppCo or FunCo + = do { co' <- go cs co; return (mkSymCo co') } - go n co - = NthCo r n co + go _ _ = Nothing -- Assertion checking bad_call_msg = vcat [ text "Coercion =" <+> ppr co , text "LHS ty =" <+> ppr ty1 , text "RHS ty =" <+> ppr ty2 - , text "n =" <+> ppr n, text "r =" <+> ppr r + , text "cs =" <+> ppr cs , text "coercion role =" <+> ppr (coercionRole co) ] - good_call - -- If the Coercion passed in is between forall-types, then the Int must - -- be 0 and the role must be Nominal. + + -- good_call checks the typing rules given in Note [SelCo] + good_call SelForAll | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1 , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2 - = n == 0 && r == Nominal - - -- If the Coercion passed in is between T tys and T tys', then the Int - -- must be less than the length of tys/tys' (which must be the same - -- lengths). - -- - -- If the role of the Coercion is nominal, then the role passed in must - -- be nominal. If the role of the Coercion is representational, then the - -- role passed in must be tyConRolesRepresentational T !! n. If the role - -- of the Coercion is Phantom, then the role passed in must be Phantom. - -- - -- See also Note [NthCo Cached Roles] if you're wondering why it's - -- blaringly obvious that we should be *computing* this role instead of - -- passing it in. - | Just (tc1, tys1) <- splitTyConApp_maybe ty1 - , Just (tc2, tys2) <- splitTyConApp_maybe ty2 - , tc1 == tc2 - = let len1 = length tys1 - len2 = length tys2 - good_role = case coercionRole co of - Nominal -> r == Nominal - Representational -> r == (tyConRolesRepresentational tc1 !! n) - Phantom -> r == Phantom - in len1 == len2 && n < len1 && good_role - - | otherwise - = True - --- | Extract the nth field of a FunCo -mkNthCoFunCo :: Int -- ^ "n" - -> CoercionN -- ^ multiplicity coercion - -> Coercion -- ^ argument coercion - -> Coercion -- ^ result coercion - -> Coercion -- ^ nth coercion from a FunCo --- See Note [Function coercions] --- If FunCo _ mult arg_co res_co :: (s1:TYPE sk1 :mult-> s2:TYPE sk2) --- ~ (t1:TYPE tk1 :mult-> t2:TYPE tk2) --- Then we want to behave as if co was --- TyConAppCo mult argk_co resk_co arg_co res_co --- where --- argk_co :: sk1 ~ tk1 = mkNthCo 0 (mkKindCo arg_co) --- resk_co :: sk2 ~ tk2 = mkNthCo 0 (mkKindCo res_co) --- i.e. mkRuntimeRepCo -mkNthCoFunCo n w co1 co2 = case n of - 0 -> w - 1 -> mkRuntimeRepCo co1 - 2 -> mkRuntimeRepCo co2 - 3 -> co1 - 4 -> co2 - _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr w $$ ppr co1 $$ ppr co2) + = True --- | If you're about to call @mkNthCo r n co@, then @r@ should be --- whatever @nthCoRole n co@ returns. -nthCoRole :: Int -> Coercion -> Role -nthCoRole n co - | Just (tc, _) <- splitTyConApp_maybe lty - = nthRole r tc n + good_call (SelFun {}) + = isFunTy ty1 && isFunTy ty2 - | Just _ <- splitForAllTyCoVar_maybe lty - = Nominal + 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 - | otherwise - = pprPanic "nthCoRole" (ppr co) + good_call _ = False - where - lty = coercionLKind co - r = coercionRole co +-- | 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 @@ -1220,7 +1225,7 @@ = LRCo lr co -- | Instantiates a 'Coercion'. -mkInstCo :: Coercion -> Coercion -> Coercion +mkInstCo :: Coercion -> CoercionN -> Coercion mkInstCo (ForAllCo tcv _kind_co body_co) co | Just (arg, _) <- isReflCo_maybe co -- works for both tyvar and covar @@ -1236,7 +1241,7 @@ -- instead of @isReflCo@ | otherwise = GRefl r ty (MCo co) --- | Given @ty :: k1@, @co :: k1 ~ k2@, +-- | Given @r@, @ty :: k1@, and @co :: k1 ~N k2@, -- produces @co' :: (ty |> co) ~r ty@ mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion mkGReflLeftCo r ty co @@ -1288,10 +1293,10 @@ mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co mkSubCo (TyConAppCo Nominal tc cos) = TyConAppCo Representational tc (applyRoles tc cos) -mkSubCo (FunCo Nominal w arg res) - = FunCo Representational w - (downgradeRole Representational Nominal arg) - (downgradeRole Representational Nominal res) +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 @@ -1359,12 +1364,13 @@ 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 (tyConRolesX Representational tc) cos + = do { cos' <- zipWithM setNominalRole_maybe (tyConRoleListX Representational tc) cos ; return $ TyConAppCo Nominal tc cos' } - setNominalRole_maybe_helper (FunCo Representational w co1 co2) + 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 $ FunCo Nominal w co1' co2' + ; return $ co { fco_role = Nominal, fco_arg = co1', fco_res = co2' } } setNominalRole_maybe_helper (SymCo co) = SymCo <$> setNominalRole_maybe_helper co @@ -1374,10 +1380,10 @@ = 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 (NthCo _r n co) + setNominalRole_maybe_helper (SelCo n co) -- NB, this case recurses via setNominalRole_maybe, not -- setNominalRole_maybe_helper! - = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co + = SelCo n <$> setNominalRole_maybe (coercionRole co) co setNominalRole_maybe_helper (InstCo co arg) = InstCo <$> setNominalRole_maybe_helper co <*> pure arg setNominalRole_maybe_helper (UnivCo prov _ co1 co2) @@ -1403,28 +1409,44 @@ -- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational applyRoles :: TyCon -> [Coercion] -> [Coercion] -applyRoles tc cos - = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos +applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational --- the Role parameter is the Role of the TyConAppCo +-- 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 -> [Role] +tyConRolesX :: Role -> TyCon -> Infinite Role tyConRolesX Representational tc = tyConRolesRepresentational tc -tyConRolesX role _ = repeat role +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 -> [Role] -tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal +tyConRolesRepresentational :: TyCon -> Infinite Role +tyConRolesRepresentational tc = tyConRoles tc Inf.++ Inf.repeat Nominal -nthRole :: Role -> TyCon -> Int -> Role -nthRole Nominal _ _ = Nominal -nthRole Phantom _ _ = Phantom -nthRole Representational tc n - = (tyConRolesRepresentational tc) `getNth` n +-- 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 @@ -1443,20 +1465,18 @@ -- First cases handles anything that should yield refl. promoteCoercion co = case co of - _ | 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. - - Refl _ -> assert False $ - mkNomReflCo ki1 + Refl _ -> mkNomReflCo ki1 - GRefl _ _ MRefl -> assert False $ - 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' @@ -1474,14 +1494,19 @@ | isTyVar tv -> promoteCoercion g - ForAllCo _ _ _ + 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 - -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep - FunCo _ _ _ _ - -> 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 @@ -1499,14 +1524,9 @@ TransCo co1 co2 -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) - NthCo _ n co1 - | Just (_, args) <- splitTyConAppCo_maybe co1 - , args `lengthExceeds` n - -> promoteCoercion (args !! n) - - | Just _ <- splitForAllCo_maybe co - , n == 0 - -> assert False $ mkNomReflCo liftedTypeKind + SelCo n co1 + | Just co' <- mkSelCo_maybe n co1 + -> promoteCoercion co' | otherwise -> mkKindCo co @@ -1530,7 +1550,7 @@ -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep KindCo _ - -> assert False $ + -> assert False $ -- See the first equation above mkNomReflCo liftedTypeKind SubCo g @@ -1558,10 +1578,12 @@ -- 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 $ mkNthCo Nominal 4 g -- extract result type, which is the 5th argument to (->) + = Just $ mkSelCo (SelFun SelRes) g -- extract result type + | otherwise -- one forall, one funty... = Nothing @@ -1617,29 +1639,6 @@ where (Pair t1 t2, r) = coercionKindRole g -mkFamilyTyConAppCo :: TyCon -> [CoercionN] -> CoercionN --- ^ Given a family instance 'TyCon' and its arg 'Coercion's, return the --- corresponding family 'Coercion'. E.g: --- --- > data family T a --- > data instance T (Maybe b) = MkT b --- --- Where the instance 'TyCon' is :RTL, so: --- --- > mkFamilyTyConAppCo :RTL (co :: a ~# Int) = T (Maybe a) ~# T (Maybe Int) --- --- cf. 'mkFamilyTyConApp' -mkFamilyTyConAppCo tc cos - | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc - , let tvs = tyConTyVars tc - fam_cos = assertPpr (tvs `equalLength` cos) (ppr tc <+> ppr cos) $ - map (liftCoSubstWith Nominal tvs cos) fam_tys - = mkTyConAppCo Nominal fam_tc fam_cos - | otherwise - = mkTyConAppCo Nominal tc cos - --- See Note [Newtype coercions] in GHC.Core.TyCon - mkPiCos :: Role -> [Var] -> Coercion -> Coercion mkPiCos r vs co = foldr (mkPiCo r) co vs @@ -1649,21 +1648,22 @@ 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 argement coercion will be nominal. But here we + -- 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 scaled_ty co - | otherwise = mkFunResCo r scaled_ty co - where - scaled_ty = Scaled (varMult v) (varType v) + mkFunResCo r v co + | otherwise = mkFunResCo r v co -mkFunResCo :: Role -> Scaled Type -> Coercion -> Coercion --- Given res_co :: res1 -> res2, +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 (Scaled mult arg_ty) res_co - = mkFunCo role (multToCo mult) (mkReflCo role arg_ty) res_co +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 @@ -1746,18 +1746,13 @@ | 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] -mapStepResult :: (ev1 -> ev2) - -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 -mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev) -mapStepResult _ NS_Done = NS_Done -mapStepResult _ NS_Abort = NS_Abort - -- | 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 @@ -1823,7 +1818,7 @@ -- -- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') -- --- then (a) @co : ty ~ ty'@. +-- then (a) @co : ty ~R ty'@. -- (b) ty' is not a newtype. -- -- The function returns @Nothing@ for non-@newtypes@, @@ -1874,7 +1869,7 @@ We want to push the coercion inside the constructor application. So we do this - g' :: t1~t2 = Nth 0 g + g' :: t1~t2 = SelCo (SelTyCon 0) g case K @t2 (x |> g' -> Maybe g') of K (y:t2 -> Maybe t2) -> rhs @@ -1891,7 +1886,7 @@ Note [extendLiftingContextEx] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider we have datatype - K :: \/k. \/a::k. P -> T k -- P be some type + K :: /\k. /\a::k. P -> T k -- P be some type g :: T k1 ~ T k2 case (K @k1 @t1 x) |> g of @@ -1899,7 +1894,7 @@ We want to push the coercion inside the constructor application. We first get the coercion mapped by the universal type variable k: - lc = k |-> Nth 0 g :: k1~k2 + 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. @@ -1927,7 +1922,7 @@ -- See Note [Lifting coercions over types: liftCoSubst] -- ---------------------------------------------------- -data LiftingContext = LC TCvSubst LiftCoEnv +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. @@ -1968,14 +1963,14 @@ | otherwise = ty_co_subst lc r ty emptyLiftingContext :: InScopeSet -> LiftingContext -emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv +emptyLiftingContext in_scope = LC (mkEmptySubst in_scope) emptyVarEnv mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext mkLiftingContext pairs - = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) + = LC (mkEmptySubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) (mkVarEnv pairs) -mkSubstLiftingContext :: TCvSubst -> LiftingContext +mkSubstLiftingContext :: Subst -> LiftingContext mkSubstLiftingContext subst = LC subst emptyVarEnv -- | Extend a lifting context with a new mapping. @@ -1996,7 +1991,7 @@ -> Coercion -- ^ to this coercion -> LiftingContext extendLiftingContextAndInScope (LC subst env) tv co - = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co + = extendLiftingContext (LC (extendSubstInScopeSet subst (tyCoVarsOfCo co)) env) tv co -- | Extend a lifting context with existential-variable bindings. -- See Note [extendLiftingContextEx] @@ -2012,7 +2007,7 @@ -- works with existentially bound variables, which are considered to have -- nominal roles. | isTyVar v - = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) + = let lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfType ty) (extendVarEnv env v $ mkGReflRightCo Nominal ty @@ -2030,7 +2025,7 @@ kco = mkTyConAppCo Nominal (equalityTyCon r) [ mkKindCo lift_s1, mkKindCo lift_s2 , lift_s1 , lift_s2 ] - lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co) + lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfCo co) (extendVarEnv env v (mkProofIrrelCo Nominal kco co $ (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) @@ -2041,7 +2036,7 @@ -- | Erase the environments in a lifting context zapLiftingContext :: LiftingContext -> LiftingContext -zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv +zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv -- | Like 'substForAllCoBndr', but works on a lifting context substForAllCoBndrUsingLC :: Bool @@ -2066,14 +2061,14 @@ = 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 (tyConRolesX r tc) tys) - go r (FunTy _ w ty1 ty2) = mkFunCo r (go Nominal w) (go r ty1) (go r ty2) + 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 @@ -2192,14 +2187,14 @@ -> (LiftingContext, TyVar, r) liftCoSubstTyVarBndrUsing view_co fun lc@(LC subst cenv) old_var = assert (isTyVar old_var) $ - ( LC (subst `extendTCvInScope` new_var) new_cenv + ( 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 (getTCvInScope subst) (setVarType old_var k1) + new_var = uniqAway (getSubstInScope subst) (setVarType old_var k1) lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta -- :: new_var ~ new_var |> eta @@ -2212,14 +2207,14 @@ -> (LiftingContext, CoVar, r) liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var = assert (isCoVar old_var) $ - ( LC (subst `extendTCvInScope` new_var) new_cenv + ( 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 (getTCvInScope subst) (setVarType old_var k1) + new_var = uniqAway (getSubstInScope subst) (setVarType old_var k1) -- old_var :: s1 ~r s2 -- eta :: (s1' ~r s2') ~N (t1 ~r t2) @@ -2231,8 +2226,8 @@ role = coVarRole old_var eta' = downgradeRole role Nominal eta - eta1 = mkNthCo role 2 eta' - eta2 = mkNthCo role 3 eta' + eta1 = mkSelCo (SelTyCon 2 role) eta' + eta2 = mkSelCo (SelTyCon 3 role) eta' co1 = mkCoVarCo new_var co2 = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2 @@ -2259,27 +2254,32 @@ swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv swapLiftCoEnv = mapVarEnv mkSymCo -lcSubstLeft :: LiftingContext -> TCvSubst +lcSubstLeft :: LiftingContext -> Subst lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env -lcSubstRight :: LiftingContext -> TCvSubst +lcSubstRight :: LiftingContext -> Subst lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env -liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstLeft :: Subst -> LiftCoEnv -> Subst liftEnvSubstLeft = liftEnvSubst pFst -liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstRight :: Subst -> LiftCoEnv -> Subst liftEnvSubstRight = liftEnvSubst pSnd -liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubst :: (forall a. Pair a -> a) -> Subst -> LiftCoEnv -> Subst liftEnvSubst selector subst lc_env - = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst + = 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 @@ -2293,12 +2293,12 @@ equality_ty = selector (coercionKind co) -- | Extract the underlying substitution from the LiftingContext -lcTCvSubst :: LiftingContext -> TCvSubst -lcTCvSubst (LC subst _) = subst +lcSubst :: LiftingContext -> Subst +lcSubst (LC subst _) = subst -- | Get the 'InScopeSet' from a 'LiftingContext' lcInScopeSet :: LiftingContext -> InScopeSet -lcInScopeSet (LC subst _) = getTCvInScope subst +lcInScopeSet (LC subst _) = getSubstInScope subst {- %************************************************************************ @@ -2319,7 +2319,8 @@ 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 w co1 co2) = r `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2 +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 @@ -2327,7 +2328,7 @@ = 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 (NthCo r n co) = r `seq` n `seq` seqCo co +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 @@ -2378,25 +2379,27 @@ 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 _ w co1 co2) = mkFunctionType (go w) (go co1) (go co2) - 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 (NthCo _ d co) = go_nth d (go co) - go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos) - go (AxiomRuleCo ax cos) = pFst $ expectJust "coercionKind" $ - coaxrProves ax $ map coercionKind cos + go (Refl ty) = ty + go (GRefl _ ty _) = 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 @@ -2416,49 +2419,55 @@ go_app (InstCo co arg) args = go_app co (go arg:args) go_app co args = piResultTys (go co) args -go_nth :: Int -> Type -> Type -go_nth d ty +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 - = assert (args `lengthExceeds` d) $ - args `getNth` d + = assertPpr (args `lengthExceeds` n) (ppr n $$ ppr ty) $ + args `getNth` n - | d == 0 - , Just (tv,_) <- splitForAllTyCoVar_maybe ty +getNthFromType SelForAll ty -- Works for both tyvar and covar + | Just (tv,_) <- splitForAllTyCoVar_maybe ty = tyVarKind tv - | otherwise - = pprPanic "coercionLKind:nth" (ppr d <+> ppr ty) +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 _ w co1 co2) = mkFunctionType (go w) (go co1) (go co2) - 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 (NthCo _ d co) = go_nth 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 (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 = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co) + empty_subst = mkEmptySubst (mkInScopeSet $ tyCoVarsOfCo co) go_ax_inst ax ind tys | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs @@ -2484,19 +2493,20 @@ where k2 = coercionRKind k_co tv2 = setTyVarKind tv1 (substTy subst k2) - subst' | isGReflCo k_co = extendTCvInScope subst tv1 + subst' | isGReflCo k_co = extendSubstInScope subst tv1 -- kind_co always has kind @Type@, thus @isGReflCo@ - | otherwise = extendTvSubst (extendTCvInScope subst tv2) tv1 $ + | 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 - eta1 = mkNthCo r 2 (downgradeRole r Nominal k_co) - eta2 = mkNthCo r 3 (downgradeRole r Nominal k_co) + 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 @@ -2509,8 +2519,8 @@ cv2 = setVarType cv1 (substTy subst k2) n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) - subst' | isReflCo k_co = extendTCvInScope subst cv1 - | otherwise = extendCvSubst (extendTCvInScope subst cv2) + subst' | isReflCo k_co = extendSubstInScope subst cv1 + | otherwise = extendCvSubst (extendSubstInScope subst cv2) cv1 n_subst go_forall subst other_co @@ -2543,14 +2553,16 @@ go (TyConAppCo r _ _) = r go (AppCo co1 _) = go co1 go (ForAllCo _ _ co) = go co - go (FunCo r _ _ _) = r + 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 (NthCo r _d _co) = r + 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 @@ -2585,11 +2597,6 @@ in TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] -mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type -mkHeteroCoercionType Nominal = mkHeteroPrimEqPred -mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred -mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType" - -- | Creates a primitive type equality predicate. -- Invariant: the types are not Coercions mkPrimEqPred :: Type -> Type -> Type @@ -2649,20 +2656,21 @@ ; _ -> False }) $ mkNomReflCo ty1 - go (FunTy { ft_mult = w1, ft_arg = arg1, ft_res = res1 }) - (FunTy { ft_mult = w2, ft_arg = arg2, ft_res = res2 }) - = mkFunCo Nominal (go w1 w2) (go arg1 arg2) (go res1 res2) + 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) <- repSplitAppTy_maybe ty2 + | Just (ty2a, ty2b) <- splitAppTyNoView_maybe ty2 = mkAppCo (go ty1a ty2a) (go ty1b ty2b) go ty1 (AppTy ty2a ty2b) - | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 + | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1 = mkAppCo (go ty1a ty2a) (go ty1b ty2b) go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2) @@ -2690,10 +2698,10 @@ r = coVarRole cv1 kind_co' = downgradeRole r Nominal kind_co - eta1 = mkNthCo r 2 kind_co' - eta2 = mkNthCo r 3 kind_co' + eta1 = mkSelCo (SelTyCon 2 r) kind_co' + eta2 = mkSelCo (SelTyCon 3 r) kind_co' - subst = mkEmptyTCvSubst $ mkInScopeSet $ + subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` mkCoVarCo cv1 `mkTransCo` 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 @@ -17,14 +17,16 @@ mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkAppCo :: Coercion -> Coercion -> Coercion mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion -mkFunCo :: Role -> CoercionN -> 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 mkCoVarCo :: CoVar -> Coercion mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion mkPhantomCo :: Coercion -> Type -> Type -> Coercion mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion mkSymCo :: Coercion -> Coercion mkTransCo :: Coercion -> Coercion -> Coercion -mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion +mkSelCo :: HasDebugCallStack => CoSel -> Coercion -> Coercion mkLRCo :: LeftOrRight -> Coercion -> Coercion mkInstCo :: Coercion -> Coercion -> Coercion mkGReflCo :: Role -> Type -> MCoercionN -> Coercion 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 @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} @@ -35,6 +36,8 @@ import GHC.Prelude +import Language.Haskell.Syntax.Basic (Role(..)) + import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprTyVar ) import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) @@ -508,14 +511,6 @@ Roles are defined here to avoid circular dependencies. -} - --- See Note [Roles] in GHC.Core.Coercion --- defined here to avoid cyclic dependency with GHC.Core.Coercion --- --- Order of constructors matters: the Ord instance coincides with the *super*typing --- relation on roles. -data Role = Nominal | Representational | Phantom - deriving (Eq, Ord, Data.Data) -- These names are slurped into the parser code. Changing these strings -- will change the **surface syntax** that GHC accepts! If you want to 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 @@ -15,6 +15,7 @@ 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 @@ -23,6 +24,7 @@ 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 ) @@ -32,7 +34,6 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Trace import Control.Monad ( zipWithM ) @@ -43,6 +44,13 @@ %* * %************************************************************************ +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 @@ -119,14 +127,25 @@ { optCoercionEnabled :: Bool -- ^ Enable coercion optimisation (reduce its size) } -optCoercion :: OptCoercionOpts -> TCvSubst -> Coercion -> NormalCo +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 - | otherwise = substCo 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 +-} -optCoercion' :: TCvSubst -> Coercion -> NormalCo + | otherwise + = substCo env co + + +optCoercion' :: Subst -> Coercion -> NormalCo optCoercion' env co | debugIsOn = let out_co = opt_co1 lc False co @@ -136,19 +155,23 @@ assertPpr (substTyUnchecked env in_ty1 `eqType` out_ty1 && substTyUnchecked env in_ty2 `eqType` out_ty2 && in_role == out_role) - ( text "optCoercion changed types!" - $$ hang (text "in_co:") 2 (ppr co) - $$ hang (text "in_ty1:") 2 (ppr in_ty1) - $$ hang (text "in_ty2:") 2 (ppr in_ty2) - $$ hang (text "out_co:") 2 (ppr out_co) - $$ hang (text "out_ty1:") 2 (ppr out_ty1) - $$ hang (text "out_ty2:") 2 (ppr out_ty2) - $$ hang (text "subst:") 2 (ppr env)) - out_co + (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 @@ -191,9 +214,12 @@ -- See Note [Optimising coercion optimisation] -- | Optimize a non-phantom coercion. -opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo - +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 {" @@ -201,12 +227,13 @@ , text "Rep:" <+> ppr rep , text "Role:" <+> ppr r , text "Co:" <+> ppr co ]) $ - assert (r == coercionRole 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 $$ @@ -246,7 +273,7 @@ (True, Nominal) -> mkTyConAppCo Representational tc (zipWith3 (opt_co3 env sym) - (map Just (tyConRolesRepresentational tc)) + (map Just (tyConRoleListRepresentational tc)) (repeat Nominal) cos) (False, Nominal) -> @@ -255,7 +282,7 @@ -- must use opt_co2 here, because some roles may be P -- See Note [Optimising coercion optimisation] mkTyConAppCo r tc (zipWith (opt_co2 env sym) - (tyConRolesRepresentational tc) -- the current roles + (tyConRoleListRepresentational tc) -- the current roles cos) (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) @@ -269,18 +296,20 @@ 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 cow co1 co2) +opt_co4 env sym rep r (FunCo _r afl afr cow co1 co2) = assert (r == _r) $ - if rep - then mkFunCo Representational cow' co1' co2' - else mkFunCo r cow' co1' co2' + 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 (lcTCvSubst env) 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] @@ -333,38 +362,29 @@ co2' = opt_co4_wrap env sym rep r co2 in_scope = lcInScopeSet env -opt_co4 env _sym rep r (NthCo _r n co) - | Just (ty, _) <- isReflCo_maybe co - , Just (_tc, args) <- assert (r == _r ) - splitTyConApp_maybe ty - = liftCoSubst (chooseRole rep r) env (args `getNth` n) - - | Just (ty, _) <- isReflCo_maybe co - , n == 0 - , Just (tv, _) <- splitForAllTyCoVar_maybe ty - -- works for both tyvar and covar - = liftCoSubst (chooseRole rep r) env (varType tv) +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 (NthCo r1 n (TyConAppCo _ _ cos)) +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 (NthCo r1 n (FunCo _r2 w co1 co2)) - = assert (r == r1 ) - opt_co4_wrap env sym rep r (mkNthCoFunCo n w co1 co2) +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 r (NthCo _r n (ForAllCo _ eta _)) +opt_co4 env sym rep _ (SelCo SelForAll (ForAllCo _ eta _)) -- works for both tyvar and covar - = assert (r == _r ) - assert (n == 0 ) - opt_co4_wrap env sym rep Nominal eta + = opt_co4_wrap env sym rep Nominal eta -opt_co4 env sym rep r (NthCo _r n co) - | Just nth_co <- case co' of - TyConAppCo _ _ cos -> Just (cos `getNth` n) - FunCo _ w co1 co2 -> Just (mkNthCoFunCo n w co1 co2) - ForAllCo _ eta _ -> Just 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 @@ -372,7 +392,7 @@ else nth_co | otherwise - = wrapRole rep r $ NthCo r n co' + = wrapRole rep r $ SelCo n co' where co' = opt_co1 env sym co @@ -455,8 +475,8 @@ -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2) r2 = coVarRole cv kind_co' = downgradeRole r2 Nominal kind_co - n1 = mkNthCo r2 2 kind_co' - n2 = mkNthCo r2 3 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)) @@ -547,7 +567,7 @@ , 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 = tyConRolesX role tc1 + = 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 @@ -577,9 +597,9 @@ eta = mkUnivCo prov' Nominal k1 k2 eta_d = downgradeRole r' Nominal eta -- eta gets opt'ed soon, but not yet. - n_co = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo` + n_co = (mkSymCo $ mkSelCo (SelTyCon 2 r') eta_d) `mkTransCo` (mkCoVarCo cv1) `mkTransCo` - (mkNthCo r' 3 eta_d) + (mkSelCo (SelTyCon 3 r') eta_d) ty2' = substTyWithCoVars [cv2] [n_co] ty2 (env', cv1', eta') = optForAllCoBndr env sym cv1 eta @@ -651,13 +671,12 @@ mkGReflRightCo r1 t1 (opt_trans is co1 co2) -- Push transitivity through matching destructors -opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2) +opt_trans_rule is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2) | d1 == d2 , coercionRole co1 == coercionRole co2 , co1 `compatible_co` co2 - = assert (r1 == r2) $ - fireTransRule "PushNth" in_co1 in_co2 $ - mkNthCo r1 d1 (opt_trans is co1 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 @@ -694,10 +713,14 @@ fireTransRule "PushTyConApp" in_co1 in_co2 $ mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) -opt_trans_rule is in_co1@(FunCo r1 w1 co1a co1b) in_co2@(FunCo r2 w2 co2a co2b) - = assert (r1 == r2) $ -- Just like the TyConAppCo/TyConAppCo case +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 $ - mkFunCo r1 (opt_trans is w1 w2) (opt_trans is co1a co2a) (opt_trans is co1b co2b) + 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] @@ -772,8 +795,8 @@ is' = is `extendInScopeSet` cv1 role = coVarRole cv1 eta1' = downgradeRole role Nominal eta1 - n1 = mkNthCo role 2 eta1' - n2 = mkNthCo role 3 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 @@ -1134,9 +1157,9 @@ Here, - h1 = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4) - eta1 = mkNthCo r 2 h1 :: (s1 ~ s3) - eta2 = mkNthCo r 3 h1 :: (s2 ~ s4) + 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) @@ -1148,7 +1171,7 @@ | Pair ty1 ty2 <- coercionKind co , Just (tv1, _) <- splitForAllTyVar_maybe ty1 , isForAllTy_ty ty2 - , let kind_co = mkNthCo Nominal 0 co + , let kind_co = mkSelCo SelForAll co = Just ( tv1, kind_co , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co)) @@ -1164,13 +1187,13 @@ | Pair ty1 ty2 <- coercionKind co , Just (cv1, _) <- splitForAllCoVar_maybe ty1 , isForAllTy_co ty2 - = let kind_co = mkNthCo Nominal 0 co + = let kind_co = mkSelCo SelForAll co r = coVarRole cv1 l_co = mkCoVarCo cv1 kind_co' = downgradeRole r Nominal kind_co - r_co = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo` - l_co `mkTransCo` - (mkNthCo r 3 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)) @@ -1197,17 +1220,19 @@ etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] -- If possible, split a coercion -- g :: T s1 .. sn ~ T t1 .. tn --- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~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 (mustBeSaturated tc) + | 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 [NthCo and newtypes] in GHC.Core.TyCo.Rep + , 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 diff --git a/GHC/Core/ConLike.hs b/GHC/Core/ConLike.hs --- a/GHC/Core/ConLike.hs +++ b/GHC/Core/ConLike.hs @@ -185,10 +185,14 @@ -- -- 7) The original result type conLikeFullSig :: ConLike - -> ([TyVar], [TyCoVar], [EqSpec] + -> ([TyVar], [TyCoVar] -- Why tyvars for universal but tycovars for existential? -- See Note [Existential coercion variables] in GHC.Core.DataCon - , ThetaType, ThetaType, [Scaled Type], Type) + , [EqSpec] + , ThetaType -- Provided theta + , ThetaType -- Required theta + , [Scaled Type] -- Arguments + , Type ) -- Result conLikeFullSig (RealDataCon con) = let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con -- Required theta is empty as normal data cons require no additional diff --git a/GHC/Core/DataCon.hs b/GHC/Core/DataCon.hs --- a/GHC/Core/DataCon.hs +++ b/GHC/Core/DataCon.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary module GHC.Core.DataCon ( -- * Main data types @@ -19,7 +20,6 @@ -- ** Equality specs EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType, eqSpecPair, eqSpecPreds, - substEqSpec, filterEqSpec, -- ** Field labels FieldLabel(..), FieldLabelString, @@ -36,11 +36,11 @@ dataConDisplayType, dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, dataConUserTyVars, dataConUserTyVarBinders, - dataConEqSpec, dataConTheta, + dataConTheta, dataConStupidTheta, dataConOtherTheta, dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, - dataConInstOrigArgTys, dataConRepArgTys, + dataConInstOrigArgTys, dataConRepArgTys, dataConResRepTyArgs, dataConInstUnivs, dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, dataConSrcBangs, @@ -55,9 +55,10 @@ -- ** Predicates on DataCons isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon, - isUnboxedSumDataCon, - isVanillaDataCon, isNewDataCon, classDataCon, dataConCannotMatch, - dataConUserTyVarsArePermuted, + isUnboxedSumDataCon, isCovertGadtDataCon, + isVanillaDataCon, isNewDataCon, isTypeDataCon, + classDataCon, dataConCannotMatch, + dataConUserTyVarsNeedWrapper, checkDataConTyVars, isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked, specialPromotedDc, @@ -67,12 +68,15 @@ import GHC.Prelude +import Language.Haskell.Syntax.Basic + import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer ) import GHC.Core.Type as Type import GHC.Core.Coercion import GHC.Core.Unify import GHC.Core.TyCon import GHC.Core.TyCo.Subst +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Multiplicity import {-# SOURCE #-} GHC.Types.TyThing import GHC.Types.FieldLabel @@ -86,12 +90,11 @@ import GHC.Types.Basic import GHC.Data.FastString import GHC.Unit.Types -import GHC.Unit.Module.Name import GHC.Utils.Binary import GHC.Types.Unique.FM ( UniqFM ) import GHC.Types.Unique.Set import GHC.Builtin.Uniques( mkAlphaTyVarUnique ) - +import GHC.Data.Graph.UnVar -- UnVarSet and operations import GHC.Utils.Outputable import GHC.Utils.Misc @@ -105,9 +108,11 @@ import Data.Char import Data.List( find ) +import Language.Haskell.Syntax.Module.Name + {- -Note [Data constructor representation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Data constructor representation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following Haskell data type declaration data T = T !Int ![Int] @@ -208,7 +213,7 @@ * The wrapper (if it exists) takes dcOrigArgTys as its arguments. The worker takes dataConRepArgTys as its arguments - If the wrapper is absent, dataConRepArgTys is the same as dcOrigArgTys + If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys * The 'NoDataConRep' case of DataConRep is important. Not only is it efficient, but it also ensures that the wrapper is replaced by the @@ -228,7 +233,7 @@ data T = MkT !(Int,Int) \$wMkT :: (Int,Int) -> T \$wMkT (x,y) = MkT x y - Notice that the worker has two fields where the wapper has + Notice that the worker has two fields where the wrapper has just one. That is, the worker has type MkT :: Int -> Int -> T @@ -250,6 +255,8 @@ * Type variables may be permuted; see MkId Note [Data con wrappers and GADT syntax] +* Datatype contexts require dropping some dictionary arguments. + See Note [Instantiating stupid theta]. Note [The stupid context] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -282,7 +289,7 @@ I say the context is "stupid" because the dictionaries passed are immediately discarded -- they do nothing and have no benefit. -(See Note [Instantiating stupid theta] in GHC.Tc.Gen.Head.) +(See Note [Instantiating stupid theta].) It's a flaw in the language. GHC has made some efforts to correct this flaw. In GHC, datatype contexts @@ -326,6 +333,30 @@ result, dcStupidTheta is always empty for data types defined using GADT syntax. +Note [Instantiating stupid theta] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a data type with a "stupid theta" (see +Note [The stupid context]): + + data Ord a => T a = MkT (Maybe a) + +We want to generate an Ord constraint for every use of MkT; but +we also want to allow visible type application, such as + + MkT @Int + +To achieve this, the wrapper for a data (or newtype) constructor +with a datatype context contains a lambda which drops the dictionary +argments corresponding to the datatype context: + + /\a \(_d:Ord a). MkT @a + +Notice that the wrapper discards the dictionary argument d. +We don't need it; it was only there to generate a Wanted constraint. +(That is why it is stupid.) + +This all happens in GHC.Types.Id.Make.mkDataConRep. + ************************************************************************ * * \subsection{Data constructors} @@ -391,7 +422,7 @@ -- syntax, provided its type looks like the above. -- The declaration format is held in the TyCon (algTcGadtSyntax) - -- Universally-quantified type vars [a,b,c] + -- dcUnivTyVars: Universally-quantified type vars [a,b,c] -- INVARIANT: length matches arity of the dcRepTyCon -- INVARIANT: result type of data con worker is exactly (T a b c) -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with @@ -400,16 +431,17 @@ -- Existentially-quantified type and coercion vars [x,y] -- For an example involving coercion variables, - -- Why tycovars? See Note [Existential coercion variables] + -- Why TyCoVars? See Note [Existential coercion variables] dcExTyCoVars :: [TyCoVar], -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames -- Reason: less confusing, and easier to generate Iface syntax -- The type/coercion vars in the order the user wrote them [c,y,x,b] - -- INVARIANT: 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 + -- 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], @@ -522,7 +554,7 @@ * Each argument flag is Inferred or Specified. None are Required. (A DataCon is a term-level function; see - Note [No Required TyCoBinder in terms] in GHC.Core.TyCo.Rep.) + 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 @@ -534,44 +566,59 @@ Note [Existential coercion variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - For now (Aug 2018) we can't write coercion quantifications in source Haskell, but we can in Core. Consider having: data T :: forall k. k -> k -> Constraint where - MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co)) - => T k a b + MkT :: forall k (a::k) (b::k). + forall k' (c::k') (co::k'~k). + (b ~# (c|>co)) => T k a b dcUnivTyVars = [k,a,b] dcExTyCoVars = [k',c,co] dcUserTyVarBinders = [k,a,k',c] - dcEqSpec = [b~(c|>co)] + dcEqSpec = [b ~# (c|>co)] dcOtherTheta = [] dcOrigArgTys = [] dcRepTyCon = T - Function call 'dataConKindEqSpec' returns [k'~k] +Function call 'dataConKindEqSpec' returns [k'~k] Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~ -A `DataCon`'s source arity and core representation arity may differ: -`dcSourceArity` does not take constraints into account, but `dcRepArity` does. - -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). -For example: +dcSourceArity does not take constraints into account, +but dcRepArity does. For example: MkT :: Ord a => a -> T a dcSourceArity = 1 dcRepArity = 2 - MkU :: (b ~ '[]) => U b - dcSourceArity = 0 - dcRepArity = 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. + + - 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. + +* 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). + +Often (dcUnivTyVars ++ dcExTyCoVars) = dcUserTyVarBinders; but they may differ +for three reasons, coming next: + +--- Reason (R1): Order of quantification in GADT syntax --- + In System FC, data constructor type signatures always quantify over all of their universal type variables, followed by their existential type variables. Normally, this isn't a problem, as most datatypes naturally quantify their type @@ -614,36 +661,119 @@ performs a stable topological sort on the type variables in the user-written type signature, which would place `b` before `a`. -But as noted above, enacting this behavior is not entirely trivial, as System -FC demands the variables go in universal-then-existential order under the hood. -Our solution is thus to equip DataCon with two different sets of type -variables: +--- Reason (R2): GADT constructors quantify over different variables --- -* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential - type/coercion variables, respectively. 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 - TyCoVarBinders). +GADT constructors may quantify over different variables than the worker +would. Consider + data T a b where + MkT :: forall c d. c -> T [c] d -* dcUserTyVarBinders, for the type variables binders in the order in which they - originally arose in the user-written type signature. Their order *does* matter - for TypeApplications, so they are full TyVarBinders, complete with - visibilities. +The dcUserTyVarBinders must be [c, d] -- that's what the user quantified over. +But c is actually existential, as it is not equal to either of the two +universal variables. -This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders -consists precisely of: +Here is what we'll get: + dcUserTyVarBinders = [c, d] + dcUnivTyVars = [a, d] + dcExTyCoVars = [c] + +Note that dcUnivTyVars contains `a` from the type header (the `data T a b`) +and `d` from the signature for MkT. This is done because d is used in place +of b in the result of MkT, and so we use the name d for the universal, as that +might improve error messages. On the other hand, we need to use a fresh name +for the first universal (recalling that the result of a worker must be the +type constructor applied to a sequence of plain variables), so we use `a`, from +the header. This choice of universals is made in GHC.Tc.TyCl.mkGADTVars. + +Because c is not a universal, it is an existential. Here, we see that (even +ignoring order) dcUserTyVarBinders is not dcUnivTyVars ⋃ dcExTyCoVars, because +the latter has `a` while the former does not. To understand this better, let's +look at this type for the "true underlying" worker data con: + + MkT :: forall a d. forall c. (a ~# [c]) => c -> T a d + +We see here that the `a` universal is connected with the `c` existential via +an equality constraint. It will always be the case (see the code in mkGADTVars) +that the universals not mentioned in dcUserTyVarBinders will be used in a +GADT equality -- that is, used on the left-hand side of an element of dcEqSpec: + + dcEqSpec = [a ~# [c]] + +Putting this all together, all variables used on the left-hand side of an +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 +consists of: + * The set of tyvars in dcUnivTyVars whose type variables do not appear in dcEqSpec, unioned with: + * The set of tyvars (*not* covars) in dcExTyCoVars No covars here because because they're not user-written +When comparing for equality, we ignore differences concerning type variables +whose kinds have kind Constraint. + The word "set" is used above because the order in which the tyvars appear in dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of (tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the ordering, they in fact share the same type variables (with the same Uniques). We -sometimes refer to this as "the dcUserTyVarBinders invariant". +sometimes refer to this as "the dcUserTyVarBinders invariant". It is checked +in checkDataConTyVars. dcUserTyVarBinders, as the name suggests, is the one that users will see most of the time. It's used when computing the type signature of a @@ -730,30 +860,17 @@ -- after consulting HsSrcBang, flags, etc. data HsImplBang = HsLazy -- ^ Lazy field, or one with an unlifted type - | HsStrict -- ^ Strict but not unpacked field + | HsStrict Bool -- ^ Strict but not unpacked field + -- True <=> we could have unpacked, but opted not to + -- because of -O0. + -- See Note [Detecting useless UNPACK pragmas] | HsUnpack (Maybe Coercion) -- ^ Strict and unpacked field -- co :: arg-ty ~ product-ty HsBang deriving Data.Data --- | Source Strictness --- --- What strictness annotation the user wrote -data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' - | SrcStrict -- ^ Strict, ie '!' - | NoSrcStrict -- ^ no strictness annotation - deriving (Eq, Data.Data) --- | Source Unpackedness --- --- What unpackedness the user requested -data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified - | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified - | NoSrcUnpack -- ^ no unpack pragma - deriving (Eq, Data.Data) - - ------------------------- -- StrictnessMark is used to indicate strictness -- of the DataCon *worker* fields @@ -762,8 +879,7 @@ -- | An 'EqSpec' is a tyvar/type pair representing an equality made in -- rejigging a GADT constructor -data EqSpec = EqSpec TyVar - Type +data EqSpec = EqSpec TyVar Type -- | Make a non-dependent 'EqSpec' mkEqSpec :: TyVar -> Type -> EqSpec @@ -782,22 +898,6 @@ eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty | EqSpec tv ty <- spec ] --- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec --- is mapped in the substitution, it is mapped to a type variable, not --- a full type. -substEqSpec :: TCvSubst -> EqSpec -> EqSpec -substEqSpec subst (EqSpec tv ty) - = EqSpec tv' (substTy subst ty) - where - tv' = getTyVar "substEqSpec" (substTyVar subst tv) - --- | Filter out any 'TyVar's mentioned in an 'EqSpec'. -filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar] -filterEqSpec eq_spec - = filter not_in_eq_spec - where - not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec - instance Outputable EqSpec where ppr (EqSpec tv ty) = ppr (tv, ty) @@ -865,14 +965,49 @@ * 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 - [HsStrict, HsStrict, HsLazy] + [HsStrict _, HsStrict _, HsLazy] With -O it might be - [HsStrict, HsUnpack _, HsLazy] + [HsStrict _, HsUnpack _, HsLazy] With -funbox-small-strict-fields it might be [HsUnpack, HsUnpack _, HsLazy] With -XStrictData it might be - [HsStrict, HsUnpack _, HsStrict] + [HsStrict _, HsUnpack _, HsStrict _] +Note [Detecting useless UNPACK pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to issue a warning when there's an UNPACK pragma in the source code, +but we decided not to unpack. +However, when compiling with -O0, we never unpack, and that'd generate +spurious warnings. +Therefore, we remember in HsStrict a boolean flag, whether we _could_ +have unpacked. This flag is set in GHC.Types.Id.Make.dataConSrcToImplBang. +Then, in GHC.Tc.TyCl.checkValidDataCon (sub-function check_bang), +if the user wrote an `{-# UNPACK #-}` pragma (i.e. HsSrcBang contains SrcUnpack) +we consult HsImplBang: + + HsUnpack _ => field unpacked, no warning + Example: data T = MkT {-# UNPACK #-} !Int [with -O] + HsStrict True => field not unpacked because -O0, no warning + Example: data T = MkT {-# UNPACK #-} !Int [with -O0] + HsStrict False => field not unpacked, warning + Example: data T = MkT {-# UNPACK #-} !(Int -> Int) + HsLazy => field not unpacked, warning + This can happen in two scenarios: + + 1) UNPACK without a bang + Example: data T = MkT {-# UNPACK #-} Int + This will produce a warning about missing ! before UNPACK. + + 2) UNPACK of an unlifted datatype + Because of bug #20204, we currently do not unpack type T, + and therefore issue a warning: + type IntU :: UnliftedType + data IntU = IntU Int# + data T = Test {-# UNPACK #-} IntU + +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 @@ -895,7 +1030,7 @@ Trep :: Int# -> a -> Void# -> T a Actually, the unboxed part isn't implemented yet! -Note that this representation is still *different* from runtime +Not 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: @@ -956,7 +1091,7 @@ ppr HsLazy = text "Lazy" ppr (HsUnpack Nothing) = text "Unpacked" ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) - ppr HsStrict = text "StrictNotUnpacked" + ppr (HsStrict b) = text "StrictNotUnpacked" <> parens (ppr b) instance Outputable SrcStrictness where ppr SrcLazy = char '~' @@ -1009,7 +1144,7 @@ -- | Compare strictness annotations eqHsBang :: HsImplBang -> HsImplBang -> Bool eqHsBang HsLazy HsLazy = True -eqHsBang HsStrict HsStrict = True +eqHsBang (HsStrict _) (HsStrict _) = True eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2) @@ -1059,7 +1194,7 @@ -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper -> [KnotTied (Scaled Type)] -- ^ Original argument types -> KnotTied Type -- ^ Original result type - -> RuntimeRepInfo -- ^ See comments on 'GHC.Core.TyCon.RuntimeRepInfo' + -> PromDataConInfo -- ^ See comments on 'GHC.Core.TyCon.PromDataConInfo' -> KnotTied TyCon -- ^ Representation type constructor -> ConTag -- ^ Constructor tag -> ThetaType -- ^ The "stupid theta", context of the data @@ -1120,8 +1255,11 @@ -- If the DataCon has a wrapper, then the worker's type is never seen -- by the user. The visibilities we pick do not matter here. DCR{} -> mkInfForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ - mkVisFunTys rep_arg_tys $ + mkScaledFunctionTys rep_arg_tys $ mkTyConApp rep_tycon (mkTyVarTys univ_tvs) + -- res_arg_tys is a mixture of TypeLike and ConstraintLike, + -- so we don't know which FunTyFlag to use + -- Hence using mkScaledFunctionTys. -- See Note [Promoted data constructors] in GHC.Core.TyCon prom_tv_bndrs = [ mkNamedTyConBinder (Invisible spec) tv @@ -1131,9 +1269,9 @@ -- 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 = [ mkAnonTyConBinder InvisArg (mkTyVar n t) + prom_theta_bndrs = [ mkInvisAnonTyConBinder (mkTyVar n t) {- Invisible -} | (n,t) <- fresh_names `zip` theta ] - prom_arg_bndrs = [ mkAnonTyConBinder VisArg (mkTyVar n t) + 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_res_kind = orig_res_ty @@ -1220,30 +1358,6 @@ dataConUserTyVarBinders :: DataCon -> [InvisTVBinder] dataConUserTyVarBinders = dcUserTyVarBinders --- | Equalities derived from the result type of the data constructor, as written --- by the programmer in any GADT declaration. This includes *all* GADT-like --- equalities, including those written in by hand by the programmer. -dataConEqSpec :: DataCon -> [EqSpec] -dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) - = dataConKindEqSpec con - ++ eq_spec ++ - [ spec -- heterogeneous equality - | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta - , tc `hasKey` heqTyConKey - , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of - (Just tv1, _) -> [mkEqSpec tv1 ty2] - (_, Just tv2) -> [mkEqSpec tv2 ty1] - _ -> [] - ] ++ - [ spec -- homogeneous equality - | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta - , tc `hasKey` eqTyConKey - , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of - (Just tv1, _) -> [mkEqSpec tv1 ty2] - (_, Just tv2) -> [mkEqSpec tv2 ty1] - _ -> [] - ] - -- | Dependent (kind-level) equalities in a constructor. -- There are extracted from the existential variables. -- See Note [Existential coercion variables] @@ -1259,7 +1373,7 @@ | cv <- ex_tcvs , isCoVar cv , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv - tv = getTyVar "dataConKindEqSpec" ty1 + tv = getTyVar ty1 ] -- | The *full* constraints on the constructor type, including dependent GADT @@ -1332,10 +1446,9 @@ dataConSourceArity :: DataCon -> Arity dataConSourceArity (MkData { dcSourceArity = arity }) = arity --- | 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 --- Note [DataCon arities] +-- | Gives the number of actual fields in the /representation/ of the +-- data constructor. This may be more than appear in the source code; +-- the extra ones are the existentially quantified dictionaries dataConRepArity :: DataCon -> Arity dataConRepArity (MkData { dcRepArity = arity }) = arity @@ -1344,14 +1457,8 @@ isNullarySrcDataCon :: DataCon -> Bool isNullarySrcDataCon dc = dataConSourceArity dc == 0 --- | Return whether this `DataCon`'s worker, in its Core representation, takes --- any value arguments. --- --- In particular, remember that we include coercion arguments in the arity of --- the Core representation of the `DataCon` -- both lifted and unlifted --- coercions, despite the latter having zero-width runtime representation. --- --- See also Note [DataCon arities]. +-- | Return whether there are any argument types for this 'DataCon's runtime representation type +-- See Note [DataCon arities] isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon dc = dataConRepArity dc == 0 @@ -1483,10 +1590,11 @@ -- mentions the family tycon, not the internal one. dataConWrapperType (MkData { dcUserTyVarBinders = user_tvbs, dcOtherTheta = theta, dcOrigArgTys = arg_tys, - dcOrigResTy = res_ty }) + dcOrigResTy = res_ty, + dcStupidTheta = stupid_theta }) = mkInvisForAllTys user_tvbs $ - mkInvisFunTysMany theta $ - mkVisFunTys arg_tys $ + mkInvisFunTys (stupid_theta ++ theta) $ + mkScaledFunTys arg_tys $ res_ty dataConNonlinearType :: DataCon -> Type @@ -1497,11 +1605,11 @@ dcOrigResTy = res_ty, dcStupidTheta = stupid_theta }) = mkInvisForAllTys user_tvbs $ - mkInvisFunTysMany (stupid_theta ++ theta) $ - mkVisFunTys arg_tys' $ + mkInvisFunTys (stupid_theta ++ theta) $ + mkScaledFunTys arg_tys' $ res_ty where - arg_tys' = map (\(Scaled w t) -> Scaled (case w of One -> Many; _ -> w) t) arg_tys + arg_tys' = map (\(Scaled w t) -> Scaled (case w of OneTy -> ManyTy; _ -> w) t) arg_tys dataConDisplayType :: Bool -> DataCon -> Type dataConDisplayType show_linear_types dc @@ -1593,7 +1701,7 @@ (text "dataConInstUnivs" <+> ppr dc_args <+> ppr (dataConUnivTyVars dc)) $ - splitAt (length dc_args) $ dataConUnivTyVars dc + splitAtList dc_args $ dataConUnivTyVars dc (_, dc_args_suffix) = substTyVarBndrs prefix_subst dc_univs_suffix prefix_subst = mkTvSubst prefix_in_scope prefix_env prefix_in_scope = mkInScopeSet $ tyCoVarsOfTypes dc_args @@ -1617,7 +1725,7 @@ , dcOtherTheta = theta , dcOrigArgTys = orig_arg_tys }) = case rep of - NoDataConRep -> assert (null eq_spec) $ (map unrestricted theta) ++ orig_arg_tys + NoDataConRep -> assert (null eq_spec) $ map unrestricted theta ++ orig_arg_tys DCR { dcr_arg_tys = arg_tys } -> arg_tys -- | The string @package:module.name@ identifying a constructor, which is attached @@ -1657,6 +1765,66 @@ isNewDataCon :: DataCon -> Bool isNewDataCon dc = isNewTyCon (dataConTyCon dc) +-- | Is this data constructor in a "type data" declaration? +-- See Note [Type data declarations] in GHC.Rename.Module. +isTypeDataCon :: DataCon -> Bool +isTypeDataCon dc = isTypeDataTyCon (dataConTyCon dc) + +isCovertGadtDataCon :: DataCon -> Bool +-- See Note [isCovertGadtDataCon] +isCovertGadtDataCon (MkData { dcUnivTyVars = univ_tvs + , dcEqSpec = eq_spec + , dcRepTyCon = rep_tc }) + = not (null eq_spec) -- There are some constraints + && not (any is_visible_spec eq_spec) -- But none of them are visible + where + visible_univ_tvs :: [TyVar] -- Visible arguments in result type + visible_univ_tvs + = [ univ_tv | (univ_tv, tcb) <- univ_tvs `zip` tyConBinders rep_tc + , isVisibleTyConBinder tcb ] + + is_visible_spec :: EqSpec -> Bool + is_visible_spec (EqSpec univ_tv ty) + = univ_tv `elem` visible_univ_tvs + && not (isTyVarTy ty) -- See Note [isCovertGadtDataCon] for + -- an example where 'ty' is a tyvar + +{- Note [isCovertGadtDataCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(isCovertGadtDataCon K) returns True if K is a GADT data constructor, but +does not /look/ like it. 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 +explicit we'd see: + data T a where { MkT :: b -> T @LiftedRep b } + +The test for covert-ness is bit tricky, because we want to see if + - dcEqSpec is non-empty + - dcEqSpec does not constrain any of the /required/ (i.e. visible) + arguments of the TyCon to a non-tyvar + +In the example above, the DataCon for MkT will have + dcUnivTyVars: [(r::RuntimeRep), (a :: TYPE r)] + dcExTyVars: [(b :: Type)] + dcEqSpec: [(r, LiftedRep), (a, b)] +Here + * `r :: RuntimeRep` is constrained by dcEqSpec to LiftedRep + * `a :: TYPE r` is constrained by dcEqSpec to `b :: Type` +But the constraint on `a` is not visible to the user, so this counts +as a covert GADT data con. The declaration + MkT :: forall (b :: Type). b -> T b +looks entirely non-GADT-ish. + +Wrinkles: +* The visibility or otherwise is a property of the /TyCon/ binders +* The dcUnivTyVars may or may not be the same as the TyCon binders +* So we have to zip them together. +* For a data family the TyCon in question is the /representation/ TyCon + hence dcRepTyCon +-} + + -- | Should this DataCon be allowed in a type even without -XDataKinds? -- Currently, only Lifted & Unlifted specialPromotedDc :: DataCon -> Bool @@ -1697,17 +1865,71 @@ -- -- This is not a cheap test, so we minimize its use in GHC as much as possible. -- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in --- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once +-- "MkId", and so 'dataConUserTyVarsNeedWrapper' is only called at most once -- during a data constructor's lifetime. +dataConResRepTyArgs :: DataCon -> [Type] +-- Returns the arguments of a GADT version of the /representation/ TyCon +-- Thus data instance T [(x,y)] z where +-- MkT :: forall p q. Int -> T [(Int,p)] (Maybe q) +-- The "GADT version of the representation type" is +-- data R:T x y z where +-- MkT :: forall p q. Int -> R:T Int p (Maybe q) +-- so dataConResRepTyArgs for MkT returns [Int, p, Maybe q] +-- This is almost the same as (subst eq_spec univ_tvs); but not quite, +-- because eq_spec omits constraint-kinded equalities +dataConResRepTyArgs dc@(MkData { dcRepTyCon = rep_tc, dcOrigResTy = orig_res_ty }) + | Just (fam_tc, fam_args) <- tyConFamInst_maybe rep_tc + = -- fvs(fam_args) = tyConTyVars rep_tc + -- These tyvars are the domain of subst + -- Fvs(range(subst)) = tvars of the datacon + case tcMatchTy (mkTyConApp fam_tc fam_args) orig_res_ty of + Just subst -> map (substTyVar subst) (tyConTyVars rep_tc) + Nothing -> pprPanic "datacOnResRepTyArgs" $ + vcat [ ppr dc, ppr fam_tc <+> ppr fam_args + , ppr orig_res_ty ] + | otherwise + = tyConAppArgs orig_res_ty + +checkDataConTyVars :: DataCon -> Bool +-- Check that the worker and wrapper have the same set of type variables +-- See Note [DataCon user type variable binders] +-- Also ensures that no user tyvar is in the eq_spec (the eq_spec should +-- only relate fresh universals from (R2) of the note) +checkDataConTyVars dc@(MkData { dcUnivTyVars = univ_tvs + , dcExTyCoVars = ex_tvs + , dcEqSpec = eq_spec }) + -- use of sets here: (R1) from the Note + = mkUnVarSet depleted_worker_vars == mkUnVarSet depleted_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 + + 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. -- 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. -dataConUserTyVarsArePermuted :: DataCon -> Bool -dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs - , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec - , dcUserTyVarBinders = user_tvbs }) = - (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs +dataConUserTyVarsNeedWrapper dc@(MkData { dcUnivTyVars = univ_tvs + , dcExTyCoVars = ex_tvs + , 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 + {- %************************************************************************ 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 @@ -27,6 +27,7 @@ dataConFullSig :: DataCon -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type) isUnboxedSumDataCon :: DataCon -> Bool +isTypeDataCon :: DataCon -> Bool instance Eq DataCon instance Uniquable DataCon 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,12 @@ ruleLhsFreeIds, ruleLhsFreeIdsList, ruleRhsFreeVars, rulesRhsFreeIds, - expr_fvs, + exprFVs, -- * Orphan names - orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom, - orphNamesOfTypes, orphNamesOfCoCon, - exprsOrphNames, orphNamesOfFamInst, + orphNamesOfType, orphNamesOfTypes, + orphNamesOfCo, orphNamesOfCoCon, orphNamesOfAxiomLHS, + exprsOrphNames, -- * Core syntax tree annotation with free variables FVAnn, -- annotation, abstract @@ -70,9 +70,8 @@ import GHC.Core.TyCo.FVs import GHC.Core.TyCon import GHC.Core.Coercion.Axiom -import GHC.Core.FamInstEnv import GHC.Builtin.Types( unrestrictedFunTyConName ) -import GHC.Builtin.Types.Prim( funTyConName ) +import GHC.Builtin.Types.Prim( fUNTyCon ) import GHC.Data.Maybe( orElse ) import GHC.Utils.FV as FV @@ -349,19 +348,25 @@ -- Look through type synonyms (#4912) orphNamesOfType (TyVarTy _) = emptyNameSet orphNamesOfType (LitTy {}) = emptyNameSet +orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) + `unionNameSet` orphNamesOfType res orphNamesOfType (TyConApp tycon tys) = func `unionNameSet` orphNamesOfTyCon tycon `unionNameSet` orphNamesOfTypes tys where func = case tys of - arg:_ | tycon == funTyCon -> orph_names_of_fun_ty_con arg + arg:_ | tycon == fUNTyCon -> orph_names_of_fun_ty_con arg _ -> emptyNameSet -orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) - `unionNameSet` orphNamesOfType res -orphNamesOfType (FunTy _ w arg res) = orph_names_of_fun_ty_con w - `unionNameSet` unitNameSet funTyConName + +orphNamesOfType (FunTy af w arg res) = func + `unionNameSet` unitNameSet fun_tc `unionNameSet` orphNamesOfType w `unionNameSet` orphNamesOfType arg `unionNameSet` orphNamesOfType res + where func | isVisibleFunArg af = orph_names_of_fun_ty_con w + | otherwise = emptyNameSet + + 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 @@ -381,15 +386,19 @@ 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 _ co_mult co1 co2) = orphNamesOfCo co_mult `unionNameSet` 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 (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 (NthCo _ _ co) = orphNamesOfCo co +orphNamesOfCo (SelCo _ co) = orphNamesOfCo co orphNamesOfCo (LRCo _ co) = orphNamesOfCo co orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg orphNamesOfCo (KindCo co) = orphNamesOfCo co @@ -410,11 +419,6 @@ orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches -orphNamesOfAxiom :: CoAxiom br -> NameSet -orphNamesOfAxiom axiom - = orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom) - `extendNameSet` getName (coAxiomTyCon axiom) - orphNamesOfCoAxBranches :: Branches br -> NameSet orphNamesOfCoAxBranches = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches @@ -423,22 +427,25 @@ orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }) = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs --- | orphNamesOfAxiom collects the names of the concrete types and +-- | `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. -- -- For instance, given `type family Foo a b`: -- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H] -- --- Used in the implementation of ":info" in GHCi. -orphNamesOfFamInst :: FamInst -> NameSet -orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst) +-- Used (via orphNamesOfFamInst) in the implementation of ":info" in GHCi. +-- and when determining orphan-hood for a FamInst or module +orphNamesOfAxiomLHS :: CoAxiom br -> NameSet +orphNamesOfAxiomLHS axiom + = (orphNamesOfTypes $ concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom) + `extendNameSet` getName (coAxiomTyCon axiom) -- Detect FUN 'Many as an application of (->), so that :i (->) works as expected -- (see #8535) Issue #16475 describes a more robust solution orph_names_of_fun_ty_con :: Mult -> NameSet -orph_names_of_fun_ty_con Many = unitNameSet unrestrictedFunTyConName -orph_names_of_fun_ty_con _ = emptyNameSet +orph_names_of_fun_ty_con ManyTy = unitNameSet unrestrictedFunTyConName +orph_names_of_fun_ty_con _ = emptyNameSet {- ************************************************************************ @@ -791,3 +798,4 @@ 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 @@ -3,7 +3,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- (c) The University of Glasgow 2006 -- -- FamInstEnv: Type checked family instance declarations @@ -11,7 +10,7 @@ module GHC.Core.FamInstEnv ( FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, - pprFamInst, pprFamInsts, + pprFamInst, pprFamInsts, orphNamesOfFamInst, mkImportedFamInst, FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, @@ -42,14 +41,17 @@ import GHC.Core.Unify import GHC.Core.Type as Type import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare( eqType, eqTypes ) import GHC.Core.TyCon import GHC.Core.Coercion import GHC.Core.Coercion.Axiom import GHC.Core.Reduction import GHC.Core.RoughMap +import GHC.Core.FVs( orphNamesOfAxiomLHS ) 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 @@ -61,7 +63,11 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain + +import GHC.Types.Name.Set import GHC.Data.Bag +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf {- ************************************************************************ @@ -204,6 +210,10 @@ DataFamilyInst tycon -> tycon SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) +orphNamesOfFamInst :: FamInst -> NameSet +orphNamesOfFamInst (FamInst { fi_axiom = ax }) = orphNamesOfAxiomLHS ax + + {- ************************************************************************ * * @@ -366,7 +376,7 @@ data FamInstEnv = FamIE !Int -- The number of instances, used to choose the smaller environment - -- when checking type family consistnecy of home modules. + -- when checking type family consistency of home modules. !(RoughMap FamInst) -- See Note [FamInstEnv] -- See Note [FamInstEnv determinism] @@ -550,38 +560,42 @@ | InjectivityUnified CoAxBranch CoAxBranch -- ^ RHSs unify but LHSs don't unify under that substitution. Relevant for -- closed type families where equation after unification might be - -- overlpapped (in which case it is OK if they don't unify). Constructor + -- overlapped (in which case it is OK if they don't unify). Constructor -- stores axioms after unification. -- | Check whether two type family axioms don't violate injectivity annotation. injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch -> InjectivityCheckResult injectiveBranches injectivity - ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) - ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + ax1@(CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 }) + ax2@(CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 }) -- See Note [Verifying injectivity annotation], case 1. = let getInjArgs = filterByList injectivity - in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification + in_scope = mkInScopeSetList (tvs1 ++ tvs2) + in case tcUnifyTyWithTFs 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] - Just subst -> -- RHS unify under a substitution - let lhs1Subst = Type.substTys subst (getInjArgs lhs1) - lhs2Subst = Type.substTys subst (getInjArgs lhs2) - -- If LHSs are equal under the substitution used for RHSs then this pair - -- of equations does not violate injectivity annotation. If LHSs are not - -- equal under that substitution then this pair of equations violates - -- injectivity annotation, but for closed type families it still might - -- be the case that one LHS after substitution is unreachable. - in if eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note. - then InjectivityAccepted - else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 - , cab_rhs = Type.substTy subst rhs1 }) - ( ax2 { cab_lhs = Type.substTys subst lhs2 - , cab_rhs = Type.substTy subst rhs2 }) - -- payload of InjectivityUnified used only for check 1B2, only - -- for closed type families + Just subst -- RHS unify under a substitution + -- If LHSs are equal under the substitution used for RHSs then this pair + -- of equations does not violate injectivity annotation. If LHSs are not + -- equal under that substitution then this pair of equations violates + -- injectivity annotation, but for closed type families it still might + -- be the case that one LHS after substitution is unreachable. + | eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note. + -> InjectivityAccepted + | otherwise + -> InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 + , cab_rhs = Type.substTy subst rhs1 }) + ( ax2 { cab_lhs = Type.substTys subst lhs2 + , cab_rhs = Type.substTy subst rhs2 }) + -- Payload of InjectivityUnified used only for check 1B2, only + -- for closed type families + where + lhs1Subst = Type.substTys subst (getInjArgs lhs1) + lhs2Subst = Type.substTys subst (getInjArgs lhs2) + -- takes a CoAxiom with unknown branch incompatibilities and computes -- the compatibilities -- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom @@ -683,7 +697,7 @@ -- See Note [Tidy axioms when we build them] -- See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom - init_occ_env = initTidyOccEnv [mkTyVarOcc "_"] + init_occ_env = initTidyOccEnv [mkTyVarOccFS (fsLit "_")] init_tidy_env = mkEmptyTidyEnv init_occ_env -- See Note [Always number wildcard types in CoAxBranch] @@ -917,7 +931,7 @@ lookupFamInstEnvInjectivityConflicts :: [Bool] -- injectivity annotation for this type family instance -- INVARIANT: list contains at least one True value - -> FamInstEnvs -- all type instances seens so far + -> FamInstEnvs -- all type instances seen so far -> FamInst -- new type instance that we're checking -> [CoAxBranch] -- conflicting instance declarations lookupFamInstEnvInjectivityConflicts injList fam_inst_envs @@ -1312,7 +1326,7 @@ unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN) unwrapNewTypeStepper' rec_nts tc tys - = mapStepResult (, MRefl) $ unwrapNewTypeStepper rec_nts tc tys + = (, MRefl) <$> unwrapNewTypeStepper rec_nts tc tys -- second coercion below is the kind coercion relating the original type's kind -- to the normalised type's kind @@ -1324,16 +1338,50 @@ _ -> NS_Done --------------- +-- | Try to simplify a type-family application, by *one* step +-- If topReduceTyFamApp_maybe env r F tys = Just (HetReduction (Reduction co rhs) res_co) +-- then co :: F tys ~R# rhs +-- res_co :: typeKind(F tys) ~ typeKind(rhs) +-- Type families and data families; always Representational role +topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type] + -> Maybe HetReduction +topReduceTyFamApp_maybe envs fam_tc arg_tys + | isFamilyTyCon fam_tc -- type families and data families + , Just redn <- reduceTyFamApp_maybe envs role fam_tc ntys + = Just $ + mkHetReduction + (mkTyConAppCo role fam_tc args_cos `mkTransRedn` redn) + res_co + | otherwise + = Nothing + where + role = Representational + ArgsReductions (Reductions args_cos ntys) res_co + = initNormM envs role (tyCoVarsOfTypes arg_tys) + $ normalise_tc_args fam_tc arg_tys + +--------------- +normaliseType :: FamInstEnvs + -> Role -- desired role of coercion + -> Type -> Reduction +normaliseType env role ty + = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty + +--------------- normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> Reduction -- See comments on normaliseType for the arguments of this function normaliseTcApp env role tc tys = initNormM env role (tyCoVarsOfTypes tys) $ normalise_tc_app tc tys +------------------------------------------------------- +-- Functions that work in the NormM monad +------------------------------------------------------- + -- See Note [Normalising types] about the LiftingContext normalise_tc_app :: TyCon -> [Type] -> NormM Reduction normalise_tc_app tc tys - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys , not (isFamFreeTyCon tc) -- Expand and try again = -- A synonym with type families in the RHS -- Expand and try again @@ -1372,41 +1420,11 @@ assemble_result r redn kind_co = mkCoherenceRightMRedn r redn (mkSymMCo kind_co) ---------------- --- | Try to simplify a type-family application, by *one* step --- If topReduceTyFamApp_maybe env r F tys = Just (HetReduction (Reduction co rhs) res_co) --- then co :: F tys ~R# rhs --- res_co :: typeKind(F tys) ~ typeKind(rhs) --- Type families and data families; always Representational role -topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type] - -> Maybe HetReduction -topReduceTyFamApp_maybe envs fam_tc arg_tys - | isFamilyTyCon fam_tc -- type families and data families - , Just redn <- reduceTyFamApp_maybe envs role fam_tc ntys - = Just $ - mkHetReduction - (mkTyConAppCo role fam_tc args_cos `mkTransRedn` redn) - res_co - | otherwise - = Nothing - where - role = Representational - ArgsReductions (Reductions args_cos ntys) res_co - = initNormM envs role (tyCoVarsOfTypes arg_tys) - $ normalise_tc_args fam_tc arg_tys - normalise_tc_args :: TyCon -> [Type] -> NormM ArgsReductions normalise_tc_args tc tys = do { role <- getRole ; normalise_args (tyConKind tc) (tyConRolesX role tc) tys } ---------------- -normaliseType :: FamInstEnvs - -> Role -- desired role of coercion - -> Type -> Reduction -normaliseType env role ty - = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty - normalise_type :: Type -> NormM Reduction -- Normalise the input type, by eliminating *all* type-function redexes -- but *not* newtypes (which are visible to the programmer) @@ -1469,7 +1487,7 @@ Nothing -> do { ArgsReductions redns res_co <- normalise_args (typeKind nfun) - (repeat Nominal) + (Inf.repeat Nominal) arg_tys ; role <- getRole ; return $ @@ -1478,7 +1496,7 @@ (mkSymMCo res_co) } } normalise_args :: Kind -- of the function - -> [Role] -- roles at which to normalise args + -> Infinite Role -- roles at which to normalise args -> [Type] -- args -> NormM ArgsReductions -- returns ArgsReductions (Reductions cos xis) res_co, @@ -1488,7 +1506,7 @@ -- but the resulting application *will* be well-kinded -- cf. GHC.Tc.Solver.Rewrite.rewrite_args_slow normalise_args fun_ki roles args - = do { normed_args <- zipWithM normalise1 roles args + = do { normed_args <- zipWithM normalise1 (Inf.toList roles) args ; return $ simplifyArgsWorker ki_binders inner_ki fvs roles normed_args } where (ki_binders, inner_ki) = splitPiTys fun_ki diff --git a/GHC/Core/InstEnv.hs b/GHC/Core/InstEnv.hs --- a/GHC/Core/InstEnv.hs +++ b/GHC/Core/InstEnv.hs @@ -32,24 +32,27 @@ isOverlappable, isOverlapping, isIncoherent ) where -import GHC.Prelude +import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Tc.Utils.TcType -- InstEnv is really part of the type checker, -- and depends on TcType in many ways import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) import GHC.Core.RoughMap +import GHC.Core.Class +import GHC.Core.Unify + import GHC.Unit.Module.Env import GHC.Unit.Types -import GHC.Core.Class import GHC.Types.Var import GHC.Types.Unique.DSet import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Name.Set -import GHC.Core.Unify import GHC.Types.Basic import GHC.Types.Id 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 @@ -229,10 +232,8 @@ instanceHead :: ClsInst -> ([TyVar], Class, [Type]) -- Returns the head, using the fresh tyvars from the ClsInst -instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun }) +instanceHead (ClsInst { is_tvs = tvs, is_cls = cls, is_tys = tys }) = (tvs, cls, tys) - where - (_, _, cls, _) = tcSplitDFunTy (idType dfun) -- | Collects the names of concrete types and type constructors that make -- up the head of a class instance. For instance, given `class Foo a b`: @@ -280,16 +281,18 @@ -- See Note [When exactly is an instance decl an orphan?] orph | is_local cls_name = NotOrphan (nameOccName cls_name) - | all notOrphan mb_ns = assert (not (null mb_ns)) $ head mb_ns + | all notOrphan mb_ns = NE.head mb_ns | otherwise = IsOrphan notOrphan NotOrphan{} = True notOrphan _ = False - mb_ns :: [IsOrphan] -- One for each fundep; a locally-defined name - -- that is not in the "determined" arguments - mb_ns | null fds = [choose_one arg_names] - | otherwise = map do_one fds + mb_ns :: NonEmpty IsOrphan + -- One for each fundep; a locally-defined name + -- that is not in the "determined" arguments + mb_ns = case nonEmpty fds of + Nothing -> NE.singleton (choose_one arg_names) + Just fds -> fmap do_one fds do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names , not (tv `elem` rtvs)] @@ -319,7 +322,9 @@ {- Note [When exactly is an instance decl an orphan?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - (see GHC.Iface.Make.instanceToIfaceInst, which implements this) +(See GHC.Iface.Make.instanceToIfaceInst, which implements this.) +See Note [Orphans] in GHC.Core + Roughly speaking, an instance is an orphan if its head (after the =>) mentions nothing defined in this module. @@ -965,7 +970,7 @@ (m:_) | isIncoherent (fst m) -> NoUnifiers _ -> all_unifs - -- NOTE [Safe Haskell isSafeOverlap] + -- Note [Safe Haskell isSafeOverlap] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- We restrict code compiled in 'Safe' mode from overriding code -- compiled in any other mode. The rationale is that code compiled @@ -1059,7 +1064,7 @@ A2. M is not overlapping, A3. G is overlapping. - This means that we eliminate G from the set of matches (it is overriden by M), + This means that we eliminate G from the set of matches (it is overridden by M), but we keep it around until we are done with instance resolution because it might still be useful to eliminate other matches. @@ -1067,7 +1072,7 @@ There are two situations in which guards can eliminate a match: - B1. We want to add a new instance, but it is overriden by a guard. + B1. We want to add a new instance, but it is overridden by a guard. We can immediately discard the instance. Example for B1: @@ -1080,7 +1085,7 @@ Processing them in order: we add J1 as a match, then J2 as a guard. Now, when we come across J3, we can immediately discard it because - it is overriden by the guard J2. + it is overridden by the guard J2. B2. We have found a new guard. We must use it to discard matches we have already found. This is necessary because we must obtain @@ -1096,7 +1101,7 @@ We start by considering K1 and K2. Neither has any overlapping flag set, so we end up with two matches, {K1, K2}. - Next we look at K3: it is overriden by K1, but as K1 is not + Next we look at K3: it is overridden by K1, but as K1 is not overlapping this means K3 should function as a guard. We must then ensure we eliminate K2 from the list of matches, as K3 guards against it. diff --git a/GHC/Core/LateCC.hs b/GHC/Core/LateCC.hs --- a/GHC/Core/LateCC.hs +++ b/GHC/Core/LateCC.hs @@ -10,11 +10,10 @@ ) where import Control.Applicative -import GHC.Utils.Monad.State.Strict import Control.Monad +import qualified Data.Set as S import GHC.Prelude -import GHC.Driver.Session import GHC.Types.CostCentre import GHC.Types.CostCentre.State import GHC.Types.Name hiding (varName) @@ -25,14 +24,15 @@ import GHC.Data.FastString import GHC.Core import GHC.Core.Opt.Monad -import GHC.Types.Id import GHC.Core.Utils (mkTick) +import GHC.Types.Id +import GHC.Driver.Session -import qualified Data.Set as S 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] @@ -142,7 +142,7 @@ initLateCCState = LateCCState newCostCentreState mempty getCCFlavour :: FastString -> M CCFlavour -getCCFlavour name = LateCC <$> getCCIndex' name +getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name getCCIndex' :: FastString -> M CostCentreIndex getCCIndex' name = do diff --git a/GHC/Core/Lint.hs b/GHC/Core/Lint.hs --- a/GHC/Core/Lint.hs +++ b/GHC/Core/Lint.hs @@ -1,3441 +1,3630 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{- -(c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - - -A ``lint'' pass to check for Core correctness. -See Note [Core Lint guarantee]. --} - -module GHC.Core.Lint ( - lintCoreBindings, lintUnfolding, - lintPassResult, lintInteractiveExpr, lintExpr, - lintAnnots, lintAxioms, - - interactiveInScope, - - -- ** Debug output - endPass, endPassIO, - displayLintResults, dumpPassResult - ) where - -import GHC.Prelude - -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Env -import GHC.Driver.Config.Diagnostic - -import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree ) -import GHC.Unit.Module.ModGuts -import GHC.Runtime.Context - -import GHC.Core -import GHC.Core.FVs -import GHC.Core.Utils -import GHC.Core.Stats ( coreBindsStats ) -import GHC.Core.Opt.Monad -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.Subst -import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Ppr ( pprTyVar, pprTyVars ) -import GHC.Core.TyCon as TyCon -import GHC.Core.Coercion.Axiom -import GHC.Core.FamInstEnv( compatibleBranches ) -import GHC.Core.InstEnv ( instanceDFunId, instEnvElts ) -import GHC.Core.Coercion.Opt ( checkAxInstCo ) -import GHC.Core.Opt.Arity ( typeArity ) - -import GHC.Types.Literal -import GHC.Types.Var as Var -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Unique.Set( nonDetEltsUniqSet ) -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.Types.TypeEnv - -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.Trace -import GHC.Utils.Error -import qualified GHC.Utils.Error as Err -import GHC.Utils.Logger - -import Control.Monad -import Data.Foldable ( toList ) -import Data.List.NonEmpty ( NonEmpty(..), groupWith ) -import Data.List ( partition ) -import Data.Maybe -import GHC.Data.Pair -import qualified GHC.LanguageExtensions as LangExt - -{- -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] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As described in Note [Representation of function types], all saturated -applications of funTyCon are represented with the FunTy constructor. 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 substittion 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). - -************************************************************************ -* * - Beginning and ending passes -* * -************************************************************************ - -These functions are not CoreM monad stuff, but they probably ought to -be, and it makes a convenient place for them. They print out stuff -before and after core passes, and do Core Lint when necessary. --} - -endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () -endPass pass binds rules - = do { hsc_env <- getHscEnv - ; print_unqual <- getPrintUnqualified - ; liftIO $ endPassIO hsc_env print_unqual pass binds rules } - -endPassIO :: HscEnv -> PrintUnqualified - -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () --- Used by the IO-is CorePrep too -endPassIO hsc_env print_unqual pass binds rules - = do { dumpPassResult logger dump_core_sizes print_unqual mb_flag - (showSDoc dflags (ppr pass)) (pprPassDetails pass) binds rules - ; lintPassResult hsc_env pass binds } - where - dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags) - logger = hsc_logger hsc_env - dflags = hsc_dflags hsc_env - mb_flag = case coreDumpFlag pass of - Just flag | logHasDumpFlag logger flag -> Just flag - | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag - _ -> Nothing - -dumpPassResult :: Logger - -> Bool -- dump core sizes? - -> PrintUnqualified - -> 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 unqual mb_flag hdr extra_info binds rules - = do { forM_ mb_flag $ \flag -> do - logDumpFile logger (mkDumpStyle unqual) 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 ] - -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 CoreDoCallArity = Just Opt_D_dump_call_arity -coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify -coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal -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 CoreCSE = Just Opt_D_dump_cse -coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt -coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds -coreDumpFlag CoreTidy = Just Opt_D_dump_simpl -coreDumpFlag CorePrep = Just Opt_D_dump_prep -coreDumpFlag CoreAddLateCcs = Just Opt_D_dump_late_cc - -coreDumpFlag CoreAddCallerCcs = Nothing -coreDumpFlag CoreOccurAnal = Nothing -coreDumpFlag CoreDoPrintCore = Nothing -coreDumpFlag (CoreDoRuleCheck {}) = Nothing -coreDumpFlag CoreDoNothing = Nothing -coreDumpFlag (CoreDoPasses {}) = Nothing - -{- -************************************************************************ -* * - Top-level interfaces -* * -************************************************************************ --} - -lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO () -lintPassResult hsc_env pass binds - | not (gopt Opt_DoCoreLinting dflags) - = return () - | otherwise - = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope $ hsc_IC hsc_env) binds - ; Err.showPass logger ("Core Linted result of " ++ showPpr dflags pass) - ; displayLintResults logger (showLintWarnings pass) (ppr pass) - (pprCoreBindings binds) warns_and_errs } - where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - -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 "***" - -showLintWarnings :: CoreToDo -> Bool --- Disable Lint warnings on the first simplifier pass, because --- there may be some INLINE knots still tied, which is tiresomely noisy -showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False -showLintWarnings _ = True - -lintInteractiveExpr :: SDoc -- ^ The source of the linted expression - -> HscEnv -> CoreExpr -> IO () -lintInteractiveExpr what hsc_env expr - | not (gopt Opt_DoCoreLinting dflags) - = return () - | Just err <- lintExpr dflags (interactiveInScope $ hsc_IC hsc_env) expr - = displayLintResults logger False what (pprCoreExpr expr) (emptyBag, err) - | otherwise - = return () - where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - -interactiveInScope :: InteractiveContext -> [Var] --- In GHCi we may lint expressions, or bindings arising from 'deriving' --- clauses, that mention variables bound in the interactive context. --- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context). --- So we have to tell Lint about them, lest it reports them as out of scope. --- --- We do this by find local-named things that may appear free in interactive --- context. This function is pretty revolting and quite possibly not quite right. --- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty --- so this is a (cheap) no-op. --- --- See #8215 for an example -interactiveInScope ictxt - = tyvars ++ ids - where - -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr - (cls_insts, _fam_insts) = ic_instances ictxt - te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) - te = extendTypeEnvWithIds te1 (map instanceDFunId $ instEnvElts cls_insts) - ids = typeEnvIds te - tyvars = tyCoVarsOfTypesList $ map idType ids - -- Why the type variables? How can the top level envt have free tyvars? - -- I think it's because of the GHCi debugger, which can bind variables - -- f :: [t] -> [t] - -- where t is a RuntimeUnk (see TcType) - --- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. -lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs --- Returns (warnings, errors) --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] -lintCoreBindings dflags pass local_in_scope binds - = initL dflags flags local_in_scope $ - 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 - - flags = (defaultLintFlags dflags) - { lf_check_global_ids = check_globals - , lf_check_inline_loop_breakers = check_lbs - , lf_check_static_ptrs = check_static_ptrs - , lf_check_linearity = check_linearity - , lf_check_fixed_rep = check_fixed_rep } - - -- In the output of the desugarer, before optimisation, - -- 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. - check_fixed_rep = case pass of - CoreDesugar -> False - _ -> True - - -- See Note [Checking for global Ids] - check_globals = case pass of - CoreTidy -> False - CorePrep -> False - _ -> True - - -- See Note [Checking for INLINE loop breakers] - check_lbs = case pass of - CoreDesugar -> False - CoreDesugarOpt -> False - _ -> True - - -- See Note [Checking StaticPtrs] - check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere - | otherwise = case pass of - CoreDoFloatOutwards _ -> AllowAtTopLevel - CoreTidy -> RejectEverywhere - CorePrep -> AllowAtTopLevel - _ -> AllowAnywhere - - -- See Note [Linting linearity] - check_linearity = gopt Opt_DoLinearCoreLinting dflags || ( - case pass of - CoreDesugar -> True - _ -> False) - - (_, 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 - -> DynFlags - -> SrcLoc - -> VarSet -- ^ Treat these as in scope - -> CoreExpr - -> Maybe (Bag SDoc) -- Nothing => OK - -lintUnfolding is_compulsory dflags locn var_set expr - | isEmptyBag errs = Nothing - | otherwise = Just errs - where - vars = nonDetEltsUniqSet var_set - (_warns, errs) = initL dflags (defaultLintFlags dflags) vars $ - if is_compulsory - -- See Note [Checking for representation polymorphism] - then noFixedRuntimeRepChecks linter - else linter - linter = addLoc (ImportedUnfolding locn) $ - lintCoreExpr expr - -lintExpr :: DynFlags - -> [Var] -- Treat these as in scope - -> CoreExpr - -> Maybe (Bag SDoc) -- Nothing => OK - -lintExpr dflags vars expr - | isEmptyBag errs = Nothing - | otherwise = Just errs - where - (_warns, errs) = initL dflags (defaultLintFlags dflags) vars 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/app invariant - -- See Note [Core let/app 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 [exprArity invariant] - -- and Note [Trimming arity] - ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder) - (text "idArity" <+> ppr (idArity binder) <+> - text "exceeds typeArity" <+> - ppr (length (typeArity (idType binder))) <> colon <+> - ppr binder) - - ; 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. - -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 - 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 Many (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 - (fun, args, _source_ticks) = collectArgsTicks tickishFloatable 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. - -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 - | 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 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 [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. --} - - -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))) - - ; checkL (mightBeLiftedType arg_ty || exprOkForSpeculation arg) - (mkLetAppMsg arg) } - - ; 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 <- getTCvSubst - ; 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 _) = Many - ; 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 - --- lintCoBndr :: CoVar -> (LintedTyCoVar -> LintM a) -> LintM a --- lintCoBndr = lintTyCoBndr -- We could specialise it, I guess - -lintTyCoBndr :: TyCoVar -> (LintedTyCoVar -> LintM a) -> LintM a -lintTyCoBndr tcv thing_inside - = do { subst <- getTCvSubst - ; kind' <- lintType (varType tcv) - ; let tcv' = uniqAway (getTCvInScope subst) $ - setVarType tcv kind' - subst' = extendTCvSubstWithClone subst tcv tcv' - ; when (isCoVar tcv) $ - lintL (isCoVarType kind') - (text "CoVar with non-coercion type:" <+> pprTyVar tcv) - ; updateTCvSubst 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 (classifiesTypeWithValues 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 <- getTCvSubst - ; 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 } - - | isFunTyCon tc - , tys `lengthIs` 5 - -- We should never see a saturated application of funTyCon; such - -- applications should be represented with the FunTy constructor. - -- See Note [Linting function types] and - -- Note [Representation of function types]. - = failWithL (hang (text "Saturated application of (->)") 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' - ; 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 - | Just (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 (classifiesTypeWithValues 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 (classifiesTypeWithValues k1) (addErrL (msg (text "argument") k1)) - ; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result") k2)) - ; unless (isMultiplicityTy kw) (addErrL (msg (text "multiplicity") kw)) } - where - k1 = typeKind t1 - k2 = typeKind t2 - kw = typeKind tw - msg ar k - = 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 ty k tys - = lint_app (text "type" <+> quotes (ppr ty)) k tys - ----------------- -lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM () -lint_co_app ty k tys - = lint_app (text "coercion" <+> quotes (ppr 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 :: SDoc -> 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] -lint_app doc 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 - ; _ <- foldlM (go_app in_scope) kfn arg_tys - ; return () } - where - fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc - , nest 2 (text "Function kind =" <+> ppr kfn) - , nest 2 (text "Arg types =" <+> ppr arg_tys) - , extra ] - - go_app in_scope kfn ta - | Just kfn' <- coreView kfn - = go_app in_scope kfn' ta - - go_app _ fun_kind@(FunTy _ _ kfa kfb) ta - = do { let ka = typeKind ta - ; unless (ka `eqType` kfa) $ - addErrL (fail_msg (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka))) - ; return kfb } - - go_app in_scope (ForAllTy (Bndr kv _vis) kfn) ta - = do { let kv_kind = varType kv - ka = typeKind ta - ; unless (ka `eqType` kv_kind) $ - addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ - ppr ta <+> dcolon <+> ppr ka))) - ; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn } - - go_app _ kfn ta - = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ta))) - -{- ********************************************************************* -* * - 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 -* NthCo (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 <- getTCvSubst - ; case lookupCoVar subst cv of - Just linted_co -> return linted_co ; - Nothing - | cv `isInScope` subst - -> return (CoVarCo cv) - | otherwise - -> - -- lintCoBndr always extends the substitition - 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) - | tc `hasKey` funTyConKey - , [_w, _rep1,_rep2,_co1,_co2] <- cos - = failWithL (text "Saturated TyConAppCo (->):" <+> 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) (tyConRolesX 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 r cow co1 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 - ; lintArrow (text "coercion" <+> quotes (ppr co)) lt1 lt2 ltw - ; lintArrow (text "coercion" <+> quotes (ppr co)) rt1 rt2 rtw - ; lintRole co1 r (coercionRole co1) - ; lintRole co2 r (coercionRole co2) - ; ensureEqTys (typeKind ltw) multiplicityTy (text "coercion" <> quotes (ppr co)) - ; ensureEqTys (typeKind rtw) multiplicityTy (text "coercion" <> quotes (ppr co)) - ; let expected_mult_role = case r of - Phantom -> Phantom - _ -> Nominal - ; lintRole cow expected_mult_role (coercionRole cow) - ; return (FunCo r cow' co1' 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 && classifiesTypeWithValues k1 - && classifiesTypeWithValues 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 <- targetPlatform <$> getDynFlags - ; 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@(NthCo r0 n co) - = do { co' <- lintCoercion co - ; let (Pair s t, r) = coercionKindRole co' - ; case (splitForAllTyCoVar_maybe s, splitForAllTyCoVar_maybe t) of - { (Just _, Just _) - -- works for both tyvar and covar - | n == 0 - , (isForAllTy_ty s && isForAllTy_ty t) - || (isForAllTy_co s && isForAllTy_co t) - -> do { lintRole the_co Nominal r0 - ; return (NthCo r0 n co') } - - ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of - { (Just (tc_s, tys_s), Just (tc_t, tys_t)) - | tc_s == tc_t - , isInjectiveTyCon tc_s r - -- see Note [NthCo and newtypes] in GHC.Core.TyCo.Rep - , tys_s `equalLength` tys_t - , tys_s `lengthExceeds` n - -> do { lintRole the_co tr r0 - ; return (NthCo r0 n co') } - where - tr = nthRole r tc_s n - - ; _ -> failWithL (hang (text "Bad getNth:") - 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 <- getTCvSubst - ; let empty_subst = zapTCvSubst 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 - -> DynFlags - -> SDoc -- ^ The source of the linted axioms - -> [CoAxiom Branched] - -> IO () -lintAxioms logger dflags what axioms = - displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $ - initL dflags (defaultLintFlags dflags) [] $ - 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 (lhs_kind `eqType` rhs_kind) $ - hang (text "Inhomogeneous axiom") - 2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$ - text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) } - --- 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 :: TCvSubst -- 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 TCvSubst 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_dynflags :: DynFlags -- DynamicFlags - , le_ue_aliases :: NameEnv UsageEnv -- Assigns usage environments to the - -- alias-like binders, as found in - -- non-recursive lets. - } - -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 - -defaultLintFlags :: DynFlags -> LintFlags -defaultLintFlags dflags = LF { lf_check_global_ids = False - , lf_check_inline_loop_breakers = True - , lf_check_static_ptrs = AllowAnywhere - , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags - , lf_report_unsat_syns = True - , lf_check_fixed_rep = True - } - -newtype LintM a = - LintM { unLintM :: - LintEnv -> - WarnsAndErrs -> -- Warning and error messages so far - (Maybe a, WarnsAndErrs) } -- Result and messages (if any) - deriving (Functor) - -type WarnsAndErrs = (Bag SDoc, Bag SDoc) - -{- 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] -~~~~~~~~~~~~~~~~~~~~~~~~ -There is one known optimisations that have not yet been updated -to work with Linear Lint: - -* 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. - Plan: make let-bound variables remember the usage environment. - See ticket #18694. - -We plan to fix this issue in the very near future. -For now, -dcore-lint enables only linting output of the desugarer, -and full Linear Lint has to be enabled separately with -dlinear-core-lint. -Ticket #19165 concerns enabling Linear Lint with -dcore-lint. - -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 -> (Just x, errs) - (<*>) = ap - -instance Monad LintM where - m >>= k = LintM (\ env errs -> - let (res, errs') = unLintM m env errs in - case res of - Just r -> unLintM (k r) env errs' - Nothing -> (Nothing, errs')) - -instance MonadFail LintM where - fail err = failWithL (text err) - -instance HasDynFlags LintM where - getDynFlags = LintM (\ e errs -> (Just (le_dynflags 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 - -initL :: DynFlags - -> LintFlags - -> [Var] -- ^ 'Id's that should be treated as being in scope - -> LintM a -- ^ Action to run - -> WarnsAndErrs -initL dflags flags vars m - = case unLintM m env (emptyBag, emptyBag) of - (Just _, errs) -> errs - (Nothing, 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 vars - env = LE { le_flags = flags - , le_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tcvs)) - , le_ids = mkVarEnv [(id, (id,idType id)) | id <- ids] - , le_joins = emptyVarSet - , le_loc = [] - , le_dynflags = dflags - , le_ue_aliases = emptyNameEnv } - -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 -> (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) -> - (Nothing, (warns, addMsg True env errs msg)) - -addErrL :: SDoc -> LintM () -addErrL msg = LintM $ \ env (warns,errs) -> - (Just (), (warns, addMsg True env errs msg)) - -addWarnL :: SDoc -> LintM () -addWarnL msg = LintM $ \ env (warns,errs) -> - (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 = initDiagOpts (le_dynflags env) - mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag) 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 -> (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 -> (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 - -updateTCvSubst :: TCvSubst -> LintM a -> LintM a -updateTCvSubst 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 -> (Just (le_joins env), errs)) - -getTCvSubst :: LintM TCvSubst -getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs)) - -getUEAliases :: LintM (NameEnv UsageEnv) -getUEAliases = LintM (\ env errs -> (Just (le_ue_aliases env), errs)) - -getInScope :: LintM InScopeSet -getInScope = LintM (\ env errs -> (Just (getTCvInScope $ 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 One - 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 Many described_mult err_msg -ensureSubUsage (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg - -ensureSubMult :: Mult -> Mult -> SDoc -> LintM () -ensureSubMult actual_usage described_usage err_msg = do - flags <- getLintFlags - when (lf_check_linearity flags) $ case actual_usage' `submult` described_usage' of - Submult -> return () - Unknown -> case isMultMul actual_usage' of - Just (m1, m2) -> ensureSubMult m1 described_usage' err_msg >> - ensureSubMult m2 described_usage' err_msg - Nothing -> when (not (actual_usage' `eqType` described_usage')) (addErrL err_msg) - - where actual_usage' = normalize actual_usage - described_usage' = normalize described_usage - - normalize :: Mult -> Mult - normalize m = case isMultMul m of - Just (m1, m2) -> mkMultMul (normalize m1) (normalize m2) - Nothing -> m - -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@(_:_)) - = ( getSrcLoc (head bs), 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 -> TCvSubst -> 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]] - -mkLetAppMsg :: CoreExpr -> SDoc -mkLetAppMsg e - = hang (text "This argument does not satisfy the let/app invariant:") - 2 (ppr e) - -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" - -dupVars :: [NonEmpty Var] -> SDoc -dupVars vars - = hang (text "Duplicate variables brought into scope") - 2 (ppr (map toList vars)) - -dupExtVars :: [NonEmpty Name] -> SDoc -dupExtVars vars - = hang (text "Duplicate top-level variables with the same qualified name") - 2 (ppr (map toList vars)) - -{- -************************************************************************ -* * -\subsection{Annotation Linting} -* * -************************************************************************ --} - --- | This checks whether a pass correctly looks through debug --- annotations (@SourceNote@). This works a bit different from other --- consistency checks: We check this by running the given task twice, --- noting all differences between the results. -lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -lintAnnots pname pass guts = {-# SCC "lintAnnots" #-} do - -- Run the pass as we normally would - dflags <- getDynFlags - logger <- getLogger - when (gopt Opt_DoAnnotationLinting dflags) $ - liftIO $ Err.showPass logger "Annotation linting - first run" - nguts <- pass guts - -- If appropriate re-run it without debug annotations to make sure - -- that they made no difference. - when (gopt Opt_DoAnnotationLinting dflags) $ do - liftIO $ Err.showPass logger "Annotation linting - second run" - nguts' <- withoutAnnots pass guts - -- Finally compare the resulting bindings - liftIO $ Err.showPass logger "Annotation linting - comparison" - let binds = flattenBinds $ mg_binds nguts - binds' = flattenBinds $ mg_binds nguts' - (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' - when (not (null diffs)) $ GHC.Core.Opt.Monad.putMsg $ vcat - [ lint_banner "warning" pname - , text "Core changes with annotations:" - , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs - ] - -- Return actual new guts - return nguts - --- | Run the given pass without annotations. This means that we both --- set the debugLevel setting to 0 in the environment as well as all --- annotations from incoming modules. -withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -withoutAnnots pass guts = do - -- Remove debug flag from environment. - dflags <- getDynFlags - let removeFlag env = hscSetFlags (dflags { debugLevel = 0}) env - withoutFlag corem = - -- TODO: supply tag here as well ? - liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*> - getUniqMask <*> getModule <*> - getVisibleOrphanMods <*> - getPrintUnqualified <*> getSrcSpanM <*> - pure corem - -- Nuke existing ticks in module. - -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes - -- them in absence of debugLevel > 0. - let nukeTicks = stripTicksE (not . tickishIsCode) - nukeAnnotsBind :: CoreBind -> CoreBind - nukeAnnotsBind bind = case bind of - Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs - NonRec b e -> NonRec b $ nukeTicks e - nukeAnnotsMod mg@ModGuts{mg_binds=binds} - = mg{mg_binds = map nukeAnnotsBind binds} - -- Perform pass with all changes applied - fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts) +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UnboxedTuples #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +A ``lint'' pass to check for Core correctness. +See Note [Core Lint guarantee]. +-} + +module GHC.Core.Lint ( + LintPassResultConfig (..), + LintFlags (..), + StaticPtrCheck (..), + LintConfig (..), + WarnsAndErrs, + + lintCoreBindings', lintUnfolding, + lintPassResult, lintExpr, + lintAnnots, lintAxioms, + + -- ** Debug output + EndPassConfig (..), + endPassIO, + displayLintResults, dumpPassResult + ) where + +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" + +dupVars :: [NonEmpty Var] -> SDoc +dupVars vars + = hang (text "Duplicate variables brought into scope") + 2 (ppr (map toList vars)) + +dupExtVars :: [NonEmpty Name] -> SDoc +dupExtVars vars + = hang (text "Duplicate top-level variables with the same qualified name") + 2 (ppr (map toList vars)) + +{- +************************************************************************ +* * +\subsection{Annotation Linting} +* * +************************************************************************ +-} + +-- | This checks whether a pass correctly looks through debug +-- annotations (@SourceNote@). This works a bit different from other +-- consistency checks: We check this by running the given task twice, +-- noting all differences between the results. +lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts +lintAnnots pname pass guts = {-# SCC "lintAnnots" #-} do + -- Run the pass as we normally would + dflags <- getDynFlags + logger <- getLogger + when (gopt Opt_DoAnnotationLinting dflags) $ + liftIO $ Err.showPass logger "Annotation linting - first run" + -- If appropriate re-run it without debug annotations to make sure + -- that they made no difference. + if gopt Opt_DoAnnotationLinting dflags + then do + nguts <- pass guts + liftIO $ Err.showPass logger "Annotation linting - second run" + nguts' <- withoutAnnots pass guts + -- Finally compare the resulting bindings + liftIO $ Err.showPass logger "Annotation linting - comparison" + let binds = flattenBinds $ mg_binds nguts + binds' = flattenBinds $ mg_binds nguts' + (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' + when (not (null diffs)) $ GHC.Core.Opt.Monad.putMsg $ vcat + [ lint_banner "warning" pname + , text "Core changes with annotations:" + , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs + ] + return nguts + else + pass guts + +-- | Run the given pass without annotations. This means that we both +-- set the debugLevel setting to 0 in the environment as well as all +-- annotations from incoming modules. +withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts +withoutAnnots pass guts = do + -- Remove debug flag from environment. + -- TODO: supply tag here as well ? + let withoutFlag = mapDynFlagsCoreM $ \(!dflags) -> dflags { debugLevel = 0 } + -- Nuke existing ticks in module. + -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes + -- them in absence of debugLevel > 0. + let nukeTicks = stripTicksE (not . tickishIsCode) + nukeAnnotsBind :: CoreBind -> CoreBind + nukeAnnotsBind bind = case bind of + Rec bs -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs + NonRec b e -> NonRec b $ nukeTicks e + nukeAnnotsMod mg@ModGuts{mg_binds=binds} + = mg{mg_binds = map nukeAnnotsBind binds} + -- Perform pass with all changes applied. Drop the simple count so it doesn't + -- effect the total also + dropSimplCount $ withoutFlag $ pass (nukeAnnotsMod guts) diff --git a/GHC/Core/Lint/Interactive.hs b/GHC/Core/Lint/Interactive.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Lint/Interactive.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +A ``lint'' pass to check for Core correctness. +See Note [Core Lint guarantee]. +-} + +module GHC.Core.Lint.Interactive ( + interactiveInScope, + ) where + +import GHC.Prelude + +import GHC.Runtime.Context + +import GHC.Core.Coercion +import GHC.Core.TyCo.FVs +import GHC.Core.InstEnv ( instanceDFunId, instEnvElts ) + +import GHC.Types.Id +import GHC.Types.TypeEnv + + +interactiveInScope :: InteractiveContext -> [Var] +-- In GHCi we may lint expressions, or bindings arising from 'deriving' +-- clauses, that mention variables bound in the interactive context. +-- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context). +-- So we have to tell Lint about them, lest it reports them as out of scope. +-- +-- We do this by find local-named things that may appear free in interactive +-- context. This function is pretty revolting and quite possibly not quite right. +-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty +-- so this is a (cheap) no-op. +-- +-- See #8215 for an example +interactiveInScope ictxt + = tyvars ++ ids + where + -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr + (cls_insts, _fam_insts) = ic_instances ictxt + te1 = mkTypeEnvWithImplicits (ic_tythings ictxt) + te = extendTypeEnvWithIds te1 (map instanceDFunId $ instEnvElts cls_insts) + ids = typeEnvIds te + tyvars = tyCoVarsOfTypesList $ map idType ids + -- Why the type variables? How can the top level envt have free tyvars? + -- I think it's because of the GHCi debugger, which can bind variables + -- f :: [t] -> [t] + -- where t is a RuntimeUnk (see TcType) diff --git a/GHC/Core/Make.hs b/GHC/Core/Make.hs --- a/GHC/Core/Make.hs +++ b/GHC/Core/Make.hs @@ -1,5 +1,3 @@ - - {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | Handy functions for creating much Core syntax @@ -25,35 +23,30 @@ FloatBind(..), wrapFloat, wrapFloats, floatBindings, -- * Constructing small tuples - mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, mkCoreUbxSum, + mkCoreVarTupTy, mkCoreTup, mkCoreUnboxedTuple, mkCoreUnboxedSum, mkCoreTupBoxity, unitExpr, -- * Constructing big tuples - mkBigCoreVarTup, mkBigCoreVarTup1, + mkChunkified, chunkify, + mkBigCoreVarTup, mkBigCoreVarTupSolo, mkBigCoreVarTupTy, mkBigCoreTupTy, mkBigCoreTup, - -- * Deconstructing small tuples - mkSmallTupleSelector, mkSmallTupleCase, - - -- * Deconstructing big tuples - mkTupleSelector, mkTupleSelector1, mkTupleCase, + -- * Deconstructing big tuples + mkBigTupleSelector, mkBigTupleSelectorSolo, mkBigTupleCase, -- * Constructing list expressions mkNilExpr, mkConsExpr, mkListExpr, mkFoldrExpr, mkBuildExpr, - -- * Constructing non empty lists - mkNonEmptyListExpr, - -- * Constructing Maybe expressions mkNothingExpr, mkJustExpr, -- * Error Ids mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, - rEC_CON_ERROR_ID, rUNTIME_ERROR_ID, + rEC_CON_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, - pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, + pAT_ERROR_ID, rEC_SEL_ERROR_ID, tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID ) where @@ -61,24 +54,24 @@ import GHC.Platform import GHC.Types.Id -import GHC.Types.Var ( EvVar, setTyVarUnique ) +import GHC.Types.Var ( EvVar, setTyVarUnique, visArgConstraintLike ) import GHC.Types.TyThing import GHC.Types.Id.Info import GHC.Types.Cpr +import GHC.Types.Basic( TypeOrConstraint(..) ) import GHC.Types.Demand import GHC.Types.Name hiding ( varName ) import GHC.Types.Literal import GHC.Types.Unique.Supply import GHC.Core -import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec ) +import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec ) import GHC.Core.Type +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Coercion ( isCoVar ) import GHC.Core.DataCon ( DataCon, dataConWorkId ) import GHC.Core.Multiplicity -import GHC.Hs.Utils ( mkChunkified, chunkify ) - import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Builtin.Types.Prim @@ -88,6 +81,7 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import GHC.Settings.Constants( mAX_TUPLE_SIZE ) import GHC.Data.FastString import Data.List ( partition ) @@ -105,7 +99,7 @@ -- | Sort the variables, putting type and covars first, in scoped order, -- and then other Ids -- --- It is a deterministic sort, meaining it doesn't look at the values of +-- It is a deterministic sort, meaning it doesn't look at the values of -- Uniques. For explanation why it's important See Note [Unique Determinism] -- in GHC.Types.Unique. sortQuantVars :: [Var] -> [Var] @@ -115,9 +109,9 @@ sorted_tcvs = scopedSort tcvs -- | Bind a binding group over an expression, using a @let@ or @case@ as --- appropriate (see "GHC.Core#let_app_invariant") +-- appropriate (see "GHC.Core#let_can_float_invariant") mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr -mkCoreLet (NonRec bndr rhs) body -- See Note [Core let/app invariant] +mkCoreLet (NonRec bndr rhs) body -- See Note [Core let-can-float invariant] = bindNonRec bndr rhs body mkCoreLet bind body = Let bind body @@ -141,9 +135,6 @@ -- | Construct an expression which represents the application of a number of -- expressions to another. The leftmost expression in the list is applied first --- --- Respects the let/app invariant by building a case expression where necessary --- See Note [Core let/app invariant] in "GHC.Core" mkCoreApps :: CoreExpr -- ^ function -> [CoreExpr] -- ^ arguments -> CoreExpr @@ -156,9 +147,6 @@ -- | Construct an expression which represents the application of one expression -- to the other --- --- Respects the let/app invariant by building a case expression where necessary --- See Note [Core let/app invariant] in "GHC.Core" mkCoreApp :: SDoc -> CoreExpr -- ^ function -> CoreExpr -- ^ argument @@ -170,9 +158,6 @@ -- paired with its type to an argument. The result is paired with its type. This -- function is not exported and used in the definition of 'mkCoreApp' and -- 'mkCoreApps'. --- --- Respects the let/app invariant by building a case expression where necessary --- See Note [Core let/app invariant] in "GHC.Core" mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type) mkCoreAppTyped _ (fun, fun_ty) (Type ty) = (App fun (Type ty), piResultTy fun_ty ty) @@ -180,20 +165,7 @@ = (App fun (Coercion co), funResultTy fun_ty) mkCoreAppTyped d (fun, fun_ty) arg = assertPpr (isFunTy fun_ty) (ppr fun $$ ppr arg $$ d) - (mkValApp fun arg (Scaled mult arg_ty) res_ty, res_ty) - where - (mult, arg_ty, res_ty) = splitFunTy fun_ty - --- | Build an application (e1 e2), --- or a strict binding (case e2 of x -> e1 x) --- using the latter when necessary to respect the let/app invariant --- See Note [Core let/app invariant] in GHC.Core -mkValApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr -mkValApp fun arg (Scaled w arg_ty) res_ty - | not (needsCaseBinding arg_ty arg) - = App fun arg -- The vastly common case - | otherwise - = mkStrictApp fun arg (Scaled w arg_ty) res_ty + (App fun arg, funResultTy fun_ty) {- ********************************************************************* * * @@ -202,7 +174,7 @@ ********************************************************************* -} mkWildEvBinder :: PredType -> EvVar -mkWildEvBinder pred = mkWildValBinder Many pred +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 @@ -225,25 +197,6 @@ mkWildCase scrut (Scaled w scrut_ty) res_ty alts = Case scrut (mkWildValBinder w scrut_ty) res_ty alts --- | Build a strict application (case e2 of x -> e1 x) -mkStrictApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr -mkStrictApp fun arg (Scaled w arg_ty) res_ty - = Case arg arg_id res_ty [Alt DEFAULT [] (App fun (Var arg_id))] - -- mkDefaultCase looks attractive here, and would be sound. - -- But it uses (exprType alt_rhs) to compute the result type, - -- whereas here we already know that the result type is res_ty - where - arg_id = mkWildValBinder w arg_ty - -- Lots of shadowing, but it doesn't matter, - -- because 'fun' and 'res_ty' should not have a free wild-id - -- - -- This is Dangerous. But this is the only place we play this - -- game, mkStrictApp returns an expression that does not have - -- a free wild-id. So the only way 'fun' could get a free wild-id - -- would be if you take apart this case expression (or some other - -- expression that uses mkWildValBinder, of which there are not - -- many), and pass a fragment of it as the fun part of a 'mkStrictApp'. - mkIfThenElse :: CoreExpr -- ^ guard -> CoreExpr -- ^ then -> CoreExpr -- ^ else @@ -260,7 +213,7 @@ -- See Note [Empty case alternatives] in GHC.Core castBottomExpr e res_ty | e_ty `eqType` res_ty = e - | otherwise = Case e (mkWildValBinder One e_ty) res_ty [] + | otherwise = Case e (mkWildValBinder OneTy e_ty) res_ty [] where e_ty = exprType e @@ -277,9 +230,9 @@ | isCoVarType ty = Nothing -- Satisfy INVARIANT 2 | otherwise - = Just (Lit (LitRubbish rep) `mkTyApps` [ty]) + = Just (Lit (LitRubbish torc rep) `mkTyApps` [ty]) where - rep = getRuntimeRep ty + Just (torc, rep) = sORTKind_maybe (typeKind ty) {- ************************************************************************ @@ -302,7 +255,7 @@ mkIntExprInt :: Platform -> Int -> CoreExpr -- Result = I# i :: Int mkIntExprInt platform i = mkCoreConApps intDataCon [mkIntLit platform (fromIntegral i)] --- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value +-- | Create a 'CoreExpr' which will evaluate to a @Word@ with the given value mkWordExpr :: Platform -> Integer -> CoreExpr mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w] @@ -374,22 +327,12 @@ {- ************************************************************************ * * -\subsection{Tuple constructors} + Creating tuples and their types for Core expressions * * ************************************************************************ -} -{- -Creating tuples and their types for Core expressions - -@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@. - -* If it has only one element, it is the identity function. - -* If there are more elements than a big tuple can have, it nests - the tuples. - -Note [Flattening one-tuples] +{- Note [Flattening one-tuples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This family of functions creates a tuple of variables/expressions/types. mkCoreTup [e1,e2,e3] = (e1,e2,e3) @@ -400,8 +343,8 @@ mkCoreTup [e1] = e1 * Build a one-tuple (see Note [One-tuples] in GHC.Builtin.Types) - mkCoreTup1 [e1] = Solo e1 - We use a suffix "1" to indicate this. + mkCoreTupSolo [e1] = Solo e1 + We use a suffix "Solo" to indicate this. Usually we want the former, but occasionally the latter. @@ -419,47 +362,52 @@ One-tuples that arise internally depend on the circumstance; often flattening is a good idea. Decisions are made on a case-by-case basis. +'mkCoreBoxedTuple` and `mkBigCoreVarTupSolo` build tuples without flattening. -} --- | Build the type of a small tuple that holds the specified variables --- One-tuples are flattened; see Note [Flattening one-tuples] -mkCoreVarTupTy :: [Id] -> Type -mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) - -- | Build a small tuple holding the specified expressions --- One-tuples are flattened; see Note [Flattening one-tuples] -mkCoreTup :: [CoreExpr] -> CoreExpr -mkCoreTup [c] = c -mkCoreTup cs = mkCoreTup1 cs -- non-1-tuples are uniform - --- | Build a small tuple holding the specified expressions -- One-tuples are *not* flattened; see Note [Flattening one-tuples] -- See also Note [Don't flatten tuples from HsSyn] -mkCoreTup1 :: [CoreExpr] -> CoreExpr -mkCoreTup1 cs = mkCoreConApps (tupleDataCon Boxed (length cs)) - (map (Type . exprType) cs ++ cs) +-- Arguments must have kind Type +mkCoreBoxedTuple :: HasDebugCallStack => [CoreExpr] -> CoreExpr +mkCoreBoxedTuple cs + = assertPpr (all (tcIsLiftedTypeKind . typeKind . exprType) cs) (ppr cs) + mkCoreConApps (tupleDataCon Boxed (length cs)) + (map (Type . exprType) cs ++ cs) --- | Build a small unboxed tuple holding the specified expressions, --- with the given types. The types must be the types of the expressions. + +-- | Build a small unboxed tuple holding the specified expressions. -- Do not include the RuntimeRep specifiers; this function calculates them -- for you. -- Does /not/ flatten one-tuples; see Note [Flattening one-tuples] -mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr -mkCoreUbxTup tys exps - = assert (tys `equalLength` exps) $ - mkCoreConApps (tupleDataCon Unboxed (length tys)) - (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) +mkCoreUnboxedTuple :: [CoreExpr] -> CoreExpr +mkCoreUnboxedTuple exps + = mkCoreConApps (tupleDataCon Unboxed (length tys)) + (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) + where + tys = map exprType exps -- | Make a core tuple of the given boxity; don't flatten 1-tuples mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr -mkCoreTupBoxity Boxed exps = mkCoreTup1 exps -mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps +mkCoreTupBoxity Boxed exps = mkCoreBoxedTuple exps +mkCoreTupBoxity Unboxed exps = mkCoreUnboxedTuple exps +-- | Build the type of a small tuple that holds the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkCoreVarTupTy :: [Id] -> Type +mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) + +-- | Build a small tuple holding the specified expressions +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkCoreTup :: [CoreExpr] -> CoreExpr +mkCoreTup [c] = c +mkCoreTup cs = mkCoreBoxedTuple cs -- non-1-tuples are uniform + -- | Build an unboxed sum. -- -- Alternative number ("alt") starts from 1. -mkCoreUbxSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr -mkCoreUbxSum arity alt tys exp +mkCoreUnboxedSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr +mkCoreUnboxedSum arity alt tys exp = assert (length tys == arity) $ assert (alt <= arity) $ mkCoreConApps (sumDataCon alt arity) @@ -467,37 +415,153 @@ ++ map Type tys ++ [exp]) +{- Note [Big tuples] +~~~~~~~~~~~~~~~~~~~~ +"Big" tuples (`mkBigCoreTup` and friends) are more general than "small" +ones (`mkCoreTup` and friends) in two ways. + +1. GHCs built-in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but + we might conceivably want to build such a massive tuple as part of the + output of a desugaring stage (notably that for list comprehensions). + + `mkBigCoreTup` encodes such big tuples by creating and pattern + matching on /nested/ small tuples that are directly expressible by + GHC. + + Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects) + than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any + construction to be big. + +2. When desugaring arrows we gather up a tuple of free variables, which + may include dictionaries (of kind Constraint) and unboxed values. + + These can't live in a tuple. `mkBigCoreTup` encodes such tuples by + boxing up the offending arguments: see Note [Boxing constructors] + in GHC.Builtin.Types. + +If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkBigTupleSelector' +and 'mkBigTupleCase' functions to do all your work with tuples you should be +fine, and not have to worry about the arity limitation, or kind limitation at +all. + +The "big" tuple operations flatten 1-tuples just like "small" tuples. +But see Note [Don't flatten tuples from HsSyn] +-} + +mkBigCoreVarTupSolo :: [Id] -> CoreExpr +-- Same as mkBigCoreVarTup, but: +-- - one-tuples are not flattened +-- see Note [Flattening one-tuples] +-- - arguments should have kind Type +mkBigCoreVarTupSolo [id] = mkCoreBoxedTuple [Var id] +mkBigCoreVarTupSolo ids = mkChunkified mkCoreTup (map Var ids) + -- | Build a big tuple holding the specified variables -- One-tuples are flattened; see Note [Flattening one-tuples] +-- Arguments don't have to have kind Type mkBigCoreVarTup :: [Id] -> CoreExpr mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) -mkBigCoreVarTup1 :: [Id] -> CoreExpr --- Same as mkBigCoreVarTup, but one-tuples are NOT flattened --- see Note [Flattening one-tuples] -mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1) - [Type (idType id), Var id] -mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids) +-- | Build a "big" tuple holding the specified expressions +-- One-tuples are flattened; see Note [Flattening one-tuples] +-- Arguments don't have to have kind Type; ones that do not are boxed +-- This function crashes (in wrapBox) if given a non-Type +-- argument that it doesn't know how to box. +mkBigCoreTup :: [CoreExpr] -> CoreExpr +mkBigCoreTup exprs = mkChunkified mkCoreTup (map wrapBox exprs) -- | 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 ids = mkBigCoreTupTy (map idType ids) --- | Build a big tuple holding the specified expressions --- One-tuples are flattened; see Note [Flattening one-tuples] -mkBigCoreTup :: [CoreExpr] -> CoreExpr -mkBigCoreTup = mkChunkified mkCoreTup - -- | 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 = mkChunkified mkBoxedTupleTy +mkBigCoreTupTy tys = mkChunkified mkBoxedTupleTy $ + map boxTy tys -- | The unit expression unitExpr :: CoreExpr unitExpr = Var unitDataConId +-------------------------------------------------------------- +wrapBox :: CoreExpr -> CoreExpr +-- ^ If (e :: ty) and (ty :: Type), wrapBox is a no-op +-- But if (ty :: ki), and ki is not Type, wrapBox returns (K @ty e) +-- which has kind Type +-- where K is the boxing data constructor for ki +-- See Note [Boxing constructors] in GHC.Builtin.Types +-- Panics if there /is/ no boxing data con +wrapBox e + = case boxingDataCon e_ty of + BI_NoBoxNeeded -> e + BI_Box { bi_inst_con = boxing_expr } -> App boxing_expr e + BI_NoBoxAvailable -> pprPanic "wrapBox" (ppr e $$ ppr (exprType e)) + -- We should do better than panicing: #22336 + where + e_ty = exprType e + +boxTy :: 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`. +-- Panics if it is not possible to box `ty`, like `wrapBox` (#22336) +-- See Note [Boxing constructors] in GHC.Builtin.Types +boxTy ty + = case boxingDataCon ty of + BI_NoBoxNeeded -> ty + BI_Box { bi_boxed_type = box_ty } -> box_ty + BI_NoBoxAvailable -> pprPanic "boxTy" (ppr ty) + -- We should do better than panicing: #22336 + +unwrapBox :: UniqSupply -> Id -> CoreExpr + -> (UniqSupply, Id, CoreExpr) +-- If v's type required boxing (i.e it is unlifted or a constraint) +-- then (unwrapBox us v body) returns +-- (case box_v of MkDict v -> body) +-- together with box_v +-- where box_v is a fresh variable +-- Otherwise unwrapBox is a no-op +-- Panics if no box is available (#22336) +unwrapBox us var body + = case boxingDataCon var_ty of + BI_NoBoxNeeded -> (us, var, body) + BI_NoBoxAvailable -> pprPanic "unwrapBox" (ppr var $$ ppr var_ty) + -- We should do better than panicing: #22336 + BI_Box { bi_data_con = box_con, bi_boxed_type = box_ty } + -> (us', var', body') + where + var' = mkSysLocal (fsLit "uc") uniq ManyTy box_ty + body' = Case (Var var') var' (exprType body) + [Alt (DataAlt box_con) [var] body] + where + var_ty = idType var + (uniq, us') = takeUniqFromSupply us + +-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decomposition +mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' + -> [a] -- ^ Possible \"big\" list of things to construct from + -> a -- ^ Constructed thing made possible by recursive decomposition +mkChunkified small_tuple as = mk_big_tuple (chunkify as) + where + -- Each sub-list is short enough to fit in a tuple + mk_big_tuple [as] = small_tuple as + mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) + +chunkify :: [a] -> [[a]] +-- ^ Split a list into lists that are small enough to have a corresponding +-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE' +-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists +chunkify xs + | n_xs <= mAX_TUPLE_SIZE = [xs] + | otherwise = split xs + where + n_xs = length xs + split [] = [] + split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) + + {- ************************************************************************ * * @@ -506,7 +570,7 @@ ************************************************************************ -} --- | Builds a selector which scrutises the given +-- | Builds a selector which scrutinises the given -- expression and extracts the one name from the list given. -- If you want the no-shadowing rule to apply, the caller -- is responsible for making sure that none of these names @@ -518,16 +582,16 @@ -- If necessary, we pattern match on a \"big\" tuple. -- -- A tuple selector is not linear in its argument. Consequently, the case --- expression built by `mkTupleSelector` must consume its scrutinee 'Many' +-- expression built by `mkBigTupleSelector` must consume its scrutinee 'Many' -- times. And all the argument variables must have multiplicity 'Many'. -mkTupleSelector, mkTupleSelector1 +mkBigTupleSelector, mkBigTupleSelectorSolo :: [Id] -- ^ The 'Id's to pattern match the tuple against -> Id -- ^ The 'Id' to select -> Id -- ^ A variable of the same type as the scrutinee -> CoreExpr -- ^ Scrutinee -> CoreExpr -- ^ Selector expression --- mkTupleSelector [a,b,c,d] b v e +-- mkBigTupleSelector [a,b,c,d] b v e -- = case e of v { -- (p,q) -> case p of p { -- (a,b) -> b }} @@ -538,7 +602,7 @@ -- case (case e of v -- (p,q) -> p) of p -- (a,b) -> b -mkTupleSelector vars the_var scrut_var scrut +mkBigTupleSelector vars the_var scrut_var scrut = mk_tup_sel (chunkify vars) the_var where mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut @@ -547,18 +611,18 @@ where tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] tpl_vs = mkTemplateLocals tpl_tys - [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, + [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkBigTupleSelector" tpl_vs vars_s, the_var `elem` gp ] --- ^ 'mkTupleSelector1' is like 'mkTupleSelector' +-- ^ 'mkBigTupleSelectorSolo' is like 'mkBigTupleSelector' -- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) -mkTupleSelector1 vars the_var scrut_var scrut +mkBigTupleSelectorSolo vars the_var scrut_var scrut | [_] <- vars = mkSmallTupleSelector1 vars the_var scrut_var scrut | otherwise - = mkTupleSelector vars the_var scrut_var scrut + = mkBigTupleSelector vars the_var scrut_var scrut --- | Like 'mkTupleSelector' but for tuples that are guaranteed --- never to be \"big\". +-- | `mkSmallTupleSelector` is like 'mkBigTupleSelector', but for tuples that +-- are guaranteed never to be "big". Also does not unwrap boxed types. -- -- > mkSmallTupleSelector [x] x v e = [| e |] -- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |] @@ -581,45 +645,71 @@ Case scrut scrut_var (idType the_var) [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)] --- | A generalization of 'mkTupleSelector', allowing the body +-- | A generalization of 'mkBigTupleSelector', allowing the body -- of the case to be an arbitrary expression. -- -- To avoid shadowing, we use uniques to invent new variables. -- --- If necessary we pattern match on a \"big\" tuple. -mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables - -> [Id] -- ^ The tuple identifiers to pattern match on - -> CoreExpr -- ^ Body of the case - -> Id -- ^ A variable of the same type as the scrutinee - -> CoreExpr -- ^ Scrutinee - -> CoreExpr +-- 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; + -- Bring these into scope in the body + -> CoreExpr -- ^ Body of the case + -> CoreExpr -- ^ Scrutinee + -> CoreExpr -- ToDo: eliminate cases where none of the variables are needed. -- --- mkTupleCase uniqs [a,b,c,d] body v e +-- mkBigTupleCase uniqs [a,b,c,d] body v e -- = case e of v { (p,q) -> -- case p of p { (a,b) -> -- case q of q { (c,d) -> -- body }}} -mkTupleCase uniqs vars body scrut_var scrut - = mk_tuple_case uniqs (chunkify vars) body +mkBigTupleCase us vars body scrut + = 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) + = (us', var':vars, body') + where + (us', var', body') = unwrapBox us var body + + mk_tuple_case :: UniqSupply -> [[Id]] -> CoreExpr -> CoreExpr + -- mk_tuple_case [[a1..an], [b1..bm], ...] body + -- case scrut of (p,q, ...) -> + -- case p of (a1,..an) -> + -- case q of (b1,..bm) -> + -- ... -> body -- This is the case where don't need any nesting - mk_tuple_case _ [vars] body + mk_tuple_case us [vars] body = mkSmallTupleCase vars body scrut_var scrut + where + scrut_var = case scrut of + Var v -> v + _ -> snd (new_var us scrut_ty) - -- This is the case where we must make nest tuples at least once + -- This is the case where we must nest tuples at least once mk_tuple_case us vars_s body - = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s - in mk_tuple_case us' (chunkify vars') body' + = mk_tuple_case us' (chunkify vars') body' + where + (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s one_tuple_case chunk_vars (us, vs, body) - = let (uniq, us') = takeUniqFromSupply us - scrut_var = mkSysLocal (fsLit "ds") uniq Many - (mkBoxedTupleTy (map idType chunk_vars)) - body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) - in (us', scrut_var:vs, body') + = (us', scrut_var:vs, body') + where + tup_ty = mkBoxedTupleTy (map idType chunk_vars) + (us', scrut_var) = new_var us tup_ty + body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) --- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed + new_var :: UniqSupply -> Type -> (UniqSupply, Id) + new_var us ty = (us', id) + where + (uniq, us') = takeUniqFromSupply us + id = mkSysLocal (fsLit "ds") uniq ManyTy ty + +-- | As 'mkBigTupleCase', but for a tuple that is small enough to be guaranteed -- not to need nesting. mkSmallTupleCase :: [Id] -- ^ The tuple args @@ -631,7 +721,6 @@ mkSmallTupleCase [var] body _scrut_var scrut = bindNonRec var scrut body mkSmallTupleCase vars body scrut_var scrut --- One branch no refinement? = Case scrut scrut_var (exprType body) [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body] @@ -694,9 +783,6 @@ mkListExpr :: Type -> [CoreExpr] -> CoreExpr mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs -mkNonEmptyListExpr :: Type -> CoreExpr -> [CoreExpr] -> CoreExpr -mkNonEmptyListExpr ty x xs = mkCoreConApps nonEmptyDataCon [Type ty, x, mkListExpr ty xs] - -- | Make a fully applied 'foldr' expression mkFoldrExpr :: MonadThings m => Type -- ^ Element type of the list @@ -724,7 +810,7 @@ n_tyvar <- newTyVar alphaTyVar let n_ty = mkTyVarTy n_tyvar c_ty = mkVisFunTysMany [elt_ty, n_ty] n_ty - [c, n] <- sequence [mkSysLocalM (fsLit "c") Many c_ty, mkSysLocalM (fsLit "n") Many n_ty] + [c, n] <- sequence [mkSysLocalM (fsLit "c") ManyTy c_ty, mkSysLocalM (fsLit "n") ManyTy n_ty] build_inside <- mk_build_inside (c, c_ty) (n, n_ty) @@ -762,7 +848,9 @@ -} mkRuntimeErrorApp - :: Id -- Should be of type (forall a. Addr# -> a) + :: Id -- Should be of type + -- forall (r::RuntimeRep) (a::TYPE r). Addr# -> a + -- or (a :: CONSTRAINT r) -- where Addr# points to a UTF8 encoded string -> Type -- The type to instantiate 'a' -> String -- The string to print @@ -774,10 +862,6 @@ where err_string = Lit (mkLitString err_msg) -mkImpossibleExpr :: Type -> CoreExpr -mkImpossibleExpr res_ty - = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" - {- ************************************************************************ * * @@ -799,29 +883,23 @@ errorIds :: [Id] errorIds - = [ rUNTIME_ERROR_ID, - nON_EXHAUSTIVE_GUARDS_ERROR_ID, + = [ nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, pAT_ERROR_ID, rEC_CON_ERROR_ID, rEC_SEL_ERROR_ID, - aBSENT_ERROR_ID, + iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID, + aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID, - tYPE_ERROR_ID, -- Used with Opt_DeferTypeErrors, see #10284 - rAISE_OVERFLOW_ID, - rAISE_UNDERFLOW_ID, - rAISE_DIVZERO_ID + tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284 ] -recSelErrorName, runtimeErrorName, absentErrorName :: Name -recConErrorName, patErrorName :: Name +recSelErrorName, recConErrorName, patErrorName :: Name nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name typeErrorName :: Name absentSumFieldErrorName :: Name -raiseOverflowName, raiseUnderflowName, raiseDivZeroName :: Name recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID -runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID @@ -834,17 +912,15 @@ err_nm :: String -> Unique -> Id -> Name err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id -rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id +rEC_SEL_ERROR_ID, rEC_CON_ERROR_ID :: Id pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id -tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id -rAISE_OVERFLOW_ID, rAISE_UNDERFLOW_ID, rAISE_DIVZERO_ID :: Id -rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName -rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName -rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName -pAT_ERROR_ID = mkRuntimeErrorId patErrorName -nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName -nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName -tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName +tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id +rEC_SEL_ERROR_ID = mkRuntimeErrorId TypeLike recSelErrorName +rEC_CON_ERROR_ID = mkRuntimeErrorId TypeLike recConErrorName +pAT_ERROR_ID = mkRuntimeErrorId TypeLike patErrorName +nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId TypeLike noMethodBindingErrorName +nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId TypeLike nonExhaustiveGuardsErrorName +tYPE_ERROR_ID = mkRuntimeErrorId TypeLike typeErrorName -- Note [aBSENT_SUM_FIELD_ERROR_ID] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -945,38 +1021,7 @@ absentSumFieldErrorIdKey aBSENT_SUM_FIELD_ERROR_ID -absentErrorName - = mkWiredInIdName - gHC_PRIM_PANIC - (fsLit "absentError") - absentErrorIdKey - aBSENT_ERROR_ID - -raiseOverflowName - = mkWiredInIdName - gHC_PRIM_EXCEPTION - (fsLit "raiseOverflow") - raiseOverflowIdKey - rAISE_OVERFLOW_ID - -raiseUnderflowName - = mkWiredInIdName - gHC_PRIM_EXCEPTION - (fsLit "raiseUnderflow") - raiseUnderflowIdKey - rAISE_UNDERFLOW_ID - -raiseDivZeroName - = mkWiredInIdName - gHC_PRIM_EXCEPTION - (fsLit "raiseDivZero") - raiseDivZeroIdKey - rAISE_DIVZERO_ID - aBSENT_SUM_FIELD_ERROR_ID = mkExceptionId absentSumFieldErrorName -rAISE_OVERFLOW_ID = mkExceptionId raiseOverflowName -rAISE_UNDERFLOW_ID = mkExceptionId raiseUnderflowName -rAISE_DIVZERO_ID = mkExceptionId raiseDivZeroName -- | Exception with type \"forall a. a\" -- @@ -989,31 +1034,7 @@ (divergingIdInfo [] `setCafInfo` NoCafRefs) -- See Note [Wired-in exceptions are not CAFfy] -mkRuntimeErrorId :: Name -> Id --- Error function --- 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 --- a UTF8-encoded error string -mkRuntimeErrorId name - = mkVanillaGlobalWithInfo name runtimeErrorTy (divergingIdInfo [evalDmd]) - -- Do *not* mark them as NoCafRefs, because they can indeed have - -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, - -- which has some CAFs - -- In due course we may arrange that these error-y things are - -- regarded by the GC as permanently live, in which case we - -- can give them NoCaf info. As it is, any function that calls - -- any pc_bottoming_Id will itself have CafRefs, which bloats - -- SRTs. - -runtimeErrorTy :: Type --- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a --- See Note [Error and friends have an "open-tyvar" forall] -runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] - (mkVisFunTyMany addrPrimTy openAlphaTy) - --- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID' or 'raiseOverflow', that +-- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID', that -- throws an (imprecise) exception after being supplied one value arg for every -- argument 'Demand' in the list. The demands end up in the demand signature. -- @@ -1042,6 +1063,56 @@ ************************************************************************ * * + iMPOSSIBLE_ERROR_ID +* * +************************************************************************ +-} + +iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID :: Id +iMPOSSIBLE_ERROR_ID = mkRuntimeErrorId TypeLike impossibleErrorName +iMPOSSIBLE_CONSTRAINT_ERROR_ID = mkRuntimeErrorId ConstraintLike impossibleConstraintErrorName + +impossibleErrorName, impossibleConstraintErrorName :: Name +impossibleErrorName = err_nm "impossibleError" + impossibleErrorIdKey iMPOSSIBLE_ERROR_ID +impossibleConstraintErrorName = err_nm "impossibleConstraintError" + impossibleConstraintErrorIdKey iMPOSSIBLE_CONSTRAINT_ERROR_ID + +mkImpossibleExpr :: Type -> String -> CoreExpr +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 + +{- Note [Type vs Constraint for error ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need both + iMPOSSIBLE_ERROR_ID :: forall (r::RuntimeRep) (a::TYPE r). Addr# -> a + iMPOSSIBLE_CONSTRAINT_ERROR_ID :: forall (r::RuntimeRep) (a::CONSTRAINT r). Addr# -> a + +because we don't have polymorphism over TYPE vs CONSTRAINT. You +might wonder if iMPOSSIBLE_CONSTRAINT_ERROR_ID is ever needed in +practice, but it is: see #22634. So: + +* In Control.Exception.Base we have + impossibleError :: forall (a::Type). Addr# -> a + impossibleConstraintError :: forall (a::Type). Addr# -> a + This generates the code for `impossibleError`, but because they are wired in + the interface file definitions are never looked at (indeed, they don't + even get serialised). + +* In this module GHC.Core.Make we define /wired-in/ Ids for + iMPOSSIBLE_ERROR_ID + iMPOSSIBLE_CONSTRAINT_ERROR_ID + with the desired above types (i.e. runtime-rep polymorphic, and returning a + constraint for the latter. + +Much the same plan works for aBSENT_ERROR_ID and aBSENT_CONSTRAINT_ERROR_ID + + +************************************************************************ +* * aBSENT_ERROR_ID * * ************************************************************************ @@ -1122,19 +1193,92 @@ be relying on anything from it. -} -aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID] - = mkVanillaGlobalWithInfo absentErrorName absent_ty id_info - where - absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany addrPrimTy alphaTy) - -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for - -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils - id_info = divergingIdInfo [evalDmd] -- NB: CAFFY! +-- We need two absentError Ids: +-- absentError :: forall (a :: Type). Addr# -> a +-- absentConstraintError :: forall (a :: Constraint). Addr# -> a +-- We don't have polymorphism over TypeOrConstraint! +-- mkAbsentErrorApp chooses which one to use, based on the kind +-- See Note [Type vs Constraint for error ids] mkAbsentErrorApp :: Type -- The type to instantiate 'a' -> String -- The string to print -> CoreExpr mkAbsentErrorApp res_ty err_msg - = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ] + = 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_string = Lit (mkLitString err_msg) + +absentErrorName, absentConstraintErrorName :: Name +absentErrorName + = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentError") + absentErrorIdKey aBSENT_ERROR_ID + +absentConstraintErrorName -- See Note [Type vs Constraint for error ids] + = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentConstraintError") + absentConstraintErrorIdKey aBSENT_CONSTRAINT_ERROR_ID + +aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID :: Id + +aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID] + = mk_runtime_error_id absentErrorName absent_ty + where + -- absentError :: forall (a :: Type). Addr# -> a + absent_ty = mkSpecForAllTys [alphaTyVar] $ + mkVisFunTyMany addrPrimTy (mkTyVarTy alphaTyVar) + -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for + -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils + +aBSENT_CONSTRAINT_ERROR_ID -- See Note [aBSENT_ERROR_ID] + = mk_runtime_error_id absentConstraintErrorName absent_ty + -- See Note [Type vs Constraint for error ids] + where + -- absentConstraintError :: forall (a :: Constraint). Addr# -> a + absent_ty = mkSpecForAllTys [alphaConstraintTyVar] $ + mkFunTy visArgConstraintLike ManyTy + addrPrimTy (mkTyVarTy alphaConstraintTyVar) + + +{- +************************************************************************ +* * + mkRuntimeErrorId +* * +************************************************************************ +-} + +mkRuntimeErrorId :: TypeOrConstraint -> Name -> Id +-- Error function +-- 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 +-- a UTF8-encoded error string +mkRuntimeErrorId torc name = mk_runtime_error_id name (mkRuntimeErrorTy torc) + + +mk_runtime_error_id :: Name -> Type -> Id +mk_runtime_error_id name ty + = mkVanillaGlobalWithInfo name ty (divergingIdInfo [evalDmd]) + -- Do *not* mark them as NoCafRefs, because they can indeed have + -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, + -- which has some CAFs + -- In due course we may arrange that these error-y things are + -- regarded by the GC as permanently live, in which case we + -- can give them NoCaf info. As it is, any function that calls + -- any pc_bottoming_Id will itself have CafRefs, which bloats + -- SRTs. + +mkRuntimeErrorTy :: TypeOrConstraint -> Type +-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a +-- See Note [Error and friends have an "open-tyvar" forall] +mkRuntimeErrorTy torc = mkSpecForAllTys [runtimeRep1TyVar, tyvar] $ + mkFunctionType ManyTy addrPrimTy (mkTyVarTy tyvar) + where + (tyvar:_) = 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 @@ -109,13 +109,17 @@ -- is the type you want. newtype CoreMap a = CoreMap (CoreMapG a) +-- TODO(22292): derive +instance Functor CoreMap where + fmap f = \ (CoreMap m) -> CoreMap (fmap f m) + {-# INLINE fmap #-} + instance TrieMap CoreMap where type Key CoreMap = CoreExpr emptyTM = CoreMap emptyTM lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m) foldTM k (CoreMap m) = foldTM k m - mapTM f (CoreMap m) = CoreMap (mapTM f m) filterTM f (CoreMap m) = CoreMap (filterTM f m) -- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended @@ -146,9 +150,8 @@ eqDeBruijnExpr :: DeBruijn CoreExpr -> DeBruijn CoreExpr -> Bool eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where - go (Var v1) (Var v2) = eqDeBruijnVar (D env1 v1) (D env2 v2) + go (Var v1) (Var v2) = eqDeBruijnVar (D env1 v1) (D env2 v2) go (Lit lit1) (Lit lit2) = lit1 == lit2 - -- See Note [Using tcView inside eqDeBruijnType] in GHC.Core.Map.Type go (Type t1) (Type t2) = eqDeBruijnType (D env1 t1) (D env2 t2) -- See Note [Alpha-equality for Coercion arguments] go (Coercion {}) (Coercion {}) = True @@ -159,7 +162,6 @@ && go e1 e2 go (Lam b1 e1) (Lam b2 e2) - -- See Note [Using tcView inside eqDeBruijnType] in GHC.Core.Map.Type = eqDeBruijnType (D env1 (varType b1)) (D env2 (varType b2)) && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2) && eqDeBruijnExpr (D (extendCME env1 b1) e1) (D (extendCME env2 b2) e2) @@ -171,9 +173,7 @@ go (Let (Rec ps1) e1) (Let (Rec ps2) e2) = equalLength ps1 ps2 -- See Note [Alpha-equality for let-bindings] - && all2 (\b1 b2 -> -- See Note [Using tcView inside eqDeBruijnType] in - -- GHC.Core.Map.Type - eqDeBruijnType (D env1 (varType b1)) + && all2 (\b1 b2 -> eqDeBruijnType (D env1 (varType b1)) (D env2 (varType b2))) bs1 bs2 && D env1' rs1 == D env2' rs2 @@ -248,30 +248,27 @@ , cm_letr = emptyTM, cm_case = emptyTM , cm_ecase = emptyTM, cm_tick = emptyTM } +-- TODO(22292): derive +instance Functor CoreMapX where + fmap 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 = fmap f cvar, cm_lit = fmap f clit, cm_co = fmap f cco, cm_type = fmap f ctype + , cm_cast = fmap (fmap f) ccast, cm_app = fmap (fmap f) capp, cm_lam = fmap (fmap f) clam + , cm_letn = fmap (fmap (fmap f)) cletn, cm_letr = fmap (fmap (fmap f)) cletr + , cm_case = fmap (fmap f) ccase, cm_ecase = fmap (fmap f) cecase + , cm_tick = fmap (fmap f) ctick } + instance TrieMap CoreMapX where type Key CoreMapX = DeBruijn CoreExpr emptyTM = emptyE lookupTM = lkE alterTM = xtE foldTM = fdE - mapTM = mapE filterTM = ftE -------------------------- -mapE :: (a->b) -> CoreMapX a -> CoreMapX b -mapE 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 = mapTM f cvar, cm_lit = mapTM f clit - , cm_co = mapTM f cco, cm_type = mapTM f ctype - , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp - , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn - , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase - , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick } - ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a ftE f (CM { cm_var = cvar, cm_lit = clit , cm_co = cco, cm_type = ctype @@ -281,10 +278,10 @@ , cm_ecase = cecase, cm_tick = ctick }) = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit , cm_co = filterTM f cco, cm_type = filterTM f ctype - , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp - , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn - , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase - , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick } + , cm_cast = fmap (filterTM f) ccast, cm_app = fmap (filterTM f) capp + , cm_lam = fmap (filterTM f) clam, cm_letn = fmap (fmap (filterTM f)) cletn + , 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 } -------------------------- lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a @@ -394,6 +391,11 @@ , am_data :: DNameEnv (CoreMapG a) , am_lit :: LiteralMap (CoreMapG a) } +-- TODO(22292): derive +instance Functor AltMap where + fmap f AM { am_deflt = adeflt, am_data = adata, am_lit = alit } = AM + { am_deflt = fmap f adeflt, am_data = fmap (fmap f) adata, am_lit = fmap (fmap f) alit } + instance TrieMap AltMap where type Key AltMap = CoreAlt emptyTM = AM { am_deflt = emptyTM @@ -402,7 +404,6 @@ lookupTM = lkA emptyCME alterTM = xtA emptyCME foldTM = fdA - mapTM = mapA filterTM = ftA instance Eq (DeBruijn CoreAlt) where @@ -416,17 +417,11 @@ D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 go _ _ = False -mapA :: (a->b) -> AltMap a -> AltMap b -mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) - = AM { am_deflt = mapTM f adeflt - , am_data = mapTM (mapTM f) adata - , am_lit = mapTM (mapTM f) alit } - ftA :: (a->Bool) -> AltMap a -> AltMap a ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) = AM { am_deflt = filterTM f adeflt - , am_data = mapTM (filterTM f) adata - , am_lit = mapTM (filterTM f) alit } + , am_data = fmap (filterTM f) adata + , am_lit = fmap (filterTM f) alit } lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a lkA env (Alt DEFAULT _ rhs) = am_deflt >.> lkG (D env rhs) 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.TyCo.Compare( eqForAllVis ) import GHC.Data.TrieMap import GHC.Data.FastString @@ -54,7 +55,6 @@ import qualified Data.IntMap as IntMap import Control.Monad ( (>=>) ) -import GHC.Data.Maybe -- NB: Be careful about RULES and type families (#5821). So we should make sure -- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form) @@ -83,25 +83,33 @@ -- just look up the coercion's type. newtype CoercionMap a = CoercionMap (CoercionMapG a) +-- TODO(22292): derive +instance Functor CoercionMap where + fmap f = \ (CoercionMap m) -> CoercionMap (fmap f m) + {-# INLINE fmap #-} + instance TrieMap CoercionMap where type Key CoercionMap = Coercion emptyTM = CoercionMap emptyTM lookupTM k (CoercionMap m) = lookupTM (deBruijnize k) m alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m) foldTM k (CoercionMap m) = foldTM k m - mapTM f (CoercionMap m) = CoercionMap (mapTM f m) filterTM f (CoercionMap m) = CoercionMap (filterTM f m) type CoercionMapG = GenMap CoercionMapX newtype CoercionMapX a = CoercionMapX (TypeMapX a) +-- TODO(22292): derive +instance Functor CoercionMapX where + fmap f = \ (CoercionMapX core_tm) -> CoercionMapX (fmap f core_tm) + {-# INLINE fmap #-} + instance TrieMap CoercionMapX where type Key CoercionMapX = DeBruijn Coercion emptyTM = CoercionMapX emptyTM lookupTM = lkC alterTM = xtC foldTM f (CoercionMapX core_tm) = foldTM f core_tm - mapTM f (CoercionMapX core_tm) = CoercionMapX (mapTM f core_tm) filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm) instance Eq (DeBruijn Coercion) where @@ -141,13 +149,6 @@ = TM { tm_var :: VarMap a , tm_app :: TypeMapG (TypeMapG a) -- Note [Equality on AppTys] in GHC.Core.Type , tm_tycon :: DNameEnv a - - -- only InvisArg arrows here - , tm_funty :: TypeMapG (TypeMapG (TypeMapG a)) - -- keyed on the argument, result rep, and result - -- constraints are never linear-restricted and are always lifted - -- See also Note [Equality on FunTys] in GHC.Core.TyCo.Rep - , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] in GHC.Core.Map.Expr , tm_tylit :: TyLitMap a , tm_coerce :: Maybe a @@ -157,54 +158,40 @@ -- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the -- last one? See Note [Equality on AppTys] in GHC.Core.Type -- --- Note, however, that we keep Constraint and Type apart here, despite the fact --- that they are both synonyms of TYPE 'LiftedRep (see #11715). --- -- We also keep (Eq a => a) as a FunTy, distinct from ((->) (Eq a) a). trieMapView :: Type -> Maybe Type trieMapView ty -- First check for TyConApps that need to be expanded to - -- AppTy chains. - | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty + -- AppTy chains. This includes eliminating FunTy entirely. + | Just (tc, tys@(_:_)) <- splitTyConApp_maybe ty = Just $ foldl' AppTy (mkTyConTy tc) tys -- Then resolve any remaining nullary synonyms. - | Just ty' <- tcView ty = Just ty' + | Just ty' <- coreView ty + = Just ty' + trieMapView _ = Nothing +-- TODO(22292): derive +instance Functor TypeMapX where + fmap f TM + { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon, tm_forall = tforall + , tm_tylit = tlit, tm_coerce = tcoerce } = TM + { tm_var = fmap f tvar, tm_app = fmap (fmap f) tapp, tm_tycon = fmap f ttycon + , tm_forall = fmap (fmap f) tforall + , tm_tylit = fmap f tlit, tm_coerce = fmap f tcoerce } + instance TrieMap TypeMapX where type Key TypeMapX = DeBruijn Type emptyTM = emptyT lookupTM = lkT alterTM = xtT foldTM = fdT - mapTM = mapT filterTM = filterT instance Eq (DeBruijn Type) where (==) = eqDeBruijnType -{- Note [Using tcView inside eqDeBruijnType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -`eqDeBruijnType` uses `tcView` and thus treats Type and Constraint as -distinct -- see Note [coreView vs tcView] in GHC.Core.Type. We do that because -`eqDeBruijnType` is used in TrieMaps, which are used for instance for instance -selection in the type checker. [Or at least will be soon.] - -However, the odds that we have two expressions that are identical save for the -'Type'/'Constraint' distinction are low. (Not impossible to do. But doubtful -anyone has ever done so in the history of Haskell.) - -And it's actually all OK: 'eqExpr' is conservative: if `eqExpr e1 e2` returns -'True', thne it must be that `e1` behaves identically to `e2` in all contexts. -But if `eqExpr e1 e2` returns 'False', then we learn nothing. The use of -'tcView' where we expect 'coreView' means 'eqExpr' returns 'False' bit more -often that it should. This might, say, stop a `RULE` from firing or CSE from -optimizing an expression. Stopping `RULE` firing is good actually: `RULES` are -written in Haskell, where `Type /= Constraint`. Stopping CSE is unfortunate, -but tolerable. --} - -- | An equality relation between two 'Type's (known below as @t1 :: k2@ -- and @t2 :: k2@) data TypeEquality = TNEQ -- ^ @t1 /= t2@ @@ -246,9 +233,8 @@ | tc1 == tc2 = TEQ go env_t@(D env t) env_t'@(D env' t') - -- See Note [Using tcView inside eqDeBruijnType] - | Just new_t <- tcView t = go (D env new_t) env_t' - | Just new_t' <- tcView t' = go env_t (D env' new_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') | otherwise = case (t, t') of -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep @@ -258,9 +244,9 @@ (TyVarTy v, TyVarTy v') -> liftEquality $ eqDeBruijnVar (D env v) (D env' v') -- See Note [Equality on AppTys] in GHC.Core.Type - (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s + (AppTy t1 t2, s) | Just (t1', t2') <- splitAppTyNoView_maybe s -> go (D env t1) (D env' t1') `andEq` go (D env t2) (D env' t2') - (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s + (s, AppTy t1' t2') | Just (t1, t2) <- splitAppTyNoView_maybe s -> go (D env t1) (D env' t1') `andEq` go (D env t2) (D env' t2') (FunTy v1 w1 t1 t2, FunTy v1' w1' t1' t2') @@ -276,16 +262,19 @@ (LitTy l, LitTy l') -> liftEquality (l == l') (ForAllTy (Bndr tv vis) ty, ForAllTy (Bndr tv' vis') ty') - -> -- See Note [ForAllTy and typechecker equality] in - -- GHC.Tc.Solver.Canonical for why we use `sameVis` here - liftEquality (vis `sameVis` vis') `andEq` + -> -- See Note [ForAllTy and type equality] in + -- GHC.Core.TyCo.Compare for why we use `eqForAllVis` here + liftEquality (vis `eqForAllVis` vis') `andEq` go (D env (varType tv)) (D env' (varType tv')) `andEq` go (D (extendCME env tv) ty) (D (extendCME env' tv') ty') (CoercionTy {}, CoercionTy {}) -> TEQ _ -> TNEQ - gos _ _ [] [] = TEQ + -- These bangs make 'gos' strict in the CMEnv, which in turn + -- keeps the CMEnv unboxed across the go/gos mutual recursion + -- (If you want a test case, T9872c really exercises this code.) + gos !_ !_ [] [] = TEQ gos e1 e2 (ty1:tys1) (ty2:tys2) = go (D e1 ty1) (D e2 ty2) `andEq` gos e1 e2 tys1 tys2 gos _ _ _ _ = TNEQ @@ -308,23 +297,10 @@ emptyT = TM { tm_var = emptyTM , tm_app = emptyTM , tm_tycon = emptyDNameEnv - , tm_funty = emptyTM , tm_forall = emptyTM , tm_tylit = emptyTyLitMap , tm_coerce = Nothing } -mapT :: (a->b) -> TypeMapX a -> TypeMapX b -mapT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon - , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit - , tm_coerce = tcoerce }) - = TM { tm_var = mapTM f tvar - , tm_app = mapTM (mapTM f) tapp - , tm_tycon = mapTM f ttycon - , tm_funty = mapTM (mapTM (mapTM f)) tfunty - , tm_forall = mapTM (mapTM f) tforall - , tm_tylit = mapTM f tlit - , tm_coerce = fmap f tcoerce } - ----------------- lkT :: DeBruijn Type -> TypeMapX a -> Maybe a lkT (D env ty) m = go ty m @@ -334,19 +310,17 @@ go (AppTy t1 t2) = tm_app >.> lkG (D env t1) >=> lkG (D env t2) go (TyConApp tc []) = tm_tycon >.> lkDNamed tc - go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) go (LitTy l) = tm_tylit >.> lkTyLit l go (ForAllTy (Bndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) >=> lkBndr env tv - go (FunTy InvisArg _ arg res) - | Just res_rep <- getRuntimeRep_maybe res - = tm_funty >.> lkG (D env arg) - >=> lkG (D env res_rep) - >=> lkG (D env res) - go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) go (CastTy t _) = go t go (CoercionTy {}) = tm_coerce + -- trieMapView has eliminated non-nullary TyConApp + -- and FunTy into an AppTy chain + go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) + go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) + ----------------- xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m @@ -355,16 +329,15 @@ xtT (D env (AppTy t1 t2)) f m = m { tm_app = tm_app m |> xtG (D env t1) |>> xtG (D env t2) f } xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtDNamed tc f } -xtT (D env (FunTy InvisArg _ t1 t2)) f m = m { tm_funty = tm_funty m |> xtG (D env t1) - |>> xtG (D env t2_rep) - |>> xtG (D env t2) f } - where t2_rep = expectJust "xtT FunTy InvisArg" (getRuntimeRep_maybe t2) xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } xtT (D env (CastTy t _)) f m = xtT (D env t) f m xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f } xtT (D env (ForAllTy (Bndr tv _) ty)) f m = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty) |>> xtBndr env tv f } + +-- trieMapView has eliminated non-nullary TyConApp +-- and FunTy into an AppTy chain xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty) xtT (D _ ty@(FunTy {})) _ _ = pprPanic "xtT FunTy" (ppr ty) @@ -372,20 +345,18 @@ fdT k m = foldTM k (tm_var m) . foldTM (foldTM k) (tm_app m) . foldTM k (tm_tycon m) - . foldTM (foldTM (foldTM k)) (tm_funty m) . foldTM (foldTM k) (tm_forall m) . foldTyLit k (tm_tylit m) . foldMaybe k (tm_coerce m) filterT :: (a -> Bool) -> TypeMapX a -> TypeMapX a filterT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon - , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit + , tm_forall = tforall, tm_tylit = tlit , tm_coerce = tcoerce }) = TM { tm_var = filterTM f tvar - , tm_app = mapTM (filterTM f) tapp + , tm_app = fmap (filterTM f) tapp , tm_tycon = filterTM f ttycon - , tm_funty = mapTM (mapTM (filterTM f)) tfunty - , tm_forall = mapTM (filterTM f) tforall + , tm_forall = fmap (filterTM f) tforall , tm_tylit = filterTM f tlit , tm_coerce = filterMaybe f tcoerce } @@ -395,22 +366,22 @@ , tlm_char :: Map.Map Char a } +-- TODO(22292): derive +instance Functor TyLitMap where + fmap f TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc } = TLM + { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc } + instance TrieMap TyLitMap where type Key TyLitMap = TyLit emptyTM = emptyTyLitMap lookupTM = lkTyLit alterTM = xtTyLit foldTM = foldTyLit - mapTM = mapTyLit filterTM = filterTyLit emptyTyLitMap :: TyLitMap a emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty } -mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b -mapTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc }) - = TLM { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc } - lkTyLit :: TyLit -> TyLitMap a -> Maybe a lkTyLit l = case l of @@ -439,6 +410,11 @@ -- is the type you want. The keys in this map may have different kinds. newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a)) +-- TODO(22292): derive +instance Functor TypeMap where + fmap f = \ (TypeMap m) -> TypeMap (fmap (fmap f) m) + {-# INLINE fmap #-} + lkTT :: DeBruijn Type -> TypeMap a -> Maybe a lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m >>= lkG (D env ty) @@ -456,8 +432,7 @@ lookupTM k m = lkTT (deBruijnize k) m alterTM k f m = xtTT (deBruijnize k) f m foldTM k (TypeMap m) = foldTM (foldTM k) m - mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m) - filterTM f (TypeMap m) = TypeMap (mapTM (filterTM f) m) + filterTM f (TypeMap m) = TypeMap (fmap (filterTM f) m) foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b foldTypeMap k z m = foldTM k m z @@ -488,16 +463,19 @@ -- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g), -- you'll find entries inserted under (t), even if (g) is non-reflexive. -newtype LooseTypeMap a - = LooseTypeMap (TypeMapG a) +newtype LooseTypeMap a = LooseTypeMap (TypeMapG a) +-- TODO(22292): derive +instance Functor LooseTypeMap where + fmap f = \ (LooseTypeMap m) -> LooseTypeMap (fmap f m) + {-# INLINE fmap #-} + instance TrieMap LooseTypeMap where type Key LooseTypeMap = Type emptyTM = LooseTypeMap emptyTM lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m) foldTM f (LooseTypeMap m) = foldTM f m - mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m) filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m) {- @@ -566,18 +544,19 @@ -- of pairs are composition. data BndrMap a = BndrMap (TypeMapG (MaybeMap TypeMapG a)) +-- TODO(22292): derive +instance Functor BndrMap where + fmap f = \ (BndrMap tm) -> BndrMap (fmap (fmap f) tm) + {-# INLINE fmap #-} + instance TrieMap BndrMap where type Key BndrMap = Var emptyTM = BndrMap emptyTM lookupTM = lkBndr emptyCME alterTM = xtBndr emptyCME foldTM = fdBndrMap - mapTM = mapBndrMap filterTM = ftBndrMap -mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b -mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm) - fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm @@ -596,24 +575,23 @@ BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt)) ftBndrMap :: (a -> Bool) -> BndrMap a -> BndrMap a -ftBndrMap f (BndrMap tm) = BndrMap (mapTM (filterTM f) tm) +ftBndrMap f (BndrMap tm) = BndrMap (fmap (filterTM f) tm) --------- Variable occurrence ------------- data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable , vm_fvar :: DVarEnv a } -- Free variable +-- TODO(22292): derive +instance Functor VarMap where + fmap f VM { vm_bvar = bv, vm_fvar = fv } = VM { vm_bvar = fmap f bv, vm_fvar = fmap f fv } + instance TrieMap VarMap where type Key VarMap = Var emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv } lookupTM = lkVar emptyCME alterTM = xtVar emptyCME foldTM = fdVar - mapTM = mapVar filterTM = ftVar - -mapVar :: (a->b) -> VarMap a -> VarMap b -mapVar f (VM { vm_bvar = bv, vm_fvar = fv }) - = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv } lkVar :: CmEnv -> Var -> VarMap a -> Maybe a lkVar env v diff --git a/GHC/Core/Multiplicity.hs b/GHC/Core/Multiplicity.hs --- a/GHC/Core/Multiplicity.hs +++ b/GHC/Core/Multiplicity.hs @@ -11,8 +11,8 @@ -} module GHC.Core.Multiplicity ( Mult - , pattern One - , pattern Many + , pattern OneTy + , pattern ManyTy , isMultMul , mkMultAdd , mkMultMul @@ -29,14 +29,16 @@ , scaleScaled , IsSubmult(..) , submult - , mapScaledType) where + , mapScaledType + , pprArrowWithMultiplicity ) where import GHC.Prelude import GHC.Utils.Outputable +import GHC.Core.Type import GHC.Core.TyCo.Rep +import GHC.Types.Var( isFUNArg ) import {-# SOURCE #-} GHC.Builtin.Types ( multMulTyCon ) -import GHC.Core.Type import GHC.Builtin.Names (multMulTyConKey) import GHC.Types.Unique (hasKey) @@ -49,22 +51,30 @@ [https://arxiv.org/abs/1710.09756]. Other important resources in the linear types implementation wiki page [https://gitlab.haskell.org/ghc/ghc/wikis/linear-types/implementation], and the -proposal [https://github.com/ghc-proposals/ghc-proposals/pull/111] which +proposal [https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst] which describes the concrete design at length. For the busy developer, though, here is a high-level view of linear types is the following: - Function arrows are annotated with a multiplicity (as defined by type `Mult` and its smart constructors in this module) - - Because, as a type constructor, the type of function now has an extra - argument, the notation (->) is no longer suitable. We named the function - type constructor `FUN`. - - (->) retains its backward compatible meaning: `(->) a b = a -> b`. To - achieve this, `(->)` is defined as a type synonym to `FUN Many` (see + - Multiplicities, in Haskell, are types of kind `GHC.Types.Multiplicity`. + as in + + map :: forall (p :: Multiplicity). (a %p -> b) -> [a] %p -> [b] + + - The type constructor for function types (FUN) has type + + FUN :: forall (m :: Multiplicity) -> forall {r1) {r2}. TYPE r1 -> TYPE r2 -> Type + + The argument order is explained in https://gitlab.haskell.org/ghc/ghc/-/issues/20164 + - (->) retains its backward compatible meaning: + + (->) a b = a -> b = a %'Many -> b + + To achieve this, `(->)` is defined as a type synonym to `FUN Many` (see below). -- Multiplicities can be reified in Haskell as types of kind - `GHC.Types.Multiplicity` -- Ground multiplicity (that is, without a variable) can be `One` or `Many` +- A ground multiplicity (that is, without a variable) can be `One` or `Many` (`Many` is generally rendered as ω in the scientific literature). Functions whose type is annotated with `One` are linear functions, functions whose type is annotated with `Many` are regular functions, often called “unrestricted” @@ -73,19 +83,9 @@ consumed exactly once, *then* its argument is consumed exactly once. You can think of “consuming exactly once” as evaluating a value in normal form exactly once (though not necessarily in one go). The _Linear Haskell_ article (see - infra) has a more precise definition of “consuming exactly once”. -- Data types can have unrestricted fields (the canonical example being the - `Unrestricted` data type), then these don't need to be consumed for a value to - be consumed exactly once. So consuming a value of type `Unrestricted` exactly - once means forcing it at least once. -- Why “at least once”? Because if `case u of { C x y -> f (C x y) }` is linear - (provided `f` is a linear function). So we might as well have done `case u of - { !z -> f z }`. So, we can observe constructors as many times as we want, and - we are actually allowed to force the same thing several times because laziness - means that we are really forcing a the value once, and observing its - constructor several times. The type checker and the linter recognise some (but - not all) of these multiple forces as indeed linear. Mostly just enough to - support variable patterns. + supra) has a more precise definition of “consuming exactly once”. +- Data constructors are linear by default. + See Note [Data constructors are linear by default]. - Multiplicities form a semiring. - Multiplicities can also be variables and we can universally quantify over these variables. This is referred to as “multiplicity @@ -100,6 +100,8 @@ multiplicity `Many` can consume its scrutinee as many time as it wishes (no matter how much the case expression is consumed). +For linear types in the linter see Note [Linting linearity] in GHC.Core.Lint. + Note [Usages] ~~~~~~~~~~~~~ In the _Linear Haskell_ paper, you'll find typing rules such as these: @@ -132,7 +134,7 @@ Usages are usually group in a UsageEnv, as defined in the UsageEnv module. So, in our function application example, the typechecking algorithm would -receive usage environements f_ue from the typechecking of f, and u_ue from the +receive usage environments f_ue from the typechecking of f, and u_ue from the typechecking of u. Then the output would be f_ue + (k * u_ue). Addition and scaling of usage environment is the pointwise extension of the semiring operations on multiplicities. @@ -206,8 +208,8 @@ Note [Data constructors are linear by default] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Data constructors defined without -XLinearTypes (as well as data constructors -defined with the Haskell 98 in all circumstances) have all their fields linear. +All data constructors defined without -XLinearTypes, as well as data constructors +defined with the Haskell 98 in all circumstances, have all their fields linear. That is, in @@ -217,10 +219,52 @@ Just :: a %1 -> Just a +Irrespective of whether -XLinearTypes is turned on or not. Furthermore, when +-XLinearTypes is turned off, the declaration + + data Endo a where { MkIntEndo :: (Int -> Int) -> T Int } + +gives + + MkIntEndo :: (Int -> Int) %1 -> T Int + +With -XLinearTypes turned on, instead, this would give + + data EndoU a where { MkIntEndoU :: (Int -> Int) -> T Int } + MkIntEndoU :: (Int -> Int) -> T Int + +With -XLinearTypes turned on, to get a linear field with GADT syntax we +would need to write + + data EndoL a where { MkIntEndoL :: (Int -> Int) %1 -> T Int } + The goal is to maximise reuse of types between linear code and traditional code. This is argued at length in the proposal and the article (links in Note [Linear types]). +Unrestricted field don't need to be consumed for a value to be consumed exactly +once. So consuming a value of type `IntEndoU a` exactly once means forcing it at +least once. + +Why “at least once”? Because if `case u of { MkIntEndoL x -> f (MkIntEndoL x) }` +is linear (provided `f` is a linear function). But we might as well have done +`case u of { !z -> f z }`. So, we can observe constructors as many times as we +want, and we are actually allowed to force the same thing several times because +laziness means that we are really forcing the value once, and observing its +constructor several times. The type checker and the linter recognise some (but +not all) of these multiple forces as indeed linear. Mostly just enough to +support variable patterns. + +In summary: + +- Fields of data constructors defined with Haskell 98 syntax are always linear + (even if `-XLinearTypes` is off). This choice has been made to favour sharing + types between linearly typed Haskell and traditional Haskell. To avoid an + ecosystem split. +- When `-XLinearTypes` is off, GADT-syntax declaration can only use the regular + arrow `(->)`. However all the fields are linear. + + Note [Polymorphisation of linear fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The choice in Note [Data constructors are linear by default] has an impact on @@ -295,13 +339,13 @@ -- With only two multiplicities One and Many, we can always replace -- p + q by Many. See Note [Overapproximating multiplicities]. mkMultAdd :: Mult -> Mult -> Mult -mkMultAdd _ _ = Many +mkMultAdd _ _ = ManyTy mkMultMul :: Mult -> Mult -> Mult -mkMultMul One p = p -mkMultMul p One = p -mkMultMul Many _ = Many -mkMultMul _ Many = Many +mkMultMul OneTy p = p +mkMultMul p OneTy = p +mkMultMul ManyTy _ = ManyTy +mkMultMul _ ManyTy = ManyTy mkMultMul p q = mkTyConApp multMulTyCon [p, q] scaleScaled :: Mult -> Scaled a -> Scaled a @@ -329,8 +373,25 @@ -- value of multiplicity @w2@ is expected. This is a partial order. submult :: Mult -> Mult -> IsSubmult -submult _ Many = Submult -submult One One = Submult +submult _ ManyTy = Submult +submult OneTy OneTy = Submult -- The 1 <= p rule -submult One _ = Submult +submult OneTy _ = Submult submult _ _ = Unknown + +pprArrowWithMultiplicity :: FunTyFlag -> Either Bool SDoc -> SDoc +-- Pretty-print a multiplicity arrow. The multiplicity itself +-- is described by the (Either Bool SDoc) +-- Left False -- Many +-- Left True -- One +-- Right doc -- Something else +-- In the Right case, the doc is in parens if not atomic +pprArrowWithMultiplicity af pp_mult + | isFUNArg af + = case pp_mult of + Left False -> arrow + Left True -> lollipop + Right doc -> text "%" <> doc <+> arrow + | otherwise + = ppr (funTyFlagTyCon af) + 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,2176 +7,3132 @@ -} {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - --- | Arity and eta expansion -module GHC.Core.Opt.Arity - ( manifestArity, joinRhsArity, exprArity, typeArity - , exprEtaExpandArity, findRhsArity - , etaExpand, etaExpandAT - , exprBotStrictness_maybe - - -- ** ArityType - , ArityType(..), mkBotArityType, mkManifestArityType, expandableArityType - , arityTypeArity, maxWithArity, idArityType - - -- ** Join points - , etaExpandToJoinPoint, etaExpandToJoinPointRule - - -- ** Coercions and casts - , pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg - , pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo - ) -where - -import GHC.Prelude - -import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt ) - -import GHC.Core -import GHC.Core.FVs -import GHC.Core.Utils -import GHC.Core.DataCon -import GHC.Core.TyCon ( tyConArity ) -import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc ) -import GHC.Core.Predicate ( isDictTy, isCallStackPredTy ) -import GHC.Core.Multiplicity - --- We have two sorts of substitution: --- GHC.Core.Subst.Subst, and GHC.Core.TyCo.TCvSubst --- Both have substTy, substCo Hence need for qualification -import GHC.Core.Subst as Core -import GHC.Core.Type as Type -import GHC.Core.Coercion as Type - -import GHC.Types.Demand -import GHC.Types.Var -import GHC.Types.Var.Env -import GHC.Types.Id -import GHC.Types.Basic -import GHC.Types.Tickish - -import GHC.Builtin.Uniques -import GHC.Data.FastString -import GHC.Data.Pair - -import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Trace -import GHC.Utils.Misc - -{- -************************************************************************ -* * - manifestArity and exprArity -* * -************************************************************************ - -exprArity is a cheap-and-cheerful version of exprEtaExpandArity. -It tells how many things the expression can be applied to before doing -any work. It doesn't look inside cases, lets, etc. The idea is that -exprEtaExpandArity will do the hard work, leaving something that's easy -for exprArity to grapple with. In particular, Simplify uses exprArity to -compute the ArityInfo for the Id. - -Originally I thought that it was enough just to look for top-level lambdas, but -it isn't. I've seen this - - foo = PrelBase.timesInt - -We want foo to get arity 2 even though the eta-expander will leave it -unchanged, in the expectation that it'll be inlined. But occasionally it -isn't, because foo is blacklisted (used in a rule). - -Similarly, see the ok_note check in exprEtaExpandArity. So - f = __inline_me (\x -> e) -won't be eta-expanded. - -And in any case it seems more robust to have exprArity be a bit more intelligent. -But note that (\x y z -> f x y z) -should have arity 3, regardless of f's arity. --} - -manifestArity :: CoreExpr -> Arity --- ^ manifestArity sees how many leading value lambdas there are, --- after looking through casts -manifestArity (Lam v e) | isId v = 1 + manifestArity e - | otherwise = manifestArity e -manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e -manifestArity (Cast e _) = manifestArity e -manifestArity _ = 0 - -joinRhsArity :: CoreExpr -> JoinArity --- Join points are supposed to have manifestly-visible --- lambdas at the top: no ticks, no casts, nothing --- Moreover, type lambdas count in JoinArity -joinRhsArity (Lam _ e) = 1 + joinRhsArity e -joinRhsArity _ = 0 - - ---------------- -exprArity :: CoreExpr -> Arity --- ^ An approximate, fast, version of 'exprEtaExpandArity' -exprArity e = go e - where - go (Var v) = idArity v - go (Lam x e) | isId x = go e + 1 - | otherwise = go e - go (Tick t e) | not (tickishIsCode t) = go e - go (Cast e co) = trim_arity (go e) (coercionRKind co) - -- See Note [exprArity invariant] - go (App e (Type _)) = go e - go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 - -- See Note [exprArity for applications] - -- NB: coercions count as a value argument - - go _ = 0 - - trim_arity :: Arity -> Type -> Arity - trim_arity arity ty = arity `min` length (typeArity ty) - ---------------- -typeArity :: Type -> [OneShotInfo] --- How many value arrows are visible in the type? --- We look through foralls, and newtypes --- See Note [exprArity invariant] -typeArity ty - = go initRecTc ty - where - go rec_nts ty - | Just (_, ty') <- splitForAllTyCoVar_maybe ty - = go rec_nts ty' - - | Just (_,arg,res) <- splitFunTy_maybe ty - = typeOneShot arg : go rec_nts res - - | Just (tc,tys) <- splitTyConApp_maybe ty - , Just (ty', _) <- instNewTyCon_maybe tc tys - , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes and products] - -- in GHC.Core.TyCon --- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes --- -- See Note [Newtype classes and eta expansion] --- (no longer required) - = go rec_nts' ty' - -- Important to look through non-recursive newtypes, so that, eg - -- (f x) where f has arity 2, f :: Int -> IO () - -- Here we want to get arity 1 for the result! - -- - -- AND through a layer of recursive newtypes - -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) - - | otherwise - = [] - ---------------- -exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig) --- A cheap and cheerful function that identifies bottoming functions --- and gives them a suitable strictness signatures. It's used during --- float-out -exprBotStrictness_maybe e - = case getBotArity (arityType botStrictnessArityEnv e) of - Nothing -> Nothing - Just ar -> Just (ar, sig ar) - where - sig ar = mkClosedDmdSig (replicate ar topDmd) botDiv - -{- -Note [exprArity invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -exprArity has the following invariants: - - (1) If typeArity (exprType e) = n, - then manifestArity (etaExpand e n) = n - - That is, etaExpand can always expand as much as typeArity says - So the case analysis in etaExpand and in typeArity must match - - (2) exprArity e <= typeArity (exprType e) - - (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n - - That is, if exprArity says "the arity is n" then etaExpand really - can get "n" manifest lambdas to the top. - -Why is this important? Because - - In GHC.Iface.Tidy we use exprArity to fix the *final arity* of - each top-level Id, and in - - In CorePrep we use etaExpand on each rhs, so that the visible lambdas - actually match that arity, which in turn means - that the StgRhs has the right number of lambdas - -An alternative would be to do the eta-expansion in GHC.Iface.Tidy, at least -for top-level bindings, in which case we would not need the trim_arity -in exprArity. That is a less local change, so I'm going to leave it for today! - -Note [Newtype classes and eta expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - NB: this nasty special case is no longer required, because - for newtype classes we don't use the class-op rule mechanism - at all. See Note [Single-method classes] in GHC.Tc.TyCl.Instance. SLPJ May 2013 - --------- Old out of date comments, just for interest ----------- -We have to be careful when eta-expanding through newtypes. In general -it's a good idea, but annoyingly it interacts badly with the class-op -rule mechanism. Consider - - class C a where { op :: a -> a } - instance C b => C [b] where - op x = ... - -These translate to - - co :: forall a. (a->a) ~ C a - - $copList :: C b -> [b] -> [b] - $copList d x = ... - - $dfList :: C b -> C [b] - {-# DFunUnfolding = [$copList] #-} - $dfList d = $copList d |> co@[b] - -Now suppose we have: - - dCInt :: C Int - - blah :: [Int] -> [Int] - blah = op ($dfList dCInt) - -Now we want the built-in op/$dfList rule will fire to give - blah = $copList dCInt - -But with eta-expansion 'blah' might (and in #3772, which is -slightly more complicated, does) turn into - - blah = op (\eta. ($dfList dCInt |> sym co) eta) - -and now it is *much* harder for the op/$dfList rule to fire, because -exprIsConApp_maybe won't hold of the argument to op. I considered -trying to *make* it hold, but it's tricky and I gave up. - -The test simplCore/should_compile/T3722 is an excellent example. --------- End of old out of date comments, just for interest ----------- - - -Note [exprArity for applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we come to an application we check that the arg is trivial. - eg f (fac x) does not have arity 2, - even if f has arity 3! - -* We require that is trivial rather merely cheap. Suppose f has arity 2. - Then f (Just y) - has arity 0, because if we gave it arity 1 and then inlined f we'd get - let v = Just y in \w. - which has arity 0. And we try to maintain the invariant that we don't - have arity decreases. - -* The `max 0` is important! (\x y -> f x) has arity 2, even if f is - unknown, hence arity 0 - - -************************************************************************ -* * - Computing the "arity" of an expression -* * -************************************************************************ - -Note [Definition of arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -The "arity" of an expression 'e' is n if - applying 'e' to *fewer* than n *value* arguments - converges rapidly - -Or, to put it another way - - there is no work lost in duplicating the partial - application (e x1 .. x(n-1)) - -In the divergent case, no work is lost by duplicating because if the thing -is evaluated once, that's the end of the program. - -Or, to put it another way, in any context C - - C[ (\x1 .. xn. e x1 .. xn) ] - is as efficient as - C[ e ] - -It's all a bit more subtle than it looks: - -Note [One-shot lambdas] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider one-shot lambdas - let x = expensive in \y z -> E -We want this to have arity 1 if the \y-abstraction is a 1-shot lambda. - -Note [Dealing with bottom] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -A Big Deal with computing arities is expressions like - - f = \x -> case x of - True -> \s -> e1 - False -> \s -> e2 - -This happens all the time when f :: Bool -> IO () -In this case we do eta-expand, in order to get that \s to the -top, and give f arity 2. - -This isn't really right in the presence of seq. Consider - (f bot) `seq` 1 - -This should diverge! But if we eta-expand, it won't. We ignore this -"problem" (unless -fpedantic-bottoms is on), because being scrupulous -would lose an important transformation for many programs. (See -#5587 for an example.) - -Consider also - f = \x -> error "foo" -Here, arity 1 is fine. But if it is - f = \x -> case x of - True -> error "foo" - False -> \y -> x+y -then we want to get arity 2. Technically, this isn't quite right, because - (f True) `seq` 1 -should diverge, but it'll converge if we eta-expand f. Nevertheless, we -do so; it improves some programs significantly, and increasing convergence -isn't a bad thing. Hence the ABot/ATop in ArityType. - -So these two transformations aren't always the Right Thing, and we -have several tickets reporting unexpected behaviour resulting from -this transformation. So we try to limit it as much as possible: - - (1) Do NOT move a lambda outside a known-bottom case expression - case undefined of { (a,b) -> \y -> e } - This showed up in #5557 - - (2) Do NOT move a lambda outside a case unless - (a) The scrutinee is ok-for-speculation, or - (b) more liberally: the scrutinee is cheap (e.g. a variable), and - -fpedantic-bottoms is not enforced (see #2915 for an example) - -Of course both (1) and (2) are readily defeated by disguising the bottoms. - -4. 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 - - newtype T = MkT ([T] -> Int) - -Suppose we have - e = coerce T f -where f has arity 1. Then: etaExpandArity e = 1; -that is, etaExpandArity looks through the coerce. - -When we eta-expand e to arity 1: eta_expand 1 e T -we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x) - - HOWEVER, note that if you use coerce bogusly you can ge - coerce Int negate - And since negate has arity 2, you might try to eta expand. But you can't - decompose Int to a function type. Hence the final case in eta_expand. - -Note [The state-transformer hack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - f = e -where e has arity n. Then, if we know from the context that f has -a usage type like - t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ... -then we can expand the arity to m. This usage type says that -any application (x e1 .. en) will be applied to uniquely to (m-n) more args -Consider f = \x. let y = - in case x of - True -> foo - False -> \(s:RealWorld) -> e -where foo has arity 1. Then we want the state hack to -apply to foo too, so we can eta expand the case. - -Then we expect that if f is applied to one arg, it'll be applied to two -(that's the hack -- we don't really know, and sometimes it's false) -See also Id.isOneShotBndr. - -Note [State hack and bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's a terrible idea to use the state hack on a bottoming function. -Here's what happens (#2861): - - f :: String -> IO T - f = \p. error "..." - -Eta-expand, using the state hack: - - f = \p. (\s. ((error "...") |> g1) s) |> g2 - g1 :: IO T ~ (S -> (S,T)) - g2 :: (S -> (S,T)) ~ IO T - -Extrude the g2 - - f' = \p. \s. ((error "...") |> g1) s - f = f' |> (String -> g2) - -Discard args for bottomming function - - f' = \p. \s. ((error "...") |> g1 |> g3 - g3 :: (S -> (S,T)) ~ (S,T) - -Extrude g1.g3 - - f'' = \p. \s. (error "...") - f' = f'' |> (String -> S -> g1.g3) - -And now we can repeat the whole loop. Aargh! The bug is in applying the -state hack to a function which then swallows the argument. - -This arose in another guise in #3959. Here we had - - catch# (throw exn >> return ()) - -Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()]. -After inlining (>>) we get - - catch# (\_. throw {IO ()} exn) - -We must *not* eta-expand to - - catch# (\_ _. throw {...} exn) - -because 'catch#' expects to get a (# _,_ #) after applying its argument to -a State#, not another function! - -In short, we use the state hack to allow us to push let inside a lambda, -but not to introduce a new lambda. - - -Note [ArityType] -~~~~~~~~~~~~~~~~ -ArityType is the result of a compositional analysis on expressions, -from which we can decide the real arity of the expression (extracted -with function exprEtaExpandArity). - -We use the following notation: - at ::= \o1..on.div - div ::= T | x | ⊥ - o ::= ? | 1 -And omit the \. if n = 0. Examples: - \?11.T stands for @AT [NoOneShotInfo,OneShotLam,OneShotLam] topDiv@ - ⊥ stands for @AT [] botDiv@ -See the 'Outputable' instance for more information. It's pretty simple. - -Here is what the fields mean. If an arbitrary expression 'f' has -ArityType 'at', then - - * If @at = AT [o1,..,on] botDiv@ (notation: \o1..on.⊥), then @f x1..xn@ - definitely diverges. Partial applications to fewer than n args may *or - may not* diverge. - - We allow ourselves to eta-expand bottoming functions, even - if doing so may lose some `seq` sharing, - let x = in \y. error (g x y) - ==> \y. let x = in error (g x y) - - * If @at = AT [o1,..,on] topDiv@ (notation: \o1..on.T), then expanding 'f' - to @\x1..xn. f x1..xn@ loses no sharing, assuming the calls of f respect - the one-shot-ness o1..on of its definition. - - NB 'f' is an arbitrary expression, eg @f = g e1 e2@. This 'f' can have - arity type @AT oss _@, with @length oss > 0@, only if e1 e2 are themselves - cheap. - - * In both cases, @f@, @f x1@, ... @f x1 ... x(n-1)@ are definitely - really functions, or bottom, but *not* casts from a data type, in - at least one case branch. (If it's a function in one case branch but - an unsafe cast from a data type in another, the program is bogus.) - So eta expansion is dynamically ok; see Note [State hack and - bottoming functions], the part about catch# - -Example: - f = \x\y. let v = in - \s(one-shot) \t(one-shot). blah - 'f' has arity type \??11.T - The one-shot-ness means we can, in effect, push that - 'let' inside the \st. - - -Suppose f = \xy. x+y -Then f :: \??.T - f v :: \?.T - f :: T - - - -Note [Eta reduction in recursive RHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider the following recursive function: - f = \x. ....g (\y. f y).... -The recursive call of f in its own RHS seems like a fine opportunity for -eta-reduction because f has arity 1. And often it is! - -Alas, that is unsound in general if the eta-reduction happens in a tail context. -Making the arity visible in the RHS allows us to eta-reduce - f = \x -> f x -to - f = f -which means we optimise terminating programs like (f `seq` ()) into -non-terminating ones. Nor is this problem just for tail calls. Consider - f = id (\x -> f x) -where we have (for some reason) not yet inlined `id`. We must not eta-reduce to - f = id f -because that will then simplify to `f = f` as before. - -An immediate idea might be to look at whether the called function is a local -loopbreaker and refrain from eta-expanding. But that doesn't work for mutually -recursive function like in #21652: - f = g - g* x = f x -Here, g* is the loopbreaker but f isn't. - -What can we do? - -Fix 1: Zap `idArity` when analysing recursive RHSs and re-attach the info when - entering the let body. - Has the disadvantage that other transformations which make use of arity - (such as dropping of `seq`s when arity > 0) will no longer work in the RHS. - Plus it requires non-trivial refactorings to both the simple optimiser (in - the way `subst_opt_bndr` is used) as well as the Simplifier (in the way - `simplRecBndrs` and `simplRecJoinBndrs` is used), modifying the SimplEnv's - substitution twice in the process. A very complicated stop-gap. - -Fix 2: Pass the set of enclosing recursive binders to `tryEtaReduce`; these are - the ones we should not eta-reduce. All call-site must maintain this set. - Example: - rec { f1 = ....rec { g = ... (\x. g x)...(\y. f2 y)... }... - ; f2 = ...f1... } - when eta-reducing those inner lambdas, we need to know that we are in the - rec group for {f1, f2, g}. - This is very much like the solution in Note [Speculative evaluation] in - GHC.CoreToStg.Prep. - It is a bit tiresome to maintain this info, because it means another field - in SimplEnv and SimpleOptEnv. - -We implement Fix (2) because of it isn't as complicated to maintain as (1). -Plus, it is the correct fix to begin with. After all, the arity is correct, -but doing the transformation isn't. The moving parts are: - * A field `scRecIds` in `SimplEnv` tracks the enclosing recursive binders - * We extend the `scRecIds` set in `GHC.Core.Opt.Simplify.simplRecBind` - * We consult the set in `is_eta_reduction_sound` in `tryEtaReduce` -The situation is very similar to Note [Speculative evaluation] which has the -same fix. - --} - - --- | The analysis lattice of arity analysis. It is isomorphic to --- --- @ --- data ArityType' --- = AEnd Divergence --- | ALam OneShotInfo ArityType' --- @ --- --- Which is easier to display the Hasse diagram for: --- --- @ --- ALam OneShotLam at --- | --- AEnd topDiv --- | --- ALam NoOneShotInfo at --- | --- AEnd exnDiv --- | --- AEnd botDiv --- @ --- --- where the @at@ fields of @ALam@ are inductively subject to the same order. --- That is, @ALam os at1 < ALam os at2@ iff @at1 < at2@. --- --- Why the strange Top element? --- See Note [Combining case branches: optimistic one-shot-ness] --- --- We rely on this lattice structure for fixed-point iteration in --- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType]. -data ArityType - = AT ![OneShotInfo] !Divergence - -- ^ @AT oss div@ means this value can safely be eta-expanded @length oss@ - -- times, provided use sites respect the 'OneShotInfo's in @oss@. - -- A 'OneShotLam' annotation can come from two sources: - -- * The user annotated a lambda as one-shot with 'GHC.Exts.oneShot' - -- * It's from a lambda binder of a type affected by `-fstate-hack`. - -- See 'idStateHackOneShotInfo'. - -- In both cases, 'OneShotLam' should win over 'NoOneShotInfo', see - -- Note [Combining case branches]. - -- - -- If @div@ is dead-ending ('isDeadEndDiv'), then application to - -- @length os@ arguments will surely diverge, similar to the situation - -- with 'DmdType'. - deriving Eq - --- | This is the BNF of the generated output: --- --- @ --- @ --- --- We format --- @AT [o1,..,on] topDiv@ as @\o1..on.T@ and --- @AT [o1,..,on] botDiv@ as @\o1..on.⊥@, respectively. --- More concretely, @AT [NOI,OS,OS] topDiv@ is formatted as @\?11.T@. --- If the one-shot info is empty, we omit the leading @\.@. -instance Outputable ArityType where - ppr (AT oss div) - | null oss = pp_div div - | otherwise = char '\\' <> hcat (map pp_os oss) <> dot <> pp_div div - where - pp_div Diverges = char '⊥' - pp_div ExnOrDiv = char 'x' - pp_div Dunno = char 'T' - pp_os OneShotLam = char '1' - pp_os NoOneShotInfo = char '?' - -mkBotArityType :: [OneShotInfo] -> ArityType -mkBotArityType oss = AT oss botDiv - -botArityType :: ArityType -botArityType = mkBotArityType [] - -mkManifestArityType :: [Var] -> CoreExpr -> ArityType -mkManifestArityType bndrs body - = AT oss div - where - oss = [idOneShotInfo bndr | bndr <- bndrs, isId bndr] - div | exprIsDeadEnd body = botDiv - | otherwise = topDiv - -topArityType :: ArityType -topArityType = AT [] topDiv - --- | The number of value args for the arity type -arityTypeArity :: ArityType -> Arity -arityTypeArity (AT oss _) = length oss - --- | True <=> eta-expansion will add at least one lambda -expandableArityType :: ArityType -> Bool -expandableArityType at = arityTypeArity at > 0 - --- | See Note [Dead ends] in "GHC.Types.Demand". --- Bottom implies a dead end. -isDeadEndArityType :: ArityType -> Bool -isDeadEndArityType (AT _ div) = isDeadEndDiv div - --- | Expand a non-bottoming arity type so that it has at least the given arity. -maxWithArity :: ArityType -> Arity -> ArityType -maxWithArity at@(AT oss div) !ar - | isDeadEndArityType at = at - | oss `lengthAtLeast` ar = at - | otherwise = AT (take ar $ oss ++ repeat NoOneShotInfo) div - --- | Trim an arity type so that it has at most the given arity. --- Any excess 'OneShotInfo's are truncated to 'topDiv', even if they end in --- 'ABot'. -minWithArity :: ArityType -> Arity -> ArityType -minWithArity at@(AT oss _) ar - | oss `lengthAtMost` ar = at - | otherwise = AT (take ar oss) topDiv - -takeWhileOneShot :: ArityType -> ArityType -takeWhileOneShot (AT oss div) - | isDeadEndDiv div = AT (takeWhile isOneShotInfo oss) topDiv - | otherwise = AT (takeWhile isOneShotInfo oss) div - --- | The Arity returned is the number of value args the --- expression can be applied to without doing much work -exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType --- exprEtaExpandArity is used when eta expanding --- e ==> \xy -> e x y -exprEtaExpandArity dflags e = arityType (findRhsArityEnv dflags) e - -getBotArity :: ArityType -> Maybe Arity --- Arity of a divergent function -getBotArity (AT oss div) - | isDeadEndDiv div = Just $ length oss - | otherwise = Nothing - ----------------------- -findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType --- This implements the fixpoint loop for arity analysis --- See Note [Arity analysis] --- If findRhsArity e = (n, is_bot) then --- (a) any application of e to (\x1..xn. e x1 .. xn) --- (b) if is_bot=True, then e applied to n args is guaranteed bottom -findRhsArity dflags bndr rhs old_arity - = go 0 botArityType - -- We always do one step, but usually that produces a result equal to - -- old_arity, and then we stop right away, because old_arity is assumed - -- to be sound. In other words, arities should never decrease. - -- Result: the common case is that there is just one iteration - where - go :: Int -> ArityType -> ArityType - go !n cur_at@(AT oss div) - | not (isDeadEndDiv div) -- the "stop right away" case - , length oss <= old_arity = cur_at -- from above - | next_at == cur_at = cur_at - | otherwise = - -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity] - warnPprTrace (debugIsOn && n > 2) - "Exciting arity" - (nest 2 (ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $ - go (n+1) next_at - where - next_at = step cur_at - - step :: ArityType -> ArityType - step at = -- pprTrace "step" (ppr bndr <+> ppr at <+> ppr (arityType env rhs)) $ - arityType env rhs - where - env = extendSigEnv (findRhsArityEnv dflags) bndr at - - -{- -Note [Arity analysis] -~~~~~~~~~~~~~~~~~~~~~ -The motivating example for arity analysis is this: - - f = \x. let g = f (x+1) - in \y. ...g... - -What arity does f have? Really it should have arity 2, but a naive -look at the RHS won't see that. You need a fixpoint analysis which -says it has arity "infinity" the first time round. - -This example happens a lot; it first showed up in Andy Gill's thesis, -fifteen years ago! It also shows up in the code for 'rnf' on lists -in #4138. - -We do the necessary, quite simple fixed-point iteration in 'findRhsArity', -which assumes for a single binding 'ABot' on the first run and iterates -until it finds a stable arity type. Two wrinkles - -* We often have to ask (see the Case or Let case of 'arityType') whether some - expression is cheap. In the case of an application, that depends on the arity - of the application head! That's why we have our own version of 'exprIsCheap', - 'myExprIsCheap', that will integrate the optimistic arity types we have on - f and g into the cheapness check. - -* Consider this (#18793) - - go = \ds. case ds of - [] -> id - (x:ys) -> let acc = go ys in - case blah of - True -> acc - False -> \ x1 -> acc (negate x1) - - We must propagate go's optimistically large arity to @acc@, so that the - tail call to @acc@ in the True branch has sufficient arity. This is done - by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case - of 'arityType'. - -Note [Exciting arity] -~~~~~~~~~~~~~~~~~~~~~ -The fixed-point iteration in 'findRhsArity' stabilises very quickly in almost -all cases. To get notified of cases where we need an usual number of iterations, -we emit a warning in debug mode, so that we can investigate and make sure that -we really can't do better. It's a gross hack, but catches real bugs (#18870). - -Now, which number is "unusual"? We pick n > 2. Here's a pretty common and -expected example that takes two iterations and would ruin the specificity -of the warning (from T18937): - - f :: [Int] -> Int -> Int - f [] = id - f (x:xs) = let y = sum [0..x] - in \z -> f xs (y + z) - -Fixed-point iteration starts with arity type ⊥ for f. After the first -iteration, we get arity type \??.T, e.g. arity 2, because we unconditionally -'floatIn' the let-binding (see its bottom case). After the second iteration, -we get arity type \?.T, e.g. arity 1, because now we are no longer allowed -to floatIn the non-cheap let-binding. Which is all perfectly benign, but -means we do two iterations (well, actually 3 'step's to detect we are stable) -and don't want to emit the warning. - -Note [Eta expanding through dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If the experimental -fdicts-cheap flag is on, we eta-expand through -dictionary bindings. This improves arities. Thereby, it also -means that full laziness is less prone to floating out the -application of a function to its dictionary arguments, which -can thereby lose opportunities for fusion. Example: - foo :: Ord a => a -> ... - foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... - -- So foo has arity 1 - - f = \x. foo dInt $ bar x - -The (foo DInt) is floated out, and makes ineffective a RULE - foo (bar x) = ... - -One could go further and make exprIsCheap reply True to any -dictionary-typed expression, but that's more work. --} - -arityLam :: Id -> ArityType -> ArityType -arityLam id (AT oss div) = AT (idStateHackOneShotInfo id : oss) div - -floatIn :: Bool -> ArityType -> ArityType --- We have something like (let x = E in b), --- where b has the given arity type. -floatIn cheap at - | isDeadEndArityType at || cheap = at - -- If E is not cheap, keep arity only for one-shots - | otherwise = takeWhileOneShot at - -arityApp :: ArityType -> Bool -> ArityType - --- Processing (fun arg) where at is the ArityType of fun, --- Knock off an argument and behave like 'let' -arityApp (AT (_:oss) div) cheap = floatIn cheap (AT oss div) -arityApp at _ = at - --- | Least upper bound in the 'ArityType' lattice. --- See the haddocks on 'ArityType' for the lattice. --- --- Used for branches of a @case@. -andArityType :: ArityEnv -> ArityType -> ArityType -> ArityType -andArityType env (AT (lam1:lams1) div1) (AT (lam2:lams2) div2) - | AT lams' div' <- andArityType env (AT lams1 div1) (AT lams2 div2) - = AT ((lam1 `and_lam` lam2) : lams') div' - where - (os1) `and_lam` (os2) - = ( os1 `bestOneShot` os2) - -- bestOneShot: see Note [Combining case branches: optimistic one-shot-ness] - -andArityType env (AT [] div1) at2 = andWithTail env div1 at2 -andArityType env at1 (AT [] div2) = andWithTail env div2 at1 - -andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType -andWithTail env div1 at2 - | isDeadEndDiv div1 -- case x of { T -> error; F -> \y.e } - = at2 -- Note [ABot branches: max arity wins] - - | pedanticBottoms env -- Note [Combining case branches: andWithTail] - = AT [] topDiv - - | otherwise -- case x of { T -> plusInt ; F -> \y.e } - = takeWhileOneShot at2 -- We know div1 = topDiv - -- See Note [Combining case branches: andWithTail] - - -{- Note [ABot branches: max arity wins] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider case x of - True -> \x. error "urk" - False -> \xy. error "urk2" - -Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely diverge". -So we need \??.⊥ for the whole thing, the /max/ of both arities. - -Note [Combining case branches: optimistic one-shot-ness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When combining the ArityTypes for two case branches (with andArityType) -and both ArityTypes have ATLamInfo, then we just combine their -expensive-ness and one-shot info. The tricky point is when we have - case x of True -> \x{one-shot). blah1 - Fale -> \y. blah2 - -Since one-shot-ness is about the /consumer/ not the /producer/, we -optimistically assume that if either branch is one-shot, we combine -the best of the two branches, on the (slightly dodgy) basis that if we -know one branch is one-shot, then they all must be. Surprisingly, -this means that the one-shot arity type is effectively the top element -of the lattice. - -Hence the call to `bestOneShot` in `andArityType`. - -Note [Combining case branches: andWithTail] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When combining the ArityTypes for two case branches (with andArityType) -and one side or the other has run out of ATLamInfo; then we get -into `andWithTail`. - -* If one branch is guaranteed bottom (isDeadEndDiv), we just take - the other; see Note [ABot branches: max arity wins] - -* Otherwise, if pedantic-bottoms is on, we just have to return - AT [] topDiv. E.g. if we have - f x z = case x of True -> \y. blah - False -> z - then we can't eta-expand, because that would change the behaviour - of (f False bottom(). - -* But if pedantic-bottoms is not on, we allow ourselves to push - `z` under a lambda (much as we allow ourselves to put the `case x` - under a lambda). However we know nothing about the expensiveness - or one-shot-ness of `z`, so we'd better assume it looks like - (Expensive, NoOneShotInfo) all the way. Remembering - Note [Combining case branches: optimistic one-shot-ness], - we just add work to ever ATLamInfo, keeping the one-shot-ness. - -Here's an example: - go = \x. let z = go e0 - go2 = \x. case x of - True -> z - False -> \s(one-shot). e1 - in go2 x -We *really* want to respect the one-shot annotation provided by the -user and eta-expand go and go2. -When combining the branches of the case we have - T `andAT` \1.T -and we want to get \1.T. -But if the inner lambda wasn't one-shot (\?.T) we don't want to do this. -(We need a usage analysis to justify that.) - -Unless we can conclude that **all** branches are safe to eta-expand then we -must pessimisticaly conclude that we can't eta-expand. See #21694 for where this -went wrong. -We can do better in the long run, but for the 9.4/9.2 branches we choose to simply -ignore oneshot annotations for the time being. - - -Note [Arity trimming] -~~~~~~~~~~~~~~~~~~~~~ -Consider ((\x y. blah) |> co), where co :: (Int->Int->Int) ~ (Int -> F a) , and -F is some type family. - -Because of Note [exprArity invariant], item (2), we must return with arity at -most 1, because typeArity (Int -> F a) = 1. So we have to trim the result of -calling arityType on (\x y. blah). Failing to do so, and hence breaking the -exprArity invariant, led to #5441. - -How to trim? If we end in topDiv, it's easy. But we must take great care with -dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"), -we'll get \??.⊥. We absolutely must not trim that to \?.⊥, because that -claims that ((\x y. error "urk") |> co) diverges when given one argument, -which it absolutely does not. And Bad Things happen if we think something -returns bottom when it doesn't (#16066). - -So, if we need to trim a dead-ending arity type, switch (conservatively) to -topDiv. - -Historical note: long ago, we unconditionally switched to topDiv when we -encountered a cast, but that is far too conservative: see #5475 - -Note [Eta expanding through CallStacks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Just as it's good to eta-expand through dictionaries, so it is good to -do so through CallStacks. #20103 is a case in point, where we got - foo :: HasCallStack => Int -> Int - foo = \(d::CallStack). let d2 = pushCallStack blah d in - \(x:Int). blah - -We really want to eta-expand this! #20103 is quite convincing! -We do this regardless of -fdicts-cheap; it's not really a dictionary. --} - ---------------------------- - --- | Each of the entry-points of the analyser ('arityType') has different --- requirements. The entry-points are --- --- 1. 'exprBotStrictness_maybe' --- 2. 'exprEtaExpandArity' --- 3. 'findRhsArity' --- --- For each of the entry-points, there is a separate mode that governs --- --- 1. How pedantic we are wrt. ⊥, in 'pedanticBottoms'. --- 2. Whether we store arity signatures for non-recursive let-bindings, --- accessed in 'extendSigEnv'/'lookupSigEnv'. --- See Note [Arity analysis] why that's important. --- 3. Which expressions we consider cheap to float inside a lambda, --- in 'myExprIsCheap'. -data AnalysisMode - = BotStrictness - -- ^ Used during 'exprBotStrictness_maybe'. - | EtaExpandArity { am_ped_bot :: !Bool - , am_dicts_cheap :: !Bool } - -- ^ Used for finding an expression's eta-expanding arity quickly, without - -- fixed-point iteration ('exprEtaExpandArity'). - | FindRhsArity { am_ped_bot :: !Bool - , am_dicts_cheap :: !Bool - , am_sigs :: !(IdEnv ArityType) } - -- ^ Used for regular, fixed-point arity analysis ('findRhsArity'). - -- See Note [Arity analysis] for details about fixed-point iteration. - -- INVARIANT: Disjoint with 'ae_joins'. - -data ArityEnv - = AE - { ae_mode :: !AnalysisMode - -- ^ The analysis mode. See 'AnalysisMode'. - } - --- | The @ArityEnv@ used by 'exprBotStrictness_maybe'. Pedantic about bottoms --- and no application is ever considered cheap. -botStrictnessArityEnv :: ArityEnv -botStrictnessArityEnv = AE { ae_mode = BotStrictness } - -{- --- | The @ArityEnv@ used by 'exprEtaExpandArity'. -etaExpandArityEnv :: DynFlags -> ArityEnv -etaExpandArityEnv dflags - = AE { ae_mode = EtaExpandArity { am_ped_bot = gopt Opt_PedanticBottoms dflags - , am_dicts_cheap = gopt Opt_DictsCheap dflags } - , ae_joins = emptyVarSet } --} - --- | The @ArityEnv@ used by 'findRhsArity'. -findRhsArityEnv :: DynFlags -> ArityEnv -findRhsArityEnv dflags - = AE { ae_mode = FindRhsArity { am_ped_bot = gopt Opt_PedanticBottoms dflags - , am_dicts_cheap = gopt Opt_DictsCheap dflags - , am_sigs = emptyVarEnv } - } - -isFindRhsArity :: ArityEnv -> Bool -isFindRhsArity (AE { ae_mode = FindRhsArity {} }) = True -isFindRhsArity _ = False - --- First some internal functions in snake_case for deleting in certain VarEnvs --- of the ArityType. Don't call these; call delInScope* instead! - -modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv -modifySigEnv f env@AE { ae_mode = am@FindRhsArity{am_sigs = sigs} } = - env { ae_mode = am { am_sigs = f sigs } } -modifySigEnv _ env = env -{-# INLINE modifySigEnv #-} - -del_sig_env :: Id -> ArityEnv -> ArityEnv -- internal! -del_sig_env id = modifySigEnv (\sigs -> delVarEnv sigs id) -{-# INLINE del_sig_env #-} - -del_sig_env_list :: [Id] -> ArityEnv -> ArityEnv -- internal! -del_sig_env_list ids = modifySigEnv (\sigs -> delVarEnvList sigs ids) -{-# INLINE del_sig_env_list #-} - --- end of internal deletion functions - -extendSigEnv :: ArityEnv -> Id -> ArityType -> ArityEnv -extendSigEnv env id ar_ty - = modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) env - -delInScope :: ArityEnv -> Id -> ArityEnv -delInScope env id = del_sig_env id env - -delInScopeList :: ArityEnv -> [Id] -> ArityEnv -delInScopeList env ids = del_sig_env_list ids env - -lookupSigEnv :: ArityEnv -> Id -> Maybe ArityType -lookupSigEnv AE{ ae_mode = mode } id = case mode of - BotStrictness -> Nothing - EtaExpandArity{} -> Nothing - FindRhsArity{ am_sigs = sigs } -> lookupVarEnv sigs id - --- | Whether the analysis should be pedantic about bottoms. --- 'exprBotStrictness_maybe' always is. -pedanticBottoms :: ArityEnv -> Bool -pedanticBottoms AE{ ae_mode = mode } = case mode of - BotStrictness -> True - EtaExpandArity{ am_ped_bot = ped_bot } -> ped_bot - FindRhsArity{ am_ped_bot = ped_bot } -> ped_bot - --- | A version of 'exprIsCheap' that considers results from arity analysis --- and optionally the expression's type. --- Under 'exprBotStrictness_maybe', no expressions are cheap. -myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool -myExprIsCheap AE{ae_mode = mode} e mb_ty = case mode of - BotStrictness -> False - _ -> cheap_dict || cheap_fun e - where - cheap_dict = case mb_ty of - Nothing -> False - Just ty -> (am_dicts_cheap mode && isDictTy ty) - || isCallStackPredTy ty - -- See Note [Eta expanding through dictionaries] - -- See Note [Eta expanding through CallStacks] - - cheap_fun e = case mode of -#if __GLASGOW_HASKELL__ <= 900 - BotStrictness -> panic "impossible" -#endif - EtaExpandArity{} -> exprIsCheap e - FindRhsArity{am_sigs = sigs} -> exprIsCheapX (myIsCheapApp sigs) e - --- | A version of 'isCheapApp' that considers results from arity analysis. --- See Note [Arity analysis] for what's in the signature environment and why --- it's important. -myIsCheapApp :: IdEnv ArityType -> CheapAppFun -myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of - -- Nothing means not a local function, fall back to regular - -- 'GHC.Core.Utils.isCheapApp' - Nothing -> isCheapApp fn n_val_args - - -- `Just at` means local function with `at` as current SafeArityType. - -- NB the SafeArityType bit: that means we can ignore the cost flags - -- in 'lams', and just consider the length - -- Roughly approximate what 'isCheapApp' is doing. - Just (AT oss div) - | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils - | n_val_args < length oss -> True -- Essentially isWorkFreeApp - | otherwise -> False - ----------------- -arityType :: HasDebugCallStack => ArityEnv -> CoreExpr -> ArityType --- Precondition: all the free join points of the expression --- are bound by the ArityEnv --- See Note [No free join points in arityType] - -arityType env (Cast e co) - = minWithArity (arityType env e) co_arity -- See Note [Arity trimming] - where - co_arity = length (typeArity (coercionRKind co)) - -- See Note [exprArity invariant] (2); must be true of - -- arityType too, since that is how we compute the arity - -- of variables, and they in turn affect result of exprArity - -- #5441 is a nice demo - -arityType env (Var v) - | Just at <- lookupSigEnv env v -- Local binding - = at - | otherwise - = assertPpr (not (isFindRhsArity env && isJoinId v)) (ppr v) $ - -- All join-point should be in the ae_sigs - -- See Note [No free join points in arityType] - idArityType v - - -- Lambdas; increase arity -arityType env (Lam x e) - | isId x = arityLam x (arityType env' e) - | otherwise = arityType env' e - where - env' = delInScope env x - - -- Applications; decrease arity, except for types -arityType env (App fun (Type _)) - = arityType env fun -arityType env (App fun arg ) - = arityApp (arityType env fun) (myExprIsCheap env arg Nothing) - - -- Case/Let; keep arity if either the expression is cheap - -- or it's a 1-shot lambda - -- The former is not really right for Haskell - -- f x = case x of { (a,b) -> \y. e } - -- ===> - -- 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 - | exprOkForSpeculation scrut - = alts_type - - | otherwise -- In the remaining cases we may not push - = takeWhileOneShot 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) - -arityType env (Let (NonRec b r) e) - = -- See Note [arityType for let-bindings] - floatIn cheap_rhs (arityType env' e) - where - cheap_rhs = myExprIsCheap env r (Just (idType b)) - env' = extendSigEnv env b (arityType env r) - -arityType env (Let (Rec prs) e) - = floatIn (all is_cheap prs) (arityType env' e) - where - is_cheap (b,e) = myExprIsCheap env' e (Just (idType b)) - env' = foldl extend_rec env prs - extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv - extend_rec env (b,e) = extendSigEnv env b $ - mkManifestArityType bndrs body - where - (bndrs, body) = collectBinders e - -- We can't call arityType on the RHS, because it might mention - -- join points bound in this very letrec, and we don't want to - -- do a fixpoint calculation here. So we make do with the - -- manifest arity - -arityType env (Tick t e) - | not (tickishIsCode t) = arityType env e - -arityType _ _ = topArityType - - -{- Note [No free join points in arityType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we call arityType on this expression (EX1) - \x . case x of True -> \y. e - False -> $j 3 -where $j is a join point. It really makes no sense to talk of the arity -of this expression, because it has a free join point. In particular, we -can't eta-expand the expression because we'd have do the same thing to the -binding of $j, and we can't see that binding. - -If we had (EX2) - \x. join $j y = blah - case x of True -> \y. e - False -> $j 3 -then it would make perfect sense: we can determine $j's ArityType, and -propagate it to the usage site as usual. - -But how can we get (EX1)? It doesn't make much sense, because $j can't -be a join point under the \x anyway. So we make it a precondition of -arityType that the argument has no free join-point Ids. (This is checked -with an assesrt in the Var case of arityType.) - -BUT the invariant risks being invalidated by one very narrow special case: runRW# - join $j y = blah - runRW# (\s. case x of True -> \y. e - False -> $j x) - -We have special magic in OccurAnal, and Simplify to allow continuations to -move into the body of a runRW# call. - -So we are careful never to attempt to eta-expand the (\s.blah) in the -argument to runRW#, at least not when there is a literal lambda there, -so that OccurAnal has seen it and allowed join points bound outside. -See Note [No eta-expansion in runRW#] in GHC.Core.Opt.Simplify.Iteration. - -Note [arityType for let-bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For non-recursive let-bindings, we just get the arityType of the RHS, -and extend the environment. That works nicely for things like this -(#18793): - go = \ ds. case ds_a2CF of { - [] -> id - : y ys -> case y of { GHC.Types.I# x -> - let acc = go ys in - case x ># 42# of { - __DEFAULT -> acc - 1# -> \x1. acc (negate x2) - -Here we want to get a good arity for `acc`, based on the ArityType -of `go`. - -All this is particularly important for join points. Consider this (#18328) - - f x = join j y = case y of - True -> \a. blah - False -> \b. blah - in case x of - A -> j True - B -> \c. blah - C -> j False - -and suppose the join point is too big to inline. Now, what is the -arity of f? If we inlined the join point, we'd definitely say "arity -2" because we are prepared to push case-scrutinisation inside a -lambda. It's important that we extend the envt with j's ArityType, -so that we can use that information in the A/C branch of the case. - -For /recursive/ bindings it's more difficult, to call arityType, -because we don't have an ArityType to put in the envt for the -recursively bound Ids. So for non-join-point bindings we satisfy -ourselves with mkManifestArityType. Typically we'll have eta-expanded -the binding (based on an earlier fixpoint calculation in -findRhsArity), so the manifest arity is good. - -But for /recursive join points/ things are not so good. -See Note [Arity type for recursive join bindings] - -See Note [Arity type for recursive join bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = joinrec j 0 = \ a b c -> (a,x,b) - j n = j (n-1) - in j 20 - -Obviously `f` should get arity 4. But the manifest arity of `j` -is 1. Remember, we don't eta-expand join points; see -GHC.Core.Opt.Simplify.Utils Note [Do not eta-expand join points]. -And the ArityInfo on `j` will be just 1 too; see GHC.Core -Note [Invariants on join points], item (2b). So using -Note [ArityType for let-bindings] won't work well. - -We could do a fixpoint iteration, but that's a heavy hammer -to use in arityType. So we take advantage of it being a join -point: - -* Extend the ArityEnv to bind each of the recursive binders - (all join points) to `botArityType`. This means that any - jump to the join point will return botArityType, which is - unit for `andArityType`: - botAritType `andArityType` at = at - So it's almost as if those "jump" branches didn't exist. - -* In this extended env, find the ArityType of each of the RHS, after - stripping off the join-point binders. - -* Use andArityType to combine all these RHS ArityTypes. - -* Find the ArityType of the body, also in this strange extended - environment - -* And combine that into the result with andArityType. - -In our example, the jump (j 20) will yield Bot, as will the jump -(j (n-1)). We'll 'and' those the ArityType of (\abc. blah). Good! - -In effect we are treating the RHSs as alternative bodies (like -in a case), and ignoring all jumps. In this way we don't need -to take a fixpoint. Tricky! - -NB: we treat /non-recursive/ join points in the same way, but -actually it works fine to treat them uniformly with normal -let-bindings, and that takes less code. --} - -idArityType :: Id -> ArityType -idArityType v - | strict_sig <- idDmdSig v - , not $ isNopSig strict_sig - , (ds, div) <- splitDmdSig strict_sig - , let arity = length ds - -- Every strictness signature admits an arity signature! - = AT (take arity one_shots) div - | otherwise - = AT (take (idArity v) one_shots) topDiv - where - one_shots :: [OneShotInfo] -- One-shot-ness derived from the type - one_shots = typeArity (idType v) - -{- -%************************************************************************ -%* * - The main eta-expander -%* * -%************************************************************************ - -We go for: - f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym - (n >= 0) - -where (in both cases) - - * The xi can include type variables - - * The yi are all value variables - - * N is a NORMAL FORM (i.e. no redexes anywhere) - wanting a suitable number of extra args. - -The biggest reason for doing this is for cases like - - f = \x -> case x of - True -> \y -> e1 - False -> \y -> e2 - -Here we want to get the lambdas together. A good example is the nofib -program fibheaps, which gets 25% more allocation if you don't do this -eta-expansion. - -We may have to sandwich some coerces between the lambdas -to make the types work. exprEtaExpandArity looks through coerces -when computing arity; and etaExpand adds the coerces as necessary when -actually computing the expansion. - -Note [No crap in eta-expanded code] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The eta expander is careful not to introduce "crap". In particular, -given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it -returns a CoreExpr satisfying the same invariant. See Note [Eta -expansion and the CorePrep invariants] in CorePrep. - -This means the eta-expander has to do a bit of on-the-fly -simplification but it's not too hard. The alternative, of relying on -a subsequent clean-up phase of the Simplifier to de-crapify the result, -means you can't really use it in CorePrep, which is painful. - -Note [Eta expansion for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The no-crap rule is very tiresome to guarantee when -we have join points. Consider eta-expanding - let j :: Int -> Int -> Bool - j x = e - in b - -The simple way is - \(y::Int). (let j x = e in b) y - -The no-crap way is - \(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 -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. - -(Moreover, I think that casts can make the no-crap rule fail too.) - -Note [Eta expansion and SCCs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Note that SCCs are not treated specially by etaExpand. If we have - etaExpand 2 (\x -> scc "foo" e) - = (\xy -> (scc "foo" e) y) -So the costs of evaluating 'e' (not 'e y') are attributed to "foo" - -Note [Eta expansion and source notes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -CorePrep puts floatable ticks outside of value applications, but not -type applications. As a result we might be trying to eta-expand an -expression like - - (src<...> v) @a - -which we want to lead to code like - - \x -> src<...> v @a x - -This means that we need to look through type applications and be ready -to re-add floats on the top. - -Note [Eta expansion with ArityType] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The etaExpandAT function takes an ArityType (not just an Arity) to -guide eta-expansion. Why? Because we want to preserve one-shot info. -Consider - foo = \x. case x of - True -> (\s{os}. blah) |> co - False -> wubble -We'll get an ArityType for foo of \?1.T. - -Then we want to eta-expand to - foo = \x. (\eta{os}. (case x of ...as before...) eta) |> some_co - -That 'eta' binder is fresh, and we really want it to have the -one-shot flag from the inner \s{os}. By expanding with the -ArityType gotten from analysing the RHS, we achieve this neatly. - -This makes a big difference to the one-shot monad trick; -see Note [The one-shot state monad trick] in GHC.Utils.Monad. --} - --- | @etaExpand n e@ returns an expression with --- the same meaning as @e@, but with arity @n@. --- --- Given: --- --- > e' = etaExpand n e --- --- We should have that: --- --- > ty = exprType e = exprType e' - -etaExpand :: Arity -> CoreExpr -> CoreExpr -etaExpand n orig_expr - = eta_expand in_scope (replicate n NoOneShotInfo) orig_expr - where - in_scope = {-#SCC "eta_expand:in-scopeX" #-} - mkInScopeSet (exprFreeVars orig_expr) - -etaExpandAT :: InScopeSet -> ArityType -> CoreExpr -> CoreExpr --- See Note [Eta expansion with ArityType] --- --- We pass in the InScopeSet from the simplifier to avoid recomputing --- it here, which can be jolly expensive if the casts are big --- In #18223 it took 10% of compile time just to do the exprFreeVars! -etaExpandAT in_scope (AT oss _) orig_expr - = eta_expand in_scope oss orig_expr - --- etaExpand arity e = res --- Then 'res' has at least 'arity' lambdas at the top --- possibly with a cast wrapped around the outside --- See Note [Eta expansion with ArityType] --- --- etaExpand deals with for-alls. For example: --- etaExpand 1 E --- where E :: forall a. a -> a --- would return --- (/\b. \y::a -> E b y) - -eta_expand :: InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr -eta_expand in_scope one_shots (Cast expr co) - = Cast (eta_expand in_scope one_shots expr) co - -eta_expand in_scope one_shots orig_expr - = go in_scope one_shots [] orig_expr - where - -- Strip off existing lambdas and casts before handing off to mkEtaWW - -- This is mainly to avoid spending time cloning binders and substituting - -- when there is actually nothing to do. It's slightly awkward to deal - -- with casts here, apart from the topmost one, and they are rare, so - -- if we find one we just hand off to mkEtaWW anyway - -- Note [Eta expansion and SCCs] - go _ [] _ _ = orig_expr -- Already has the specified arity; no-op - - go in_scope oss@(_:oss1) vs (Lam v body) - | isTyVar v = go (in_scope `extendInScopeSet` v) oss (v:vs) body - | otherwise = go (in_scope `extendInScopeSet` v) oss1 (v:vs) body - - go in_scope oss rev_vs expr - = -- pprTrace "ee" (vcat [ppr in_scope', ppr top_bndrs, ppr eis]) $ - retick $ - etaInfoAbs top_eis $ - etaInfoApp in_scope' sexpr eis - where - (in_scope', eis@(EI eta_bndrs mco)) - = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr) - top_bndrs = reverse rev_vs - top_eis = EI (top_bndrs ++ eta_bndrs) (mkPiMCos top_bndrs mco) - - -- Find ticks behind type apps. - -- See Note [Eta expansion and source notes] - -- I don't really understand this code SLPJ May 21 - (expr', args) = collectArgs expr - (ticks, expr'') = stripTicksTop tickishFloatable expr' - sexpr = mkApps expr'' args - retick expr = foldr mkTick expr ticks - -{- ********************************************************************* -* * - The EtaInfo mechanism - mkEtaWW, etaInfoAbs, etaInfoApp -* * -********************************************************************* -} - -{- Note [The EtaInfo mechanism] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have (e :: ty) and we want to eta-expand it to arity N. -This what eta_expand does. We do it in two steps: - -1. mkEtaWW: from 'ty' and 'N' build a EtaInfo which describes - the shape of the expansion necessary to expand to arity N. - -2. Build the term - \ v1..vn. e v1 .. vn - where those abstractions and applications are described by - the same EtaInfo. Specifically we build the term - - etaInfoAbs etas (etaInfoApp in_scope e etas) - - where etas :: EtaInfo - etaInfoAbs builds the lambdas - etaInfoApp builds the applictions - - 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 - newtype N a = MkN (S -> a) - axN :: N a ~ S -> a -and - e :: N (N Int) -then the eta-expansion should look like - (\(x::S) (y::S) -> e |> co x y) |> sym co -where - co :: N (N Int) ~ S -> S -> Int - co = axN @(N Int) ; (S -> axN @Int) - -We want to get one cast, at the top, to account for all those -nested newtypes. This is expressed by the EtaInfo type: - - data EtaInfo = EI [Var] MCoercionR - -Note [Check for reflexive casts in eta expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It turns out that the casts created by teh above mechanism are often Refl. -When casts are very deeply nested (as happens in #18223), the repetition -of types can make the overall term very large. So there is a big -payoff in cancelling out casts aggressively wherever possible. -(See also Note [No crap in eta-expanded code].) - -This matters particularly in etaInfoApp, where we -* Do beta-reduction on the fly -* Use getArg_maybe to get a cast out of the way, - so that we can do beta reduction -Together this makes a big difference. Consider when e is - case x of - True -> (\x -> e1) |> c1 - False -> (\p -> e2) |> c2 - -When we eta-expand this to arity 1, say, etaInfoAbs will wrap -a (\eta) around the outside and use etaInfoApp to apply each -alternative to 'eta'. We want to beta-reduce all that junk -away. - -#18223 was a dramatic example in which the intermediate term was -grotesquely huge, even though the next Simplifier iteration squashed -it. Better to kill it at birth. - -The crucial spots in etaInfoApp are: -* `checkReflexiveMCo` in the (Cast e co) case of `go` -* `checkReflexiveMCo` in `pushCoArg` -* Less important: checkReflexiveMCo in the final case of `go` -Collectively these make a factor-of-5 difference to the total -allocation of T18223, so take care if you change this stuff! - -Example: - newtype N = MkN (Y->Z) - f :: X -> N - f = \(x::X). ((\(y::Y). blah) |> fco) - -where fco :: (Y->Z) ~ N - -mkEtaWW makes an EtaInfo of (EI [(eta1:X), (eta2:Y)] eta_co - where - eta_co :: (X->N) ~ (X->Y->Z) - eta_co = ( -> nco) - nco :: N ~ (Y->Z) -- Comes from topNormaliseNewType_maybe - -Now, when we push that eta_co inward in etaInfoApp: -* In the (Cast e co) case, the 'fco' and 'nco' will meet, and - should cancel. -* When we meet the (\y.e) we want no cast on the y. - --} - --------------- -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 - -instance Outputable EtaInfo where - ppr (EI vs mco) = text "EI" <+> ppr vs <+> parens (ppr mco) - - -etaInfoApp :: InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr --- (etaInfoApp s e (EI bs mco) returns something equivalent to --- ((substExpr s e) |> mco b1 .. bn) --- See Note [The EtaInfo mechanism] --- --- NB: With very deeply nested casts, this function can be expensive --- In T18223, this function alone costs 15% of allocation, all --- spent in the calls to substExprSC and substBindSC - -etaInfoApp in_scope expr eis - = go (mkEmptySubst in_scope) expr eis - where - go :: Subst -> CoreExpr -> EtaInfo -> CoreExpr - -- 'go' pushed down the eta-infos into the branch of a case - -- and the body of a let; and does beta-reduction if possible - -- go subst fun co [b1,..,bn] returns (subst(fun) |> co) b1 .. bn - go subst (Tick t e) eis - = Tick (substTickish subst t) (go subst e eis) - - go subst (Cast e co) (EI bs mco) - = go subst e (EI bs mco') - where - mco' = checkReflexiveMCo (Core.substCo subst co `mkTransMCoR` mco) - -- See Note [Check for reflexive casts in eta expansion] - - go subst (Case e b ty alts) eis - = Case (Core.substExprSC subst e) b1 ty' alts' - where - (subst1, b1) = Core.substBndr subst b - alts' = map subst_alt alts - ty' = etaInfoAppTy (Core.substTy subst ty) eis - subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis) - where - (subst2,bs') = Core.substBndrs subst1 bs - - go subst (Let b e) eis - | not (isJoinBind b) -- See Note [Eta expansion for join points] - = Let b' (go subst' e eis) - where - (subst', b') = Core.substBindSC subst b - - -- Beta-reduction if possible, pushing any intervening casts past - -- the argument. See Note [The EtaInfo mechanism] - go subst (Lam v e) (EI (b:bs) mco) - | Just (arg,mco') <- pushMCoArg mco (varToCoreExpr b) - = go (Core.extendSubst subst v arg) e (EI bs mco') - - -- Stop pushing down; just wrap the expression up - -- See Note [Check for reflexive casts in eta expansion] - go subst e (EI bs mco) = Core.substExprSC subst e - `mkCastMCo` checkReflexiveMCo mco - `mkVarApps` bs - --------------- -etaInfoAppTy :: Type -> EtaInfo -> Type --- If e :: ty --- then etaInfoApp e eis :: etaInfoApp ty eis -etaInfoAppTy ty (EI bs mco) - = applyTypeToArgs (text "etaInfoAppTy") ty1 (map varToCoreExpr bs) - where - ty1 = case mco of - MRefl -> ty - MCo co -> coercionRKind co - --------------- -etaInfoAbs :: EtaInfo -> CoreExpr -> CoreExpr --- See Note [The EtaInfo mechanism] -etaInfoAbs (EI bs mco) expr = (mkLams bs expr) `mkCastMCo` mkSymMCo mco - --------------- --- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding --- an expression @e :: ty@ to take @n@ value arguments, where @fvs@ are the --- free variables of @e@. --- --- Note that this function is entirely unconcerned about cost centres and other --- semantically-irrelevant source annotations, so call sites must take care to --- preserve that info. See Note [Eta expansion and SCCs]. -mkEtaWW - :: [OneShotInfo] - -- ^ How many value arguments to eta-expand - -> SDoc - -- ^ The pretty-printed original expression, for warnings. - -> InScopeSet - -- ^ A super-set of the free vars of the expression to eta-expand. - -> Type - -> (InScopeSet, EtaInfo) - -- ^ The variables in 'EtaInfo' are fresh wrt. to the incoming 'InScopeSet'. - -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the - -- fresh variables in 'EtaInfo'. - -mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty - = go 0 orig_oss empty_subst orig_ty - where - empty_subst = mkEmptyTCvSubst in_scope - - go :: Int -- For fresh names - -> [OneShotInfo] -- Number of value args to expand to - -> TCvSubst -> Type -- We are really looking at subst(ty) - -> (InScopeSet, EtaInfo) - -- (go [o1,..,on] subst ty) = (in_scope, EI [b1,..,bn] co) - -- co :: subst(ty) ~ b1_ty -> ... -> bn_ty -> tr - - go _ [] subst _ -- See Note [exprArity invariant] - ----------- Done! No more expansion needed - = (getTCvInScope subst, EI [] MRefl) - - go n oss@(one_shot:oss1) subst ty -- See Note [exprArity invariant] - ----------- Forall types (forall a. ty) - | Just (tcv,ty') <- splitForAllTyCoVar_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)) - - ----------- Function types (t1 -> t2) - | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty - , typeHasFixedRuntimeRep arg_ty - -- See Note [Representation polymorphism invariants] in GHC.Core - -- See also test case typecheck/should_run/EtaExpandLevPoly - - , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty) - -- Avoid free vars of the original expression - - , let eta_id' = eta_id `setIdOneShotInfo` one_shot - , (in_scope, EI bs mco) <- go (n+1) oss1 subst' res_ty - = (in_scope, EI (eta_id' : bs) (mkFunResMCo (idScaledType eta_id') mco)) - - ----------- Newtypes - -- Given this: - -- newtype T = MkT ([T] -> Int) - -- Consider eta-expanding this - -- eta_expand 1 e T - -- We want to get - -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) - | Just (co, ty') <- topNormaliseNewType_maybe ty - , -- co :: ty ~ ty' - let co' = Type.substCo subst co - -- Remember to apply the substitution to co (#16979) - -- (or we could have applied to ty, but then - -- we'd have had to zap it for the recursive call) - , (in_scope, EI bs mco) <- go n oss subst ty' - -- mco :: subst(ty') ~ b1_ty -> ... -> bn_ty -> tr - = (in_scope, EI bs (mkTransMCoR co' mco)) - - | otherwise -- We have an expression of arity > 0, - -- 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) - (getTCvInScope 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 - - -{- ********************************************************************* -* * - The "push rules" -* * -************************************************************************ - -Here we implement the "push rules" from FC papers: - -* The push-argument rules, where we can move a coercion past an argument. - We have - (fun |> co) arg - and we want to transform it to - (fun arg') |> co' - for some suitable co' and transformed arg'. - -* The PushK rule for data constructors. We have - (K e1 .. en) |> co - and we want to transform to - (K e1' .. en') - by pushing the coercion into the arguments --} - -pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion) -pushCoArgs co [] = return ([], MCo co) -pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg - ; case m_co1 of - MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args - ; return (arg':args', m_co2) } - MRefl -> return (arg':args, MRefl) } - -pushMCoArg :: MCoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) -pushMCoArg MRefl arg = Just (arg, MRefl) -pushMCoArg (MCo co) arg = pushCoArg co arg - -pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) --- We have (fun |> co) arg, and we want to transform it to --- (fun arg) |> co --- This may fail, e.g. if (fun :: N) where N is a newtype --- C.f. simplCast in GHC.Core.Opt.Simplify --- 'co' is always Representational -pushCoArg co arg - | Type ty <- arg - = do { (ty', m_co') <- pushCoTyArg co ty - ; return (Type ty', m_co') } - | otherwise - = do { (arg_mco, m_co') <- pushCoValArg co - ; let arg_mco' = checkReflexiveMCo arg_mco - -- checkReflexiveMCo: see Note [Check for reflexive casts in eta expansion] - -- The coercion is very often (arg_co -> res_co), but without - -- the argument coercion actually being ReflCo - ; return (arg `mkCastMCo` arg_mco', m_co') } - -pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR) --- We have (fun |> co) @ty --- Push the coercion through to return --- (fun @ty') |> co' --- 'co' is always Representational --- If the returned coercion is Nothing, then it would have been reflexive; --- it's faster not to compute it, though. -pushCoTyArg co ty - -- The following is inefficient - don't do `eqType` here, the coercion - -- optimizer will take care of it. See #14737. - -- -- | tyL `eqType` tyR - -- -- = Just (ty, Nothing) - - | isReflCo co - = Just (ty, MRefl) - - | isForAllTy_ty tyL - = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $ - Just (ty `mkCastTy` co1, MCo co2) - - | otherwise - = Nothing - where - Pair tyL tyR = coercionKind co - -- co :: tyL ~ tyR - -- tyL = forall (a1 :: k1). ty1 - -- tyR = forall (a2 :: k2). ty2 - - co1 = mkSymCo (mkNthCo Nominal 0 co) - -- co1 :: k2 ~N k1 - -- Note that NthCo can extract a Nominal equality between the - -- kinds of the types related by a coercion between forall-types. - -- See the NthCo case in GHC.Core.Lint. - - co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1) - -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ] - -- Arg of mkInstCo is always nominal, hence mkNomReflCo - -pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR) --- We have (fun |> co) arg --- Push the coercion through to return --- (fun (arg |> co_arg)) |> co_res --- 'co' is always Representational --- If the second returned Coercion is actually Nothing, then no cast is necessary; --- the returned coercion would have been reflexive. -pushCoValArg co - -- The following is inefficient - don't do `eqType` here, the coercion - -- optimizer will take care of it. See #14737. - -- -- | tyL `eqType` tyR - -- -- = Just (mkRepReflCo arg, Nothing) - - | isReflCo co - = Just (MRefl, MRefl) - - | isFunTy tyL - , (co_mult, co1, co2) <- decomposeFunCo Representational co - , isReflexiveCo co_mult - -- We can't push the coercion in the case where co_mult isn't reflexivity: - -- it could be an unsafe axiom, and losing this information could yield - -- ill-typed terms. For instance (fun x ::(1) Int -> (fun _ -> () |> co) x) - -- with co :: (Int -> ()) ~ (Int %1 -> ()), would reduce to (fun x ::(1) Int - -- -> (fun _ ::(Many) Int -> ()) x) which is ill-typed - - -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) - -- then co1 :: tyL1 ~ tyR1 - -- co2 :: tyL2 ~ tyR2 - = assertPpr (isFunTy tyR) (ppr co $$ ppr arg) $ - Just (coToMCo (mkSymCo co1), coToMCo co2) - -- Critically, coToMCo to checks for ReflCo; the whole coercion may not - -- be reflexive, but either of its components might be - -- We could use isReflexiveCo, but it's not clear if the benefit - -- is worth the cost, and it makes no difference in #18223 - - | otherwise - = Nothing - where - arg = funArgTy tyR - Pair tyL tyR = coercionKind co - -pushCoercionIntoLambda - :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) --- This implements the Push rule from the paper on coercions --- (\x. e) |> co --- ===> --- (\x'. e |> co') -pushCoercionIntoLambda in_scope x e co - | assert (not (isTyVar x) && not (isCoVar x)) True - , Pair s1s2 t1t2 <- coercionKind co - , Just (_, _s1,_s2) <- splitFunTy_maybe s1s2 - , Just (w1, t1,_t2) <- splitFunTy_maybe t1t2 - , (co_mult, co1, co2) <- decomposeFunCo Representational co - , isReflexiveCo co_mult - -- We can't push the coercion in the case where co_mult isn't - -- reflexivity. See pushCoValArg for more details. - = let - -- Should we optimize the coercions here? - -- Otherwise they might not match too well - x' = x `setIdType` t1 `setIdMult` w1 - in_scope' = in_scope `extendInScopeSet` x' - subst = extendIdSubst (mkEmptySubst in_scope') - x - (mkCast (Var x') (mkSymCo co1)) - -- We substitute x' for x, except we need to preserve types. - -- The types are as follows: - -- x :: s1, x' :: t1, co1 :: s1 ~# t1, - -- so we extend the substitution with x |-> (x' |> sym co1). - in Just (x', substExpr subst e `mkCast` co2) - | otherwise - -- See #21555 / #21577 for a case where this trace fired but the cause was benign - = -- pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) - Nothing - -pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion - -> 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 --- 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) - - | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty - , to_tc == dataConTyCon dc - -- These two tests can fail; we might see - -- (C x y) `cast` (g :: T a ~ S [a]), - -- where S is a type function. In fact, exprIsConApp - -- will probably not be called in such circumstances, - -- but there's nothing wrong with it - - = let - tc_arity = tyConArity to_tc - dc_univ_tyvars = dataConUnivTyVars dc - dc_ex_tcvars = dataConExTyCoVars dc - arg_tys = dataConRepArgTys dc - - 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) - - -- 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) - - 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) ] - 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) - - | otherwise - = Nothing - - where - Pair from_ty to_ty = coercionKind co - -collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) --- Collect lambda binders, pushing coercions inside if possible --- E.g. (\x.e) |> g g :: -> blah --- = (\x. e |> Nth 1 g) --- --- That is, --- --- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g) -collectBindersPushingCo e - = go [] e - where - -- Peel off lambdas until we hit a cast. - go :: [Var] -> CoreExpr -> ([Var], CoreExpr) - -- The accumulator is in reverse order - go bs (Lam b e) = go (b:bs) e - go bs (Cast e co) = go_c bs e co - go bs e = (reverse bs, e) - - -- We are in a cast; peel off casts until we hit a lambda. - go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr) - -- (go_c bs e c) is same as (go bs e (e |> c)) - go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) - go_c bs (Lam b e) co = go_lam bs b e co - go_c bs e co = (reverse bs, mkCast e co) - - -- We are in a lambda under a cast; peel off lambdas and build a - -- new coercion for the body. - go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr) - -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) - go_lam bs b e co - | isTyVar b - , let Pair tyL tyR = coercionKind co - , assert (isForAllTy_ty tyL) $ - isForAllTy_ty tyR - , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] - = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) - - | isCoVar b - , let Pair tyL tyR = coercionKind co - , assert (isForAllTy_co tyL) $ - isForAllTy_co tyR - , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] - , let cov = mkCoVarCo b - = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov))) - - | isId b - , let Pair tyL tyR = coercionKind co - , assert (isFunTy tyL) $ isFunTy tyR - , (co_mult, co_arg, co_res) <- decomposeFunCo Representational co - , isReflCo co_mult -- See Note [collectBindersPushingCo] - , isReflCo co_arg -- See Note [collectBindersPushingCo] - = go_c (b:bs) e co_res - - | otherwise = (reverse bs, mkCast (Lam b e) co) - -{- - -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. - --} - -{- ********************************************************************* -* * - Join points -* * -********************************************************************* -} - -------------------- --- | Split an expression into the given number of binders and a body, --- eta-expanding if necessary. Counts value *and* type binders. -etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr) -etaExpandToJoinPoint join_arity expr - = go join_arity [] expr - where - go 0 rev_bs e = (reverse rev_bs, e) - go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e - go n rev_bs e = case etaBodyForJoinPoint n e of - (bs, e') -> (reverse rev_bs ++ bs, e') - -etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule -etaExpandToJoinPointRule _ rule@(BuiltinRule {}) - = warnPprTrace True "Can't eta-expand built-in rule:" (ppr rule) - -- How did a local binding get a built-in rule anyway? Probably a plugin. - rule -etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs - , ru_args = args }) - | need_args == 0 - = rule - | need_args < 0 - = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule) - | otherwise - = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args - , ru_rhs = new_rhs } - where - need_args = join_arity - length args - (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs - new_args = varsToCoreExprs new_bndrs - --- 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 - where - go 0 _ _ rev_bs e - = (reverse rev_bs, e) - go n ty subst rev_bs e - | Just (tv, res_ty) <- splitForAllTyCoVar_maybe ty - , let (subst', tv') = substVarBndr subst tv - = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv') - -- The varToCoreExpr is important: `tv` might be a coercion variable - | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty - , let (subst', b) = freshEtaId n subst (Scaled mult arg_ty) - = go (n-1) res_ty subst' (b : rev_bs) (e `App` varToCoreExpr b) - -- The varToCoreExpr is important: `b` might be a coercion variable - - | otherwise - = pprPanic "etaBodyForJoinPoint" $ int need_args $$ - ppr body $$ ppr (exprType body) - - init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e)) - - - --------------- -freshEtaId :: Int -> TCvSubst -> Scaled Type -> (TCvSubst, Id) --- Make a fresh Id, with specified type (after applying substitution) --- It should be "fresh" in the sense that it's not in the in-scope set --- of the TvSubstEnv; and it should itself then be added to the in-scope --- set of the TvSubstEnv --- --- The Int is just a reasonable starting point for generating a unique; --- it does not necessarily have to be unique itself. -freshEtaId n subst ty - = (subst', eta_id') - where - Scaled mult' ty' = Type.substScaledTyUnchecked subst ty - eta_id' = uniqAway (getTCvInScope subst) $ - mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) mult' ty' - -- "OrCoVar" since this can be used to eta-expand - -- coercion abstractions - subst' = extendTCvInScope subst eta_id' + +-- | Arity and eta expansion +module GHC.Core.Opt.Arity + ( -- Finding arity + manifestArity, joinRhsArity, exprArity + , findRhsArity, cheapArityType + , ArityOpts(..) + + -- ** Eta expansion + , exprEtaExpandArity, etaExpand, etaExpandAT + + -- ** Eta reduction + , tryEtaReduce + + -- ** ArityType + , ArityType, mkBotArityType + , arityTypeArity, idArityType + + -- ** Bottoming things + , exprIsDeadEnd, exprBotStrictness_maybe, arityTypeBotSigs_maybe + + -- ** typeArity and the state hack + , typeArity, typeOneShots, typeOneShot + , isOneShotBndr + , isStateHackType + + -- * Lambdas + , zapLamBndrs + + + -- ** Join points + , etaExpandToJoinPoint, etaExpandToJoinPointRule + + -- ** Coercions and casts + , pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg + , pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo + ) +where + +import GHC.Prelude + +import GHC.Core +import GHC.Core.FVs +import GHC.Core.Utils +import GHC.Core.DataCon +import GHC.Core.TyCon ( tyConArity ) +import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc ) +import GHC.Core.Predicate ( isDictTy, isEvVar, isCallStackPredTy ) +import GHC.Core.Multiplicity + +-- We have two sorts of substitution: +-- GHC.Core.Subst.Subst, and GHC.Core.TyCo.Subst +-- Both have substTy, substCo Hence need for qualification +import GHC.Core.Subst as Core +import GHC.Core.Type as Type +import GHC.Core.Coercion as Type +import GHC.Core.TyCo.Compare( eqType ) + +import GHC.Types.Demand +import GHC.Types.Cpr( CprSig, mkCprSig, botCpr ) +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Basic +import GHC.Types.Tickish + +import GHC.Builtin.Types.Prim +import GHC.Builtin.Uniques + +import GHC.Data.FastString +import GHC.Data.Graph.UnVar +import GHC.Data.Pair + +import GHC.Utils.GlobalVars( unsafeHasNoStateHack ) +import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc + +{- +************************************************************************ +* * + manifestArity and exprArity +* * +************************************************************************ + +exprArity is a cheap-and-cheerful version of exprEtaExpandArity. +It tells how many things the expression can be applied to before doing +any work. It doesn't look inside cases, lets, etc. The idea is that +exprEtaExpandArity will do the hard work, leaving something that's easy +for exprArity to grapple with. In particular, Simplify uses exprArity to +compute the ArityInfo for the Id. + +Originally I thought that it was enough just to look for top-level lambdas, but +it isn't. I've seen this + + foo = PrelBase.timesInt + +We want foo to get arity 2 even though the eta-expander will leave it +unchanged, in the expectation that it'll be inlined. But occasionally it +isn't, because foo is blacklisted (used in a rule). + +Similarly, see the ok_note check in exprEtaExpandArity. So + f = __inline_me (\x -> e) +won't be eta-expanded. + +And in any case it seems more robust to have exprArity be a bit more intelligent. +But note that (\x y z -> f x y z) +should have arity 3, regardless of f's arity. +-} + +manifestArity :: CoreExpr -> Arity +-- ^ manifestArity sees how many leading value lambdas there are, +-- after looking through casts +manifestArity (Lam v e) | isId v = 1 + manifestArity e + | otherwise = manifestArity e +manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e +manifestArity (Cast e _) = manifestArity e +manifestArity _ = 0 + +joinRhsArity :: CoreExpr -> JoinArity +-- Join points are supposed to have manifestly-visible +-- lambdas at the top: no ticks, no casts, nothing +-- Moreover, type lambdas count in JoinArity +joinRhsArity (Lam _ e) = 1 + joinRhsArity e +joinRhsArity _ = 0 + + +--------------- +exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig, CprSig) +-- A cheap and cheerful function that identifies bottoming functions +-- and gives them a suitable strictness and CPR signatures. +-- It's used during float-out +exprBotStrictness_maybe e = arityTypeBotSigs_maybe (cheapArityType e) + +arityTypeBotSigs_maybe :: ArityType -> Maybe (Arity, DmdSig, CprSig) +-- Arity of a divergent function +arityTypeBotSigs_maybe (AT lams div) + | isDeadEndDiv div = Just ( arity + , mkVanillaDmdSig arity botDiv + , mkCprSig arity botCpr) + | otherwise = Nothing + where + arity = length lams + + +{- Note [exprArity for applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come to an application we check that the arg is trivial. + eg f (fac x) does not have arity 2, + even if f has arity 3! + +* We require that is trivial rather merely cheap. Suppose f has arity 2. + Then f (Just y) + has arity 0, because if we gave it arity 1 and then inlined f we'd get + let v = Just y in \w. + which has arity 0. And we try to maintain the invariant that we don't + have arity decreases. + +* The `max 0` is important! (\x y -> f x) has arity 2, even if f is + unknown, hence arity 0 + + +************************************************************************ +* * + typeArity and the "state hack" +* * +********************************************************************* -} + + +typeArity :: Type -> Arity +-- ^ (typeArity ty) says how many arrows GHC can expose in 'ty', after +-- looking through newtypes. More generally, (typeOneShots ty) returns +-- ty's [OneShotInfo], based only on the type itself, using typeOneShot +-- on the argument type to access the "state hack". +typeArity = length . typeOneShots + +typeOneShots :: Type -> [OneShotInfo] +-- How many value arrows are visible in the type? +-- We look through foralls, and newtypes +-- See Note [Arity invariants for bindings] +typeOneShots ty + = go initRecTc ty + where + go rec_nts ty + | Just (_, ty') <- splitForAllTyCoVar_maybe ty + = go rec_nts ty' + + | Just (_,_,arg,res) <- splitFunTy_maybe ty + = typeOneShot arg : go rec_nts res + + | Just (tc,tys) <- splitTyConApp_maybe ty + , Just (ty', _) <- instNewTyCon_maybe tc tys + , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes and products] + -- in GHC.Core.TyCon +-- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes +-- -- See Note [Newtype classes and eta expansion] +-- (no longer required) + = go rec_nts' ty' + -- Important to look through non-recursive newtypes, so that, eg + -- (f x) where f has arity 2, f :: Int -> IO () + -- Here we want to get arity 1 for the result! + -- + -- AND through a layer of recursive newtypes + -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) + + | otherwise + = [] + +typeOneShot :: Type -> OneShotInfo +typeOneShot ty + | isStateHackType ty = OneShotLam + | otherwise = NoOneShotInfo + +-- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account +-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" +idStateHackOneShotInfo :: Id -> OneShotInfo +idStateHackOneShotInfo id + | isStateHackType (idType id) = OneShotLam + | otherwise = idOneShotInfo id + +-- | Returns whether the lambda associated with the 'Id' is +-- certainly applied at most once +-- This one is the "business end", called externally. +-- It works on type variables as well as Ids, returning True +-- Its main purpose is to encapsulate the Horrible State Hack +-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" +isOneShotBndr :: Var -> Bool +isOneShotBndr var + | isTyVar var = True + | OneShotLam <- idStateHackOneShotInfo var = True + | otherwise = False + +isStateHackType :: Type -> Bool +isStateHackType ty + | unsafeHasNoStateHack -- Switch off with -fno-state-hack + = False + | otherwise + = case tyConAppTyCon_maybe ty of + Just tycon -> tycon == statePrimTyCon + _ -> False + -- This is a gross hack. It claims that + -- every function over realWorldStatePrimTy is a one-shot + -- function. This is pretty true in practice, and makes a big + -- difference. For example, consider + -- a `thenST` \ r -> ...E... + -- The early full laziness pass, if it doesn't know that r is one-shot + -- will pull out E (let's say it doesn't mention r) to give + -- let lvl = E in a `thenST` \ r -> ...lvl... + -- When `thenST` gets inlined, we end up with + -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... + -- and we don't re-inline E. + -- + -- It would be better to spot that r was one-shot to start with, but + -- I don't want to rely on that. + -- + -- Another good example is in fill_in in PrelPack.hs. We should be able to + -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. + + +{- Note [Arity invariants for bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have the following invariants for let-bindings + + (1) In any binding f = e, + idArity f <= typeArity (idType f) + We enforce this with trimArityType, called in findRhsArity; + see Note [Arity trimming]. + + Note that we enforce this only for /bindings/. We do /not/ insist that + arityTypeArity (arityType e) <= typeArity (exprType e) + because that is quite a bit more expensive to guaranteed; it would + mean checking at every Cast in the recursive arityType, for example. + + (2) If typeArity (exprType e) = n, + then manifestArity (etaExpand e n) = n + + That is, etaExpand can always expand as much as typeArity says + (or less, of course). So the case analysis in etaExpand and in + typeArity must match. + + Consequence: because of (1), if we eta-expand to (idArity f), we will + end up with n manifest lambdas. + + (3) In any binding f = e, + idArity f <= arityTypeArity (safeArityType (arityType e)) + That is, we call safeArityType before attributing e's arityType to f. + See Note [SafeArityType]. + + So we call safeArityType in findRhsArity. + +Suppose we have + f :: Int -> Int -> Int + f x y = x+y -- Arity 2 + + g :: F Int + g = case of { True -> f |> co1 + ; False -> g |> co2 } + +where F is a type family. Now, we can't eta-expand g to have arity 2, +because etaExpand, which works off the /type/ of the expression +(albeit looking through newtypes), doesn't know how to make an +eta-expanded binding + g = (\a b. case x of ...) |> co +because it can't make up `co` or the types of `a` and `b`. + +So invariant (1) ensures that every binding has an arity that is no greater +than the typeArity of the RHS; and invariant (2) ensures that etaExpand +and handle what typeArity says. + +Why is this important? Because + + - In GHC.Iface.Tidy we use exprArity/manifestArity to fix the *final + arity* of each top-level Id, and in + + - In CorePrep we use etaExpand on each rhs, so that the visible + lambdas actually match that arity, which in turn means that the + StgRhs has a number of lambdas that precisely matches the arity. + +Note [Arity trimming] +~~~~~~~~~~~~~~~~~~~~~ +Invariant (1) of Note [Arity invariants for bindings] is upheld by findRhsArity, +which calls trimArityType to trim the ArityType to match the Arity of the +binding. Failing to do so, and hence breaking invariant (1) led to #5441. + +How to trim? If we end in topDiv, it's easy. But we must take great care with +dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"), +we'll get \??.⊥. We absolutely must not trim that to \?.⊥, because that +claims that ((\x y. error "urk") |> co) diverges when given one argument, +which it absolutely does not. And Bad Things happen if we think something +returns bottom when it doesn't (#16066). + +So, if we need to trim a dead-ending arity type, switch (conservatively) to +topDiv. + +Historical note: long ago, we unconditionally switched to topDiv when we +encountered a cast, but that is far too conservative: see #5475 + +Note [Newtype classes and eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + NB: this nasty special case is no longer required, because + for newtype classes we don't use the class-op rule mechanism + at all. See Note [Single-method classes] in GHC.Tc.TyCl.Instance. SLPJ May 2013 + +-------- Old out of date comments, just for interest ----------- +We have to be careful when eta-expanding through newtypes. In general +it's a good idea, but annoyingly it interacts badly with the class-op +rule mechanism. Consider + + class C a where { op :: a -> a } + instance C b => C [b] where + op x = ... + +These translate to + + co :: forall a. (a->a) ~ C a + + $copList :: C b -> [b] -> [b] + $copList d x = ... + + $dfList :: C b -> C [b] + {-# DFunUnfolding = [$copList] #-} + $dfList d = $copList d |> co@[b] + +Now suppose we have: + + dCInt :: C Int + + blah :: [Int] -> [Int] + blah = op ($dfList dCInt) + +Now we want the built-in op/$dfList rule will fire to give + blah = $copList dCInt + +But with eta-expansion 'blah' might (and in #3772, which is +slightly more complicated, does) turn into + + blah = op (\eta. ($dfList dCInt |> sym co) eta) + +and now it is *much* harder for the op/$dfList rule to fire, because +exprIsConApp_maybe won't hold of the argument to op. I considered +trying to *make* it hold, but it's tricky and I gave up. + +The test simplCore/should_compile/T3722 is an excellent example. +-------- End of old out of date comments, just for interest ----------- +-} + +{- ******************************************************************** +* * + Zapping lambda binders +* * +********************************************************************* -} + +zapLamBndrs :: FullArgCount -> [Var] -> [Var] +-- If (\xyz. t) appears under-applied to only two arguments, +-- we must zap the occ-info on x,y, because they appear (in 't') under the \z. +-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal +-- +-- NB: both `arg_count` and `bndrs` include both type and value args/bndrs +zapLamBndrs arg_count bndrs + | no_need_to_zap = bndrs + | otherwise = zap_em arg_count bndrs + where + no_need_to_zap = all isOneShotBndr (drop arg_count bndrs) + + zap_em :: FullArgCount -> [Var] -> [Var] + zap_em 0 bs = bs + zap_em _ [] = [] + zap_em n (b:bs) | isTyVar b = b : zap_em (n-1) bs + | otherwise = zapLamIdInfo b : zap_em (n-1) bs + + +{- ********************************************************************* +* * + Computing the "arity" of an expression +* * +************************************************************************ + +Note [Definition of arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "arity" of an expression 'e' is n if + applying 'e' to *fewer* than n *value* arguments + converges rapidly + +Or, to put it another way + + there is no work lost in duplicating the partial + application (e x1 .. x(n-1)) + +In the divergent case, no work is lost by duplicating because if the thing +is evaluated once, that's the end of the program. + +Or, to put it another way, in any context C + + C[ (\x1 .. xn. e x1 .. xn) ] + is as efficient as + C[ e ] + +It's all a bit more subtle than it looks: + +Note [One-shot lambdas] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider one-shot lambdas + let x = expensive in \y z -> E +We want this to have arity 1 if the \y-abstraction is a 1-shot lambda. + +Note [Dealing with bottom] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC does some transformations that are technically unsound wrt +bottom, because doing so improves arities... a lot! We describe +them in this Note. + +The flag -fpedantic-bottoms (off by default) restore technically +correct behaviour at the cots of efficiency. + +It's mostly to do with eta-expansion. Consider + + f = \x -> case x of + True -> \s -> e1 + False -> \s -> e2 + +This happens all the time when f :: Bool -> IO () +In this case we do eta-expand, in order to get that \s to the +top, and give f arity 2. + +This isn't really right in the presence of seq. Consider + (f bot) `seq` 1 + +This should diverge! But if we eta-expand, it won't. We ignore this +"problem" (unless -fpedantic-bottoms is on), because being scrupulous +would lose an important transformation for many programs. (See +#5587 for an example.) + +Consider also + f = \x -> error "foo" +Here, arity 1 is fine. But if it looks like this (see #22068) + f = \x -> case x of + True -> error "foo" + False -> \y -> x+y +then we want to get arity 2. Technically, this isn't quite right, because + (f True) `seq` 1 +should diverge, but it'll converge if we eta-expand f. Nevertheless, we +do so; it improves some programs significantly, and increasing convergence +isn't a bad thing. Hence the ABot/ATop in ArityType. + +So these two transformations aren't always the Right Thing, and we +have several tickets reporting unexpected behaviour resulting from +this transformation. So we try to limit it as much as possible: + + (1) Do NOT move a lambda outside a known-bottom case expression + case undefined of { (a,b) -> \y -> e } + This showed up in #5557 + + (2) Do NOT move a lambda outside a case unless + (a) The scrutinee is ok-for-speculation, or + (b) more liberally: the scrutinee is cheap (e.g. a variable), and + -fpedantic-bottoms is not enforced (see #2915 for an example) + +Of course both (1) and (2) are readily defeated by disguising the bottoms. + +4. 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 + + newtype T = MkT ([T] -> Int) + +Suppose we have + e = coerce T f +where f has arity 1. Then: etaExpandArity e = 1; +that is, etaExpandArity looks through the coerce. + +When we eta-expand e to arity 1: eta_expand 1 e T +we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + + HOWEVER, note that if you use coerce bogusly you can ge + coerce Int negate + And since negate has arity 2, you might try to eta expand. But you can't + decompose Int to a function type. Hence the final case in eta_expand. + +Note [The state-transformer hack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + f = e +where e has arity n. Then, if we know from the context that f has +a usage type like + t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ... +then we can expand the arity to m. This usage type says that +any application (x e1 .. en) will be applied to uniquely to (m-n) more args +Consider f = \x. let y = + in case x of + True -> foo + False -> \(s:RealWorld) -> e +where foo has arity 1. Then we want the state hack to +apply to foo too, so we can eta expand the case. + +Then we expect that if f is applied to one arg, it'll be applied to two +(that's the hack -- we don't really know, and sometimes it's false) +See also Id.isOneShotBndr. + +Note [State hack and bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's a terrible idea to use the state hack on a bottoming function. +Here's what happens (#2861): + + f :: String -> IO T + f = \p. error "..." + +Eta-expand, using the state hack: + + f = \p. (\s. ((error "...") |> g1) s) |> g2 + g1 :: IO T ~ (S -> (S,T)) + g2 :: (S -> (S,T)) ~ IO T + +Extrude the g2 + + f' = \p. \s. ((error "...") |> g1) s + f = f' |> (String -> g2) + +Discard args for bottoming function + + f' = \p. \s. ((error "...") |> g1 |> g3 + g3 :: (S -> (S,T)) ~ (S,T) + +Extrude g1.g3 + + f'' = \p. \s. (error "...") + f' = f'' |> (String -> S -> g1.g3) + +And now we can repeat the whole loop. Aargh! The bug is in applying the +state hack to a function which then swallows the argument. + +This arose in another guise in #3959. Here we had + + catch# (throw exn >> return ()) + +Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()]. +After inlining (>>) we get + + catch# (\_. throw {IO ()} exn) + +We must *not* eta-expand to + + catch# (\_ _. throw {...} exn) + +because 'catch#' expects to get a (# _,_ #) after applying its argument to +a State#, not another function! + +In short, we use the state hack to allow us to push let inside a lambda, +but not to introduce a new lambda. + + +Note [ArityType] +~~~~~~~~~~~~~~~~ +ArityType can be thought of as an abstraction of an expression. +The ArityType + AT [ (IsCheap, NoOneShotInfo) + , (IsExpensive, OneShotLam) + , (IsCheap, OneShotLam) ] Dunno) + +abstracts an expression like + \x. let in + \y{os}. + \z{os}. blah + +In general we have (AT lams div). Then +* In lams :: [(Cost,OneShotInfo)] + * The Cost flag describes the part of the expression down + to the first (value) lambda. + * The OneShotInfo flag gives the one-shot info on that lambda. + +* If 'div' is dead-ending ('isDeadEndDiv'), then application to + 'length lams' arguments will surely diverge, similar to the situation + with 'DmdType'. + +ArityType is the result of a compositional analysis on expressions, +from which we can decide the real arity of the expression (extracted +with function exprEtaExpandArity). + +We use the following notation: + at ::= \p1..pn.div + div ::= T | x | ⊥ + p ::= (c o) + c ::= X | C -- Expensive or Cheap + o ::= ? | 1 -- NotOneShot or OneShotLam +We may omit the \. if n = 0. +And ⊥ stands for `AT [] botDiv` + +Here is an example demonstrating the notation: + \(C?)(X1)(C1).T +stands for + AT [ (IsCheap,NoOneShotInfo) + , (IsExpensive,OneShotLam) + , (IsCheap,OneShotLam) ] + topDiv + +See the 'Outputable' instance for more information. It's pretty simple. + +How can we use ArityType? Example: + f = \x\y. let v = in + \s(one-shot) \t(one-shot). blah + 'f' has arity type \(C?)(C?)(X1)(C1).T + The one-shot-ness means we can, in effect, push that + 'let' inside the \st, and expand to arity 4 + +Suppose f = \xy. x+y +Then f :: \(C?)(C?).T + f v :: \(C?).T + f :: \(X?).T + +Here is what the fields mean. If an arbitrary expression 'f' has +ArityType 'at', then + + * If @at = AT [o1,..,on] botDiv@ (notation: \o1..on.⊥), then @f x1..xn@ + definitely diverges. Partial applications to fewer than n args may *or + may not* diverge. Ditto exnDiv. + + * If `f` has ArityType `at` we can eta-expand `f` to have (aritTypeOneShots at) + arguments without losing sharing. This function checks that the either + there are no expensive expressions, or the lambdas are one-shots. + + NB 'f' is an arbitrary expression, eg @f = g e1 e2@. This 'f' can have + arity type @AT oss _@, with @length oss > 0@, only if e1 e2 are themselves + cheap. + + * In both cases, @f@, @f x1@, ... @f x1 ... x(n-1)@ are definitely + really functions, or bottom, but *not* casts from a data type, in + at least one case branch. (If it's a function in one case branch but + an unsafe cast from a data type in another, the program is bogus.) + So eta expansion is dynamically ok; see Note [State hack and + bottoming functions], the part about catch# + +Wrinkles + +* Wrinkle [Bottoming functions]: see function 'arityLam'. + We treat bottoming functions as one-shot, because there is no point + in floating work outside the lambda, and it's fine to float it inside. + + For example, this is fine (see test stranal/sigs/BottomFromInnerLambda) + let x = in \y. error (g x y) + ==> \y. let x = in error (g x y) + + Idea: perhaps we could enforce this invariant with + data Arity Type = TopAT [(Cost, OneShotInfo)] | DivAT [Cost] + + +Note [SafeArityType] +~~~~~~~~~~~~~~~~~~~~ +The function safeArityType trims an ArityType to return a "safe" ArityType, +for which we use a type synonym SafeArityType. It is "safe" in the sense +that (arityTypeArity at) really reflects the arity of the expression, whereas +a regular ArityType might have more lambdas in its [ATLamInfo] that the +(cost-free) arity of the expression. + +For example + \x.\y.let v = expensive in \z. blah +has + arityType = AT [C?, C?, X?, C?] Top +But the expression actually has arity 2, not 4, because of the X. +So safeArityType will trim it to (AT [C?, C?] Top), whose [ATLamInfo] +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 +in findRhsArity. See Note [Combining arity type with demand info]. + +Thus the function `arityType` returns a regular "unsafe" ArityType, that +goes deeply into the lambdas (including under IsExpensive). But that is +very local; most ArityTypes are indeed "safe". We use the type synonym +SafeArityType to indicate where we believe the ArityType is safe. +-} + +-- | The analysis lattice of arity analysis. It is isomorphic to +-- +-- @ +-- data ArityType' +-- = AEnd Divergence +-- | ALam OneShotInfo ArityType' +-- @ +-- +-- Which is easier to display the Hasse diagram for: +-- +-- @ +-- ALam OneShotLam at +-- | +-- AEnd topDiv +-- | +-- ALam NoOneShotInfo at +-- | +-- AEnd exnDiv +-- | +-- AEnd botDiv +-- @ +-- +-- where the @at@ fields of @ALam@ are inductively subject to the same order. +-- That is, @ALam os at1 < ALam os at2@ iff @at1 < at2@. +-- +-- Why the strange Top element? +-- See Note [Combining case branches: optimistic one-shot-ness] +-- +-- We rely on this lattice structure for fixed-point iteration in +-- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType]. +data ArityType -- See Note [ArityType] + = AT ![ATLamInfo] !Divergence + -- ^ `AT oss div` is an abstraction of the expression, which describes + -- its lambdas, and how much work appears where. + -- See Note [ArityType] for more information + -- + -- If `div` is dead-ending ('isDeadEndDiv'), then application to + -- `length os` arguments will surely diverge, similar to the situation + -- with 'DmdType'. + deriving Eq + +type ATLamInfo = (Cost,OneShotInfo) + -- ^ Info about one lambda in an ArityType + -- See Note [ArityType] + +type SafeArityType = ArityType -- See Note [SafeArityType] + +data Cost = IsCheap | IsExpensive + deriving( Eq ) + +allCosts :: (a -> Cost) -> [a] -> Cost +allCosts f xs = foldr (addCost . f) IsCheap xs + +addCost :: Cost -> Cost -> Cost +addCost IsCheap IsCheap = IsCheap +addCost _ _ = IsExpensive + +-- | This is the BNF of the generated output: +-- +-- @ +-- @ +-- +-- We format +-- @AT [o1,..,on] topDiv@ as @\o1..on.T@ and +-- @AT [o1,..,on] botDiv@ as @\o1..on.⊥@, respectively. +-- More concretely, @AT [NOI,OS,OS] topDiv@ is formatted as @\?11.T@. +-- If the one-shot info is empty, we omit the leading @\.@. +instance Outputable ArityType where + ppr (AT oss div) + | null oss = pp_div div + | otherwise = char '\\' <> hcat (map pp_os oss) <> dot <> pp_div div + where + pp_div Diverges = char '⊥' + pp_div ExnOrDiv = char 'x' + pp_div Dunno = char 'T' + pp_os (IsCheap, OneShotLam) = text "(C1)" + pp_os (IsExpensive, OneShotLam) = text "(X1)" + pp_os (IsCheap, NoOneShotInfo) = text "(C?)" + pp_os (IsExpensive, NoOneShotInfo) = text "(X?)" + +mkBotArityType :: [OneShotInfo] -> ArityType +mkBotArityType oss = AT [(IsCheap,os) | os <- oss] botDiv + +botArityType :: ArityType +botArityType = mkBotArityType [] + +topArityType :: ArityType +topArityType = AT [] topDiv + +-- | The number of value args for the arity type +arityTypeArity :: SafeArityType -> Arity +arityTypeArity (AT lams _) = length lams + +arityTypeOneShots :: SafeArityType -> [OneShotInfo] +-- Returns a list only as long as the arity should be +arityTypeOneShots (AT lams _) = map snd lams + +safeArityType :: ArityType -> SafeArityType +-- ^ Assuming this ArityType is all we know, find the arity of +-- the function, and trim the argument info (and Divergence) +-- to match that arity. See Note [SafeArityType] +safeArityType at@(AT lams _) + = case go 0 IsCheap lams of + Nothing -> at -- No trimming needed + Just ar -> AT (take ar lams) topDiv + where + go :: Arity -> Cost -> [(Cost,OneShotInfo)] -> Maybe Arity + go _ _ [] = Nothing + go ar ch1 ((ch2,os):lams) + = case (ch1 `addCost` ch2, os) of + (IsExpensive, NoOneShotInfo) -> Just ar + (ch, _) -> go (ar+1) ch lams + +infixl 2 `trimArityType` + +trimArityType :: Arity -> ArityType -> ArityType +-- ^ Trim an arity type so that it has at most the given arity. +-- Any excess 'OneShotInfo's are truncated to 'topDiv', even if +-- they end in 'ABot'. See Note [Arity trimming] +trimArityType max_arity at@(AT lams _) + | lams `lengthAtMost` max_arity = at + | otherwise = AT (take max_arity lams) topDiv + +data ArityOpts = ArityOpts + { ao_ped_bot :: !Bool -- See Note [Dealing with bottom] + , ao_dicts_cheap :: !Bool -- See Note [Eta expanding through dictionaries] + } + +-- | The Arity returned is the number of value args the +-- expression can be applied to without doing much work +exprEtaExpandArity :: ArityOpts -> CoreExpr -> Maybe SafeArityType +-- exprEtaExpandArity is used when eta expanding +-- e ==> \xy -> e x y +-- Nothing if the expression has arity 0 +exprEtaExpandArity opts e + | AT [] _ <- arity_type + = Nothing + | otherwise + = Just arity_type + where + arity_type = safeArityType (arityType (findRhsArityEnv opts False) e) + + +{- ********************************************************************* +* * + findRhsArity +* * +********************************************************************* -} + +findRhsArity :: ArityOpts -> RecFlag -> Id -> CoreExpr + -> (Bool, SafeArityType) +-- This implements the fixpoint loop for arity analysis +-- See Note [Arity analysis] +-- +-- The Bool is True if the returned arity is greater than (exprArity rhs) +-- so the caller should do eta-expansion +-- That Bool is never True for join points, which are never eta-expanded +-- +-- Returns an SafeArityType that is guaranteed trimmed to typeArity of 'bndr' +-- See Note [Arity trimming] + +findRhsArity opts is_rec bndr rhs + | isJoinId bndr + = (False, join_arity_type) + -- False: see Note [Do not eta-expand join points] + -- But do return the correct arity and bottom-ness, because + -- these are used to set the bndr's IdInfo (#15517) + -- Note [Invariants on join points] invariant 2b, in GHC.Core + + | otherwise + = (arity_increased, non_join_arity_type) + -- arity_increased: eta-expand if we'll get more lambdas + -- to the top of the RHS + where + old_arity = exprArity rhs + + init_env :: ArityEnv + init_env = findRhsArityEnv opts (isJoinId bndr) + + -- Non-join-points only + non_join_arity_type = case is_rec of + Recursive -> go 0 botArityType + NonRecursive -> step init_env + arity_increased = arityTypeArity non_join_arity_type > old_arity + + -- Join-points only + -- See Note [Arity for non-recursive join bindings] + -- and Note [Arity for recursive join bindings] + join_arity_type = case is_rec of + Recursive -> go 0 botArityType + NonRecursive -> trimArityType ty_arity (cheapArityType rhs) + + ty_arity = typeArity (idType bndr) + id_one_shots = idDemandOneShots 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 + -- trimArityType: see Note [Trim arity inside the loop] + -- combineWithDemandOneShots: 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 + + -- The fixpoint iteration (go), done for recursive bindings. We + -- always do one step, but usually that produces a result equal + -- to old_arity, and then we stop right away, because old_arity + -- is assumed to be sound. In other words, arities should never + -- decrease. Result: the common case is that there is just one + -- iteration + go :: Int -> SafeArityType -> SafeArityType + go !n cur_at@(AT lams div) + | not (isDeadEndDiv div) -- the "stop right away" case + , length lams <= old_arity = cur_at -- from above + | next_at == cur_at = cur_at + | otherwise + -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity] + = warnPprTrace (debugIsOn && n > 2) + "Exciting arity" + (nest 2 (ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $ + go (n+1) next_at + where + next_at = step (extendSigEnv init_env bndr cur_at) + +infixl 2 `combineWithDemandOneShots` + +combineWithDemandOneShots :: ArityType -> [OneShotInfo] -> ArityType +-- See Note [Combining arity type with demand info] +combineWithDemandOneShots at@(AT lams div) oss + | null lams = at + | otherwise = AT (zip_lams lams oss) div + where + zip_lams :: [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo] + zip_lams lams [] = lams + zip_lams [] oss | isDeadEndDiv div = [] + | otherwise = [ (IsExpensive,OneShotLam) + | _ <- takeWhile isOneShotInfo oss] + 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 + where + call_arity_one_shots :: [OneShotInfo] + 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] + call_arity = idCallArity bndr + + dmd_one_shots :: [OneShotInfo] + -- 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) + + -- 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 + +{- Note [Arity analysis] +~~~~~~~~~~~~~~~~~~~~~~~~ +The motivating example for arity analysis is this: + + f = \x. let g = f (x+1) + in \y. ...g... + +What arity does f have? Really it should have arity 2, but a naive +look at the RHS won't see that. You need a fixpoint analysis which +says it has arity "infinity" the first time round. + +This example happens a lot; it first showed up in Andy Gill's thesis, +fifteen years ago! It also shows up in the code for 'rnf' on lists +in #4138. + +We do the necessary, quite simple fixed-point iteration in 'findRhsArity', +which assumes for a single binding 'ABot' on the first run and iterates +until it finds a stable arity type. Two wrinkles + +* We often have to ask (see the Case or Let case of 'arityType') whether some + expression is cheap. In the case of an application, that depends on the arity + of the application head! That's why we have our own version of 'exprIsCheap', + 'myExprIsCheap', that will integrate the optimistic arity types we have on + f and g into the cheapness check. + +* Consider this (#18793) + + go = \ds. case ds of + [] -> id + (x:ys) -> let acc = go ys in + case blah of + True -> acc + False -> \ x1 -> acc (negate x1) + + We must propagate go's optimistically large arity to @acc@, so that the + tail call to @acc@ in the True branch has sufficient arity. This is done + by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case + of 'arityType'. + +Note [Exciting arity] +~~~~~~~~~~~~~~~~~~~~~ +The fixed-point iteration in 'findRhsArity' stabilises very quickly in almost +all cases. To get notified of cases where we need an usual number of iterations, +we emit a warning in debug mode, so that we can investigate and make sure that +we really can't do better. It's a gross hack, but catches real bugs (#18870). + +Now, which number is "unusual"? We pick n > 2. Here's a pretty common and +expected example that takes two iterations and would ruin the specificity +of the warning (from T18937): + + f :: [Int] -> Int -> Int + f [] = id + f (x:xs) = let y = sum [0..x] + in \z -> f xs (y + z) + +Fixed-point iteration starts with arity type ⊥ for f. After the first +iteration, we get arity type \??.T, e.g. arity 2, because we unconditionally +'floatIn' the let-binding (see its bottom case). After the second iteration, +we get arity type \?.T, e.g. arity 1, because now we are no longer allowed +to floatIn the non-cheap let-binding. Which is all perfectly benign, but +means we do two iterations (well, actually 3 'step's to detect we are stable) +and don't want to emit the warning. + +Note [Trim arity inside the loop] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here's an example (from gadt/nbe.hs) which caused trouble. + data Exp g t where + Lam :: Ty a -> Exp (g,a) b -> Exp g (a->b) + + eval :: Exp g t -> g -> t + eval (Lam _ e) g = \a -> eval e (g,a) + +The danger is that we get arity 3 from analysing this; and the +next time arity 4, and so on for ever. Solution: use trimArityType +on each iteration. + +Note [Combining arity type with demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let f = \x. let y = in \p \q{os}. blah + in ...(f a b)...(f c d)... + +* From the RHS we get an ArityType like + AT [ (IsCheap,?), (IsExpensive,?), (IsCheap,OneShotLam) ] Dunno + where "?" means NoOneShotInfo + +* From the body, the demand analyser (or Call Arity) will tell us + that the function is always applied to at least two arguments. + +Combining these two pieces of info, we can get the final ArityType + AT [ (IsCheap,?), (IsExpensive,OneShotLam), (IsCheap,OneShotLam) ] Dunno +result: arity=3, which is better than we could do from either +source alone. + +The "combining" part is done by combineWithDemandOneShots. It +uses info from both Call Arity and demand analysis. + +We may have /more/ call demands from the calls than we have lambdas +in the binding. E.g. + let f1 = \x. g x x in ...(f1 p q r)... + -- Demand on f1 is C(x,C(1,C(1,L))) + + let f2 = \y. error y in ...(f2 p q r)... + -- Demand on f2 is C(x,C(1,C(1,L))) + +In both these cases we can eta expand f1 and f2 to arity 3. +But /only/ for called-once demands. Suppose we had + let f1 = \y. g x x in ...let h = f1 p q in ...(h r1)...(h r2)... + +Now we don't want to eta-expand f1 to have 3 args; only two. +Nor, in the case of f2, do we want to push that error call under +a lambda. Hence the takeWhile in combineWithDemandDoneShots. + +Note [Do not eta-expand join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Similarly to CPR (see Note [Don't w/w join points for CPR] in +GHC.Core.Opt.WorkWrap), a join point stands well to gain from its outer binding's +eta-expansion, and eta-expanding a join point is fraught with issues like how to +deal with a cast: + + let join $j1 :: IO () + $j1 = ... + $j2 :: Int -> IO () + $j2 n = if n > 0 then $j1 + else ... + + => + + let join $j1 :: IO () + $j1 = (\eta -> ...) + `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) + ~ IO () + $j2 :: Int -> IO () + $j2 n = (\eta -> if n > 0 then $j1 + else ...) + `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) + ~ IO () + +The cast here can't be pushed inside the lambda (since it's not casting to a +function type), so the lambda has to stay, but it can't because it contains a +reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather +than try and detect this situation (and whatever other situations crop up!), we +don't bother; again, any surrounding eta-expansion will improve these join +points anyway, since an outer cast can *always* be pushed inside. By the time +CorePrep comes around, the code is very likely to look more like this: + + let join $j1 :: State# RealWorld -> (# State# RealWorld, ()) + $j1 = (...) eta + $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ()) + $j2 = if n > 0 then $j1 + else (...) eta + +Note [Arity for recursive join bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = joinrec j 0 = \ a b c -> (a,x,b) + j n = j (n-1) + in j 20 + +Obviously `f` should get arity 4. But it's a bit tricky: + +1. Remember, we don't eta-expand join points; see + Note [Do not eta-expand join points]. + +2. But even though we aren't going to eta-expand it, we still want `j` to get + idArity=4, via the findRhsArity fixpoint. Then when we are doing findRhsArity + for `f`, we'll call arityType on f's RHS: + - At the letrec-binding for `j` we'll whiz up an arity-4 ArityType + for `j` (See Note [arityType for non-recursive let-bindings] + in GHC.Core.Opt.Arity)b + - At the occurrence (j 20) that arity-4 ArityType will leave an arity-3 + result. + +3. All this, even though j's /join-arity/ (stored in the JoinId) is 1. + This is is the Main Reason that we want the idArity to sometimes be + larger than the join-arity c.f. Note [Invariants on join points] item 2b + in GHC.Core. + +4. Be very careful of things like this (#21755): + g x = let j 0 = \y -> (x,y) + j n = expensive n `seq` j (n-1) + in j x + Here we do /not/ want eta-expand `g`, lest we duplicate all those + (expensive n) calls. + + But it's fine: the findRhsArity fixpoint calculation will compute arity-1 + for `j` (not arity 2); and that's just what we want. But we do need that + fixpoint. + + Historical note: an earlier version of GHC did a hack in which we gave + join points an ArityType of ABot, but that did not work with this #21755 + case. + +5. arityType does not usually expect to encounter free join points; + see GHC.Core.Opt.Arity Note [No free join points in arityType]. + But consider + f x = join j1 y = .... in + joinrec j2 z = ...j1 y... in + j2 v + + When doing findRhsArity on `j2` we'll encounter the free `j1`. + But that is fine, because we aren't going to eta-expand `j2`; + we just want to know its arity. So we have a flag am_no_eta, + switched on when doing findRhsArity on a join point RHS. If + the flag is on, we allow free join points, but not otherwise. + + +Note [Arity for non-recursive join bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Arity for recursive join bindings] deals with recursive join +bindings. But what about /non-recursive/ones? If we just call +findRhsArity, it will call arityType. And that can be expensive when +we have deeply nested join points: + join j1 x1 = join j2 x2 = join j3 x3 = blah3 + in blah2 + in blah1 +(e.g. test T18698b). + +So we call cheapArityType instead. It's good enough for practical +purposes. + +(Side note: maybe we should use cheapArity for the RHS of let bindings +in the main arityType function.) +-} + + +{- ********************************************************************* +* * + arityType +* * +********************************************************************* -} + +arityLam :: Id -> ArityType -> ArityType +arityLam id (AT oss div) + = AT ((IsCheap, one_shot) : oss) div + where + one_shot | isDeadEndDiv div = OneShotLam + | otherwise = idStateHackOneShotInfo id + -- If the body diverges, treat it as one-shot: no point + -- in floating out, and no penalty for floating in + -- See Wrinkle [Bottoming functions] in Note [ArityType] + +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 + +addWork :: ArityType -> ArityType +-- Add work to the outermost level of the arity type +addWork at@(AT lams div) + = case lams of + [] -> at + lam:lams' -> AT (add_work lam : lams') div + +add_work :: ATLamInfo -> ATLamInfo +add_work (_,os) = (IsExpensive,os) + +arityApp :: ArityType -> Cost -> ArityType +-- Processing (fun arg) where at is the ArityType of fun, +-- Knock off an argument and behave like 'let' +arityApp (AT ((ch1,_):oss) div) ch2 = floatIn (ch1 `addCost` ch2) (AT oss div) +arityApp at _ = at + +-- | Least upper bound in the 'ArityType' lattice. +-- See the haddocks on 'ArityType' for the lattice. +-- +-- Used for branches of a @case@. +andArityType :: ArityEnv -> ArityType -> ArityType -> ArityType +andArityType env (AT (lam1:lams1) div1) (AT (lam2:lams2) div2) + | AT lams' div' <- andArityType env (AT lams1 div1) (AT lams2 div2) + = AT ((lam1 `and_lam` lam2) : lams') div' + where + (ch1,os1) `and_lam` (ch2,os2) + = ( ch1 `addCost` ch2, os1 `bestOneShot` os2) + -- bestOneShot: see Note [Combining case branches: optimistic one-shot-ness] + +andArityType env (AT [] div1) at2 = andWithTail env div1 at2 +andArityType env at1 (AT [] div2) = andWithTail env div2 at1 + +andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType +andWithTail env div1 at2@(AT lams2 _) + | isDeadEndDiv div1 -- case x of { T -> error; F -> \y.e } + = at2 -- See Note + | pedanticBottoms env -- [Combining case branches: andWithTail] + = AT [] topDiv + + | otherwise -- case x of { T -> plusInt ; F -> \y.e } + = AT (map add_work lams2) topDiv -- We know div1 = topDiv + -- See Note [Combining case branches: andWithTail] + +{- Note [Combining case branches: optimistic one-shot-ness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When combining the ArityTypes for two case branches (with +andArityType) and both ArityTypes have ATLamInfo, then we just combine +their expensive-ness and one-shot info. The tricky point is when we +have + + case x of True -> \x{one-shot). blah1 + Fale -> \y. blah2 + +Since one-shot-ness is about the /consumer/ not the /producer/, we +optimistically assume that if either branch is one-shot, we combine +the best of the two branches, on the (slightly dodgy) basis that if we +know one branch is one-shot, then they all must be. Surprisingly, +this means that the one-shot arity type is effectively the top element +of the lattice. + +Hence the call to `bestOneShot` in `andArityType`. + +Here's an example: + go = \x. let z = go e0 + go2 = \x. case x of + True -> z + False -> \s(one-shot). e1 + in go2 x + +We *really* want to respect the one-shot annotation provided by the +user and eta-expand go and go2. In the first fixpoint iteration of +'go' we'll bind 'go' to botArityType (written \.⊥, see Note +[ArityType]). So 'z' will get arityType \.⊥; so we end up combining +the True and False branches: + + \.⊥ `andArityType` \1.T + +That gives \1.T (see Note [Combining case branches: andWithTail], +first bullet). So 'go2' gets an arityType of \(C?)(C1).T, which is +what we want. + +Note [Combining case branches: andWithTail] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When combining the ArityTypes for two case branches (with andArityType) +and one side or the other has run out of ATLamInfo; then we get +into `andWithTail`. + +* If one branch is guaranteed bottom (isDeadEndDiv), we just take + the other. Consider case x of + True -> \x. error "urk" + False -> \xy. error "urk2" + + Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely + diverge". So we need \??.⊥ for the whole thing, the /max/ of both + arities. + +* Otherwise, if pedantic-bottoms is on, we just have to return + AT [] topDiv. E.g. if we have + f x z = case x of True -> \y. blah + False -> z + then we can't eta-expand, because that would change the behaviour + of (f False bottom(). + +* But if pedantic-bottoms is not on, we allow ourselves to push + `z` under a lambda (much as we allow ourselves to put the `case x` + under a lambda). However we know nothing about the expensiveness + or one-shot-ness of `z`, so we'd better assume it looks like + (Expensive, NoOneShotInfo) all the way. Remembering + Note [Combining case branches: optimistic one-shot-ness], + we just add work to ever ATLamInfo, keeping the one-shot-ness. + +Note [Eta expanding through CallStacks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Just as it's good to eta-expand through dictionaries, so it is good to +do so through CallStacks. #20103 is a case in point, where we got + foo :: HasCallStack => Int -> Int + foo = \(d::CallStack). let d2 = pushCallStack blah d in + \(x:Int). blah + +We really want to eta-expand this! #20103 is quite convincing! +We do this regardless of -fdicts-cheap; it's not really a dictionary. + +Note [Eta expanding through dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the experimental -fdicts-cheap flag is on, we eta-expand through +dictionary bindings. This improves arities. Thereby, it also +means that full laziness is less prone to floating out the +application of a function to its dictionary arguments, which +can thereby lose opportunities for fusion. Example: + foo :: Ord a => a -> ... + foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... + -- So foo has arity 1 + + f = \x. foo dInt $ bar x + +The (foo DInt) is floated out, and makes ineffective a RULE + foo (bar x) = ... + +One could go further and make exprIsCheap reply True to any +dictionary-typed expression, but that's more work. +-} + +--------------------------- + +data ArityEnv + = AE { am_opts :: !ArityOpts + + , am_sigs :: !(IdEnv SafeArityType) + -- NB `SafeArityType` so we can use this in myIsCheapApp + -- See Note [Arity analysis] for details about fixed-point iteration. + + , am_free_joins :: !Bool -- True <=> free join points allowed + -- Used /only/ to support assertion checks + } + +instance Outputable ArityEnv where + ppr (AE { am_sigs = sigs, am_free_joins = free_joins }) + = text "AE" <+> braces (sep [ text "free joins:" <+> ppr free_joins + , text "sigs:" <+> ppr sigs ]) + +-- | The @ArityEnv@ used by 'findRhsArity'. +findRhsArityEnv :: ArityOpts -> Bool -> ArityEnv +findRhsArityEnv opts free_joins + = AE { am_opts = opts + , am_free_joins = free_joins + , am_sigs = emptyVarEnv } + +freeJoinsOK :: ArityEnv -> Bool +freeJoinsOK (AE { am_free_joins = free_joins }) = free_joins + +-- First some internal functions in snake_case for deleting in certain VarEnvs +-- of the ArityType. Don't call these; call delInScope* instead! + +modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv +modifySigEnv f env@(AE { am_sigs = sigs }) = env { am_sigs = f sigs } +{-# INLINE modifySigEnv #-} + +del_sig_env :: Id -> ArityEnv -> ArityEnv -- internal! +del_sig_env id = modifySigEnv (\sigs -> delVarEnv sigs id) +{-# INLINE del_sig_env #-} + +del_sig_env_list :: [Id] -> ArityEnv -> ArityEnv -- internal! +del_sig_env_list ids = modifySigEnv (\sigs -> delVarEnvList sigs ids) +{-# INLINE del_sig_env_list #-} + +-- end of internal deletion functions + +extendSigEnv :: ArityEnv -> Id -> SafeArityType -> ArityEnv +extendSigEnv env id ar_ty + = modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) $ + env + +delInScope :: ArityEnv -> Id -> ArityEnv +delInScope env id = del_sig_env id env + +delInScopeList :: ArityEnv -> [Id] -> ArityEnv +delInScopeList env ids = del_sig_env_list ids env + +lookupSigEnv :: ArityEnv -> Id -> Maybe SafeArityType +lookupSigEnv (AE { am_sigs = sigs }) id = lookupVarEnv sigs id + +-- | Whether the analysis should be pedantic about bottoms. +-- 'exprBotStrictness_maybe' always is. +pedanticBottoms :: ArityEnv -> Bool +pedanticBottoms (AE { am_opts = ArityOpts{ ao_ped_bot = ped_bot }}) = ped_bot + +exprCost :: ArityEnv -> CoreExpr -> Maybe Type -> Cost +exprCost env e mb_ty + | myExprIsCheap env e mb_ty = IsCheap + | otherwise = IsExpensive + +-- | A version of 'exprIsCheap' that considers results from arity analysis +-- and optionally the expression's type. +-- Under 'exprBotStrictness_maybe', no expressions are cheap. +myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool +myExprIsCheap (AE { am_opts = opts, am_sigs = sigs }) e mb_ty + = cheap_dict || cheap_fun e + where + cheap_dict = case mb_ty of + Nothing -> False + Just ty -> (ao_dicts_cheap opts && isDictTy ty) + || isCallStackPredTy ty + -- See Note [Eta expanding through dictionaries] + -- See Note [Eta expanding through CallStacks] + + cheap_fun e = exprIsCheapX (myIsCheapApp sigs) e + +-- | A version of 'isCheapApp' that considers results from arity analysis. +-- See Note [Arity analysis] for what's in the signature environment and why +-- it's important. +myIsCheapApp :: IdEnv SafeArityType -> CheapAppFun +myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of + + -- Nothing means not a local function, fall back to regular + -- 'GHC.Core.Utils.isCheapApp' + Nothing -> isCheapApp fn n_val_args + + -- `Just at` means local function with `at` as current SafeArityType. + -- NB the SafeArityType bit: that means we can ignore the cost flags + -- in 'lams', and just consider the length + -- Roughly approximate what 'isCheapApp' is doing. + Just (AT lams div) + | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils + | n_val_args == 0 -> True -- Essentially + | n_val_args < length lams -> True -- isWorkFreeApp + | otherwise -> False + +---------------- +arityType :: HasDebugCallStack => ArityEnv -> CoreExpr -> ArityType +-- Precondition: all the free join points of the expression +-- are bound by the ArityEnv +-- See Note [No free join points in arityType] +-- +-- Returns ArityType, not SafeArityType. The caller must do +-- trimArityType if necessary. +arityType env (Var v) + | Just at <- lookupSigEnv env v -- Local binding + = at + | otherwise + = assertPpr (freeJoinsOK env || not (isJoinId v)) (ppr v) $ + -- All join-point should be in the ae_sigs + -- See Note [No free join points in arityType] + idArityType v + +arityType env (Cast e _) + = arityType env e + + -- Lambdas; increase arity +arityType env (Lam x e) + | isId x = arityLam x (arityType env' e) + | otherwise = arityType env' e + where + env' = delInScope env x + + -- Applications; decrease arity, except for types +arityType env (App fun (Type _)) + = arityType env fun +arityType env (App fun arg ) + = arityApp fun_at arg_cost + where + fun_at = arityType env fun + arg_cost = exprCost env arg Nothing + + -- Case/Let; keep arity if either the expression is cheap + -- or it's a 1-shot lambda + -- The former is not really right for Haskell + -- f x = case x of { (a,b) -> \y. e } + -- ===> + -- 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 + + | 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) + +arityType env (Let (NonRec b rhs) e) + = -- See Note [arityType for non-recursive let-bindings] + floatIn rhs_cost (arityType env' e) + where + rhs_cost = exprCost env rhs (Just (idType b)) + env' = extendSigEnv env b (safeArityType (arityType env rhs)) + +arityType env (Let (Rec prs) e) + = -- See Note [arityType for recursive let-bindings] + floatIn (allCosts bind_cost prs) (arityType env' e) + where + bind_cost (b,e) = exprCost env' e (Just (idType b)) + env' = foldl extend_rec env prs + extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv + extend_rec env (b,_) = extendSigEnv env b $ + idArityType b + -- See Note [arityType for recursive let-bindings] + +arityType env (Tick t e) + | not (tickishIsCode t) = arityType env e + +arityType _ _ = topArityType + +-------------------- +idArityType :: Id -> ArityType +idArityType v + | strict_sig <- idDmdSig v + , (ds, div) <- splitDmdSig strict_sig + , isDeadEndDiv div + = AT (takeList ds one_shots) div + + | isEmptyTy id_ty + = botArityType + + | otherwise + = AT (take (idArity v) one_shots) topDiv + where + id_ty = idType v + + one_shots :: [(Cost,OneShotInfo)] -- One-shot-ness derived from the type + one_shots = repeat IsCheap `zip` typeOneShots id_ty + +-------------------- +cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType +-- A fast and cheap version of arityType. +-- Returns an ArityType with IsCheap everywhere +-- c.f. GHC.Core.Utils.exprIsDeadEnd +-- +-- /Can/ encounter a free join-point Id; e.g. via the call +-- in exprBotStrictness_maybe, which is called in lots +-- of places +-- +-- Returns ArityType, not SafeArityType. The caller must do +-- trimArityType if necessary. +cheapArityType e = go e + where + go (Var v) = idArityType v + go (Cast e _) = go e + go (Lam x e) | isId x = arityLam x (go e) + | otherwise = go e + go (App e a) | isTypeArg a = go e + | otherwise = arity_app a (go e) + + go (Tick t e) | not (tickishIsCode t) = go e + + -- Null alts: see Note [Empty case alternatives] in GHC.Core + go (Case _ _ _ alts) | null alts = botArityType + + -- Give up on let, case. In particular, unlike arityType, + -- we make no attempt to look inside let's. + go _ = topArityType + + -- Specialised version of arityApp; all costs in ArityType are IsCheap + -- See Note [exprArity for applications] + -- NB: (1) coercions count as a value argument + -- (2) we use the super-cheap exprIsTrivial rather than the + -- more complicated and expensive exprIsCheap + arity_app _ at@(AT [] _) = at + arity_app arg at@(AT ((cost,_):lams) div) + | assertPpr (cost == IsCheap) (ppr at $$ ppr arg) $ + isDeadEndDiv div = AT lams div + | exprIsTrivial arg = AT lams topDiv + | otherwise = topArityType + +--------------- +exprArity :: CoreExpr -> Arity +-- ^ An approximate, even faster, version of 'cheapArityType' +-- Roughly exprArity e = arityTypeArity (cheapArityType e) +-- But it's a bit less clever about bottoms +-- +-- We do /not/ guarantee that exprArity e <= typeArity e +-- You may need to do arity trimming after calling exprArity +-- See Note [Arity trimming] +-- Reason: if we do arity trimming here we have take exprType +-- and that can be expensive if there is a large cast +exprArity e = go e + where + go (Var v) = idArity v + go (Lam x e) | isId x = go e + 1 + | otherwise = go e + go (Tick t e) | not (tickishIsCode t) = go e + go (Cast e _) = go e + go (App e (Type _)) = go e + go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 + -- See Note [exprArity for applications] + -- NB: coercions count as a value argument + + go _ = 0 + +--------------- +exprIsDeadEnd :: CoreExpr -> Bool +-- See Note [Bottoming expressions] +-- This function is, in effect, just a specialised (and hence cheap) +-- version of cheapArityType: +-- exprIsDeadEnd e = case cheapArityType e of +-- AT lams div -> null lams && isDeadEndDiv div +-- See also exprBotStrictness_maybe, which uses cheapArityType +exprIsDeadEnd e + = go 0 e + where + go :: Arity -> CoreExpr -> Bool + -- (go n e) = True <=> expr applied to n value args is bottom + go _ (Lit {}) = False + go _ (Type {}) = False + go _ (Coercion {}) = False + go n (App e a) | isTypeArg a = go n e + | otherwise = go (n+1) e + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (Let _ e) = go n e + go n (Lam v e) | isTyVar v = go n e + | otherwise = False + + go _ (Case _ _ _ alts) = null alts + -- See Note [Empty case alternatives] in GHC.Core + + go n (Var v) | isDeadEndAppSig (idDmdSig v) n = True + | isEmptyTy (idType v) = True + | otherwise = False + +{- Note [Bottoming expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A bottoming expression is guaranteed to diverge, or raise an +exception. We can test for it in two different ways, and exprIsDeadEnd +checks for both of these situations: + +* Visibly-bottom computations. For example + (error Int "Hello") + is visibly bottom. The strictness analyser also finds out if + a function diverges or raises an exception, and puts that info + in its strictness signature. + +* Empty types. If a type is empty, its only inhabitant is bottom. + For example: + data T + f :: T -> Bool + f = \(x:t). case x of Bool {} + Since T has no data constructors, the case alternatives are of course + empty. However note that 'x' is not bound to a visibly-bottom value; + it's the *type* that tells us it's going to diverge. + +A GADT may also be empty even though it has constructors: + data T a where + T1 :: a -> T Bool + T2 :: T Int + ...(case (x::T Char) of {})... +Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), +which is likewise uninhabited. + +Note [No free join points in arityType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we call arityType on this expression (EX1) + \x . case x of True -> \y. e + False -> $j 3 +where $j is a join point. It really makes no sense to talk of the arity +of this expression, because it has a free join point. In particular, we +can't eta-expand the expression because we'd have do the same thing to the +binding of $j, and we can't see that binding. + +If we had (EX2) + \x. join $j y = blah + case x of True -> \y. e + False -> $j 3 +then it would make perfect sense: we can determine $j's ArityType, and +propagate it to the usage site as usual. + +But how can we get (EX1)? It doesn't make much sense, because $j can't +be a join point under the \x anyway. So we make it a precondition of +arityType that the argument has no free join-point Ids. (This is checked +with an assert in the Var case of arityType.) + +Wrinkles + +* We /do/ allow free join point when doing findRhsArity for join-point + right-hand sides. See Note [Arity for recursive join bindings] + point (5) in GHC.Core.Opt.Simplify.Utils. + +* The invariant (no free join point in arityType) risks being + invalidated by one very narrow special case: runRW# + + join $j y = blah + runRW# (\s. case x of True -> \y. e + False -> $j x) + + We have special magic in OccurAnal, and Simplify to allow continuations to + move into the body of a runRW# call. + + So we are careful never to attempt to eta-expand the (\s.blah) in the + argument to runRW#, at least not when there is a literal lambda there, + so that OccurAnal has seen it and allowed join points bound outside. + See Note [No eta-expansion in runRW#] in GHC.Core.Opt.Simplify.Iteration. + +Note [arityType for non-recursive let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For non-recursive let-bindings, we just get the arityType of the RHS, +and extend the environment. That works nicely for things like this +(#18793): + go = \ ds. case ds_a2CF of { + [] -> id + : y ys -> case y of { GHC.Types.I# x -> + let acc = go ys in + case x ># 42# of { + __DEFAULT -> acc + 1# -> \x1. acc (negate x2) + +Here we want to get a good arity for `acc`, based on the ArityType +of `go`. + +All this is particularly important for join points. Consider this (#18328) + + f x = join j y = case y of + True -> \a. blah + False -> \b. blah + in case x of + A -> j True + B -> \c. blah + C -> j False + +and suppose the join point is too big to inline. Now, what is the +arity of f? If we inlined the join point, we'd definitely say "arity +2" because we are prepared to push case-scrutinisation inside a +lambda. It's important that we extend the envt with j's ArityType, so +that we can use that information in the A/C branch of the case. + +Note [arityType for recursive let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For /recursive/ bindings it's more difficult, to call arityType +(as we do in Note [arityType for non-recursive let-bindings]) +because we don't have an ArityType to put in the envt for the +recursively bound Ids. So for we satisfy ourselves with whizzing up +up an ArityType from the idArity of the function, via idArityType. + +That is nearly equivalent to deleting the binder from the envt, at +which point we'll call idArityType at the occurrences. But doing it +here means + + (a) we only call idArityType once, no matter how many + occurrences, and + + (b) we can check (in the arityType (Var v) case) that + we don't mention free join-point Ids. See + Note [No free join points in arityType]. + +But see Note [Arity for recursive join bindings] in +GHC.Core.Opt.Simplify.Utils for dark corners. +-} + +{- +%************************************************************************ +%* * + The main eta-expander +%* * +%************************************************************************ + +We go for: + f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym + (n >= 0) + +where (in both cases) + + * The xi can include type variables + + * The yi are all value variables + + * N is a NORMAL FORM (i.e. no redexes anywhere) + wanting a suitable number of extra args. + +The biggest reason for doing this is for cases like + + f = \x -> case x of + True -> \y -> e1 + False -> \y -> e2 + +Here we want to get the lambdas together. A good example is the nofib +program fibheaps, which gets 25% more allocation if you don't do this +eta-expansion. + +We may have to sandwich some coerces between the lambdas +to make the types work. exprEtaExpandArity looks through coerces +when computing arity; and etaExpand adds the coerces as necessary when +actually computing the expansion. + +Note [No crap in eta-expanded code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The eta expander is careful not to introduce "crap". In particular, +given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it +returns a CoreExpr satisfying the same invariant. See Note [Eta +expansion and the CorePrep invariants] in CorePrep. + +This means the eta-expander has to do a bit of on-the-fly +simplification but it's not too hard. The alternative, of relying on +a subsequent clean-up phase of the Simplifier to de-crapify the result, +means you can't really use it in CorePrep, which is painful. + +Note [Eta expansion for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The no-crap rule is very tiresome to guarantee when +we have join points. Consider eta-expanding + let j :: Int -> Int -> Bool + j x = e + in b + +The simple way is + \(y::Int). (let j x = e in b) y + +The no-crap way is + \(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 +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. + +(Moreover, I think that casts can make the no-crap rule fail too.) + +Note [Eta expansion and SCCs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that SCCs are not treated specially by etaExpand. If we have + etaExpand 2 (\x -> scc "foo" e) + = (\xy -> (scc "foo" e) y) +So the costs of evaluating 'e' (not 'e y') are attributed to "foo" + +Note [Eta expansion and source notes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CorePrep puts floatable ticks outside of value applications, but not +type applications. As a result we might be trying to eta-expand an +expression like + + (src<...> v) @a + +which we want to lead to code like + + \x -> src<...> v @a x + +This means that we need to look through type applications and be ready +to re-add floats on the top. + +Note [Eta expansion with ArityType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The etaExpandAT function takes an ArityType (not just an Arity) to +guide eta-expansion. Why? Because we want to preserve one-shot info. +Consider + foo = \x. case x of + True -> (\s{os}. blah) |> co + False -> wubble +We'll get an ArityType for foo of \?1.T. + +Then we want to eta-expand to + foo = (\x. \eta{os}. (case x of ...as before...) eta) |> some_co + +That 'eta' binder is fresh, and we really want it to have the +one-shot flag from the inner \s{os}. By expanding with the +ArityType gotten from analysing the RHS, we achieve this neatly. + +This makes a big difference to the one-shot monad trick; +see Note [The one-shot state monad trick] in GHC.Utils.Monad. +-} + +-- | @etaExpand n e@ returns an expression with +-- the same meaning as @e@, but with arity @n@. +-- +-- Given: +-- +-- > e' = etaExpand n e +-- +-- We should have that: +-- +-- > ty = exprType e = exprType e' + +etaExpand :: Arity -> CoreExpr -> CoreExpr +etaExpand n orig_expr + = eta_expand in_scope (replicate n NoOneShotInfo) orig_expr + where + in_scope = {-#SCC "eta_expand:in-scopeX" #-} + mkInScopeSet (exprFreeVars orig_expr) + +etaExpandAT :: InScopeSet -> SafeArityType -> CoreExpr -> CoreExpr +-- See Note [Eta expansion with ArityType] +-- +-- We pass in the InScopeSet from the simplifier to avoid recomputing +-- it here, which can be jolly expensive if the casts are big +-- In #18223 it took 10% of compile time just to do the exprFreeVars! +etaExpandAT in_scope at orig_expr + = eta_expand in_scope (arityTypeOneShots at) orig_expr + +-- etaExpand arity e = res +-- Then 'res' has at least 'arity' lambdas at the top +-- possibly with a cast wrapped around the outside +-- See Note [Eta expansion with ArityType] +-- +-- etaExpand deals with for-alls. For example: +-- etaExpand 1 E +-- where E :: forall a. a -> a +-- would return +-- (/\b. \y::a -> E b y) + +eta_expand :: InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr +eta_expand in_scope one_shots (Cast expr co) + = mkCast (eta_expand in_scope one_shots expr) co + -- This mkCast is important, because eta_expand might return an + -- expression with a cast at the outside; and tryCastWorkerWrapper + -- asssumes that we don't have nested casts. Makes a difference + -- in compile-time for T18223 + +eta_expand in_scope one_shots orig_expr + = go in_scope one_shots [] orig_expr + where + -- Strip off existing lambdas and casts before handing off to mkEtaWW + -- This is mainly to avoid spending time cloning binders and substituting + -- when there is actually nothing to do. It's slightly awkward to deal + -- with casts here, apart from the topmost one, and they are rare, so + -- if we find one we just hand off to mkEtaWW anyway + -- Note [Eta expansion and SCCs] + go _ [] _ _ = orig_expr -- Already has the specified arity; no-op + + go in_scope oss@(_:oss1) vs (Lam v body) + | isTyVar v = go (in_scope `extendInScopeSet` v) oss (v:vs) body + | otherwise = go (in_scope `extendInScopeSet` v) oss1 (v:vs) body + + go in_scope oss rev_vs expr + = -- pprTrace "ee" (vcat [ppr in_scope', ppr top_bndrs, ppr eis]) $ + retick $ + etaInfoAbs top_eis $ + etaInfoApp in_scope' sexpr eis + where + (in_scope', eis@(EI eta_bndrs mco)) + = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr) + top_bndrs = reverse rev_vs + top_eis = EI (top_bndrs ++ eta_bndrs) (mkPiMCos top_bndrs mco) + + -- Find ticks behind type apps. + -- See Note [Eta expansion and source notes] + -- I don't really understand this code SLPJ May 21 + (expr', args) = collectArgs expr + (ticks, expr'') = stripTicksTop tickishFloatable expr' + sexpr = mkApps expr'' args + retick expr = foldr mkTick expr ticks + +{- ********************************************************************* +* * + The EtaInfo mechanism + mkEtaWW, etaInfoAbs, etaInfoApp +* * +********************************************************************* -} + +{- Note [The EtaInfo mechanism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (e :: ty) and we want to eta-expand it to arity N. +This what eta_expand does. We do it in two steps: + +1. mkEtaWW: from 'ty' and 'N' build a EtaInfo which describes + the shape of the expansion necessary to expand to arity N. + +2. Build the term + \ v1..vn. e v1 .. vn + where those abstractions and applications are described by + the same EtaInfo. Specifically we build the term + + etaInfoAbs etas (etaInfoApp in_scope e etas) + + where etas :: EtaInfo + etaInfoAbs builds the lambdas + etaInfoApp builds the applications + + 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 + newtype N a = MkN (S -> a) + axN :: N a ~ S -> a +and + e :: N (N Int) +then the eta-expansion should look like + (\(x::S) (y::S) -> (e |> co) x y) |> sym co +where + co :: N (N Int) ~ S -> S -> Int + co = axN @(N Int) ; (S -> axN @Int) + +We want to get one cast, at the top, to account for all those +nested newtypes. This is expressed by the EtaInfo type: + + data EtaInfo = EI [Var] MCoercionR + +Note [Check for reflexive casts in eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It turns out that the casts created by the above mechanism are often Refl. +When casts are very deeply nested (as happens in #18223), the repetition +of types can make the overall term very large. So there is a big +payoff in cancelling out casts aggressively wherever possible. +(See also Note [No crap in eta-expanded code].) + +This matters particularly in etaInfoApp, where we +* Do beta-reduction on the fly +* Use getArg_maybe to get a cast out of the way, + so that we can do beta reduction +Together this makes a big difference. Consider when e is + case x of + True -> (\x -> e1) |> c1 + False -> (\p -> e2) |> c2 + +When we eta-expand this to arity 1, say, etaInfoAbs will wrap +a (\eta) around the outside and use etaInfoApp to apply each +alternative to 'eta'. We want to beta-reduce all that junk +away. + +#18223 was a dramatic example in which the intermediate term was +grotesquely huge, even though the next Simplifier iteration squashed +it. Better to kill it at birth. + +The crucial spots in etaInfoApp are: +* `checkReflexiveMCo` in the (Cast e co) case of `go` +* `checkReflexiveMCo` in `pushCoArg` +* Less important: checkReflexiveMCo in the final case of `go` +Collectively these make a factor-of-5 difference to the total +allocation of T18223, so take care if you change this stuff! + +Example: + newtype N = MkN (Y->Z) + f :: X -> N + f = \(x::X). ((\(y::Y). blah) |> fco) + +where fco :: (Y->Z) ~ N + +mkEtaWW makes an EtaInfo of (EI [(eta1:X), (eta2:Y)] eta_co + where + eta_co :: (X->N) ~ (X->Y->Z) + eta_co = ( -> nco) + nco :: N ~ (Y->Z) -- Comes from topNormaliseNewType_maybe + +Now, when we push that eta_co inward in etaInfoApp: +* In the (Cast e co) case, the 'fco' and 'nco' will meet, and + should cancel. +* When we meet the (\y.e) we want no cast on the y. + +-} + +-------------- +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 + +instance Outputable EtaInfo where + ppr (EI vs mco) = text "EI" <+> ppr vs <+> parens (ppr mco) + + +etaInfoApp :: InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr +-- (etaInfoApp s e (EI bs mco) returns something equivalent to +-- ((substExpr s e) |> mco b1 .. bn) +-- See Note [The EtaInfo mechanism] +-- +-- NB: With very deeply nested casts, this function can be expensive +-- In T18223, this function alone costs 15% of allocation, all +-- spent in the calls to substExprSC and substBindSC + +etaInfoApp in_scope expr eis + = go (mkEmptySubst in_scope) expr eis + where + go :: Subst -> CoreExpr -> EtaInfo -> CoreExpr + -- 'go' pushed down the eta-infos into the branch of a case + -- and the body of a let; and does beta-reduction if possible + -- go subst fun co [b1,..,bn] returns (subst(fun) |> co) b1 .. bn + go subst (Tick t e) eis + = Tick (substTickish subst t) (go subst e eis) + + go subst (Cast e co) (EI bs mco) + = go subst e (EI bs mco') + where + mco' = checkReflexiveMCo (Core.substCo subst co `mkTransMCoR` mco) + -- See Note [Check for reflexive casts in eta expansion] + + go subst (Case e b ty alts) eis + = Case (Core.substExprSC subst e) b1 ty' alts' + where + (subst1, b1) = Core.substBndr subst b + alts' = map subst_alt alts + ty' = etaInfoAppTy (substTyUnchecked subst ty) eis + subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis) + where + (subst2,bs') = Core.substBndrs subst1 bs + + go subst (Let b e) eis + | not (isJoinBind b) -- See Note [Eta expansion for join points] + = Let b' (go subst' e eis) + where + (subst', b') = Core.substBindSC subst b + + -- Beta-reduction if possible, pushing any intervening casts past + -- the argument. See Note [The EtaInfo mechanism] + go subst (Lam v e) (EI (b:bs) mco) + | Just (arg,mco') <- pushMCoArg mco (varToCoreExpr b) + = go (Core.extendSubst subst v arg) e (EI bs mco') + + -- Stop pushing down; just wrap the expression up + -- See Note [Check for reflexive casts in eta expansion] + go subst e (EI bs mco) = Core.substExprSC subst e + `mkCastMCo` checkReflexiveMCo mco + `mkVarApps` bs + +-------------- +etaInfoAppTy :: Type -> EtaInfo -> Type +-- If e :: ty +-- then etaInfoApp e eis :: etaInfoApp ty eis +etaInfoAppTy ty (EI bs mco) + = applyTypeToArgs (text "etaInfoAppTy") ty1 (map varToCoreExpr bs) + where + ty1 = case mco of + MRefl -> ty + MCo co -> coercionRKind co + +-------------- +etaInfoAbs :: EtaInfo -> CoreExpr -> CoreExpr +-- See Note [The EtaInfo mechanism] +etaInfoAbs (EI bs mco) expr = (mkLams bs expr) `mkCastMCo` mkSymMCo mco + +-------------- +-- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding +-- an expression @e :: ty@ to take @n@ value arguments, where @fvs@ are the +-- free variables of @e@. +-- +-- Note that this function is entirely unconcerned about cost centres and other +-- semantically-irrelevant source annotations, so call sites must take care to +-- preserve that info. See Note [Eta expansion and SCCs]. +mkEtaWW + :: [OneShotInfo] + -- ^ How many value arguments to eta-expand + -> SDoc + -- ^ The pretty-printed original expression, for warnings. + -> InScopeSet + -- ^ A super-set of the free vars of the expression to eta-expand. + -> Type + -> (InScopeSet, EtaInfo) + -- ^ The variables in 'EtaInfo' are fresh wrt. to the incoming 'InScopeSet'. + -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the + -- fresh variables in 'EtaInfo'. + +mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty + = go 0 orig_oss empty_subst orig_ty + where + empty_subst = mkEmptySubst in_scope + + go :: Int -- For fresh names + -> [OneShotInfo] -- Number of value args to expand to + -> Subst -> Type -- We are really looking at subst(ty) + -> (InScopeSet, EtaInfo) + -- (go [o1,..,on] subst ty) = (in_scope, EI [b1,..,bn] co) + -- co :: subst(ty) ~ b1_ty -> ... -> bn_ty -> tr + + go _ [] subst _ + ----------- Done! No more expansion needed + = (getSubstInScope subst, EI [] MRefl) + + go n oss@(one_shot:oss1) subst ty + ----------- Forall types (forall a. ty) + | Just (tcv,ty') <- splitForAllTyCoVar_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)) + + ----------- Function types (t1 -> t2) + | Just (_af, mult, arg_ty, res_ty) <- splitFunTy_maybe ty + , typeHasFixedRuntimeRep arg_ty + -- See Note [Representation polymorphism invariants] in GHC.Core + -- See also test case typecheck/should_run/EtaExpandLevPoly + + , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty) + -- Avoid free vars of the original expression + + , let eta_id' = eta_id `setIdOneShotInfo` one_shot + , (in_scope, EI bs mco) <- go (n+1) oss1 subst' res_ty + = (in_scope, EI (eta_id' : bs) (mkFunResMCo eta_id' mco)) + + ----------- Newtypes + -- Given this: + -- newtype T = MkT ([T] -> Int) + -- Consider eta-expanding this + -- eta_expand 1 e T + -- We want to get + -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + | Just (co, ty') <- topNormaliseNewType_maybe ty + , -- co :: ty ~ ty' + let co' = Type.substCo subst co + -- Remember to apply the substitution to co (#16979) + -- (or we could have applied to ty, but then + -- we'd have had to zap it for the recursive call) + , (in_scope, EI bs mco) <- go n oss subst ty' + -- mco :: subst(ty') ~ b1_ty -> ... -> bn_ty -> tr + = (in_scope, EI bs (mkTransMCoR co' mco)) + + | otherwise -- We have an expression of arity > 0, + -- 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) + -- 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 + + +{- +************************************************************************ +* * + Eta reduction +* * +************************************************************************ + +Note [Eta reduction makes sense] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC's eta reduction transforms + \x y. x y ---> +We discuss when this is /sound/ in Note [Eta reduction soundness]. +But even assuming it is sound, when is it /desirable/. That +is what we discuss here. + +This test is made by `ok_fun` in tryEtaReduce. + +1. We want to eta-reduce only if we get all the way to a trivial + expression; we don't want to remove extra lambdas unless we are + going to avoid allocating this thing altogether. + + Trivial means *including* casts and type lambdas: + * `\x. f x |> co --> f |> (ty(x) -> co)` (provided `co` doesn't mention `x`) + * `/\a. \x. f @(Maybe a) x --> /\a. f @(Maybe a)` + See Note [Do not eta reduce PAPs] for why we insist on a trivial head. + +2. Type and dictionary abstraction. Regardless of whether 'f' is a value, it + is always sound to reduce /type lambdas/, thus: + (/\a -> f a) --> f + Moreover, we always want to, because it makes RULEs apply more often: + This RULE: `forall g. foldr (build (/\a -> g a))` + should match `foldr (build (/\b -> ...something complex...))` + and the simplest way to do so is eta-reduce `/\a -> g a` in the RULE to `g`. + + The type checker can insert these eta-expanded versions, + with both type and dictionary lambdas; hence the slightly + ad-hoc (all ok_lam bndrs) + +Of course, eta reduction is not always sound. See Note [Eta reduction soundness] +for when it is. + +When there are multiple arguments, we might get multiple eta-redexes. Example: + \x y. e x y + ==> { reduce \y. (e x) y in context \x._ } + \x. e x + ==> { reduce \x. e x in context _ } + e +And (1) implies that we never want to stop with `\x. e x`, because that is not a +trivial expression. So in practice, the implementation works by considering a +whole group of leading lambdas to reduce. + +These delicacies are why we don't simply use 'exprIsTrivial' and 'exprIsHNF' +in 'tryEtaReduce'. Alas. + +Note [Eta reduction soundness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC's eta reduction transforms + \x y. x y ---> +For soundness, we obviously require that `x` and `y` +to not occur free. But what /other/ restrictions are there for +eta reduction to be sound? + +We discuss separately what it means for eta reduction to be +/desirable/, in Note [Eta reduction makes sense]. + +Eta reduction is *not* a sound transformation in general, because it +may change termination behavior if *value* lambdas are involved: + `bot` /= `\x. bot x` (as can be observed by a simple `seq`) +The past has shown that oversight of this fact can not only lead to endless +loops or exceptions, but also straight out *segfaults*. + +Nevertheless, we can give the following criteria for when it is sound to +perform eta reduction on an expression with n leading lambdas `\xs. e xs` +(checked in 'is_eta_reduction_sound' in 'tryEtaReduce', which focuses on the +case where `e` is trivial): + + A. It is sound to eta-reduce n arguments as long as n does not exceed the + `exprArity` of `e`. (Needs Arity analysis.) + This criterion exploits information about how `e` is *defined*. + + Example: If `e = \x. bot` then we know it won't diverge until it is called + with one argument. Hence it is safe to eta-reduce `\x. e x` to `e`. + By contrast, it would be *unsound* to eta-reduce 2 args, `\x y. e x y` to `e`: + `e 42` diverges when `(\x y. e x y) 42` does not. + + S. It is sound to eta-reduce n arguments in an evaluation context in which all + calls happen with at least n arguments. (Needs Strictness analysis.) + NB: This treats evaluations like a call with 0 args. + NB: This criterion exploits information about how `e` is *used*. + + Example: Given a function `g` like + `g c = Just (c 1 2 + c 2 3)` + it is safe to eta-reduce the arg in `g (\x y. e x y)` to `g e` without + knowing *anything* about `e` (perhaps it's a parameter occ itself), simply + because `g` always calls its parameter with 2 arguments. + It is also safe to eta-reduce just one arg, e.g., `g (\x. e x)` to `g e`. + By contrast, it would *unsound* to eta-reduce 3 args in a call site + like `g (\x y z. e x y z)` to `g e`, because that diverges when + `e = \x y. bot`. + + Could we relax to "*At least one call in the same trace* is with n args"? + No. Consider what happens for + ``g2 c = c True `seq` c False 42`` + Here, `g2` will call `c` with 2 arguments (if there is a call at all). + But it is unsound to eta-reduce the arg in `g2 (\x y. e x y)` to `g2 e` + when `e = \x. if x then bot else id`, because the latter will diverge when + the former would not. Fortunately, the strictness analyser will report + "Not always called with two arguments" for `g2` and we won't eta-expand. + + See Note [Eta reduction based on evaluation context] for the implementation + details. This criterion is tested extensively in T21261. + + R. Note [Eta reduction in recursive RHSs] tells us that we should not + eta-reduce `f` in its own RHS and describes our fix. + There we have `f = \x. f x` and we should not eta-reduce to `f=f`. Which + might change a terminating program (think @f `seq` e@) to a non-terminating + one. + + E. (See fun_arity in tryEtaReduce.) As a perhaps special case on the + boundary of (A) and (S), when we know that a fun binder `f` is in + WHNF, we simply assume it has arity 1 and apply (A). Example: + g f = f `seq` \x. f x + Here it's sound eta-reduce `\x. f x` to `f`, because `f` can't be bottom + after the `seq`. This turned up in #7542. + +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. + + B. We may not undersaturate functions with no binding. + See Note [Eta expanding primops]. + + W. We may not undersaturate StrictWorkerIds. + See Note [CBV Function Ids] in GHC.Types.Id.Info. + +Here is a list of historic accidents surrounding unsound eta-reduction: + +* Consider + f = \x.f x + h y = case (case y of { True -> f `seq` True; False -> False }) of + True -> ...; False -> ... + If we (unsoundly) eta-reduce f to get f=f, the strictness analyser + says f=bottom, and replaces the (f `seq` True) with just + (f `cast` unsafe-co). + [SG in 2022: I don't think worker/wrapper would do this today.] + BUT, as things stand, 'f' got arity 1, and it *keeps* arity 1 (perhaps also + wrongly). So CorePrep eta-expands the definition again, so that it does not + terminate after all. + Result: seg-fault because the boolean case actually gets a function value. + See #1947. + +* Never *reduce* arity. For example + f = \xy. g x y + Then if h has arity 1 we don't want to eta-reduce because then + f's arity would decrease, and that is bad + [SG in 2022: I don't understand this point. There is no `h`, perhaps that + should have been `g`. Even then, this proposed eta-reduction is invalid by + criterion (A), which might actually be the point this anecdote is trying to + make. Perhaps the "no arity decrease" idea is also related to + Note [Arity robustness]?] + +Note [Do not eta reduce PAPs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I considered eta-reducing if the result is a PAP: + \x. f e1 e2 x ==> f e1 e2 + +This reduces clutter, sometimes a lot. See Note [Do not eta-expand PAPs] +in GHC.Core.Opt.Simplify.Utils, where we are careful not to eta-expand +a PAP. If eta-expanding is bad, then eta-reducing is good! + +Also the code generator likes eta-reduced PAPs; see GHC.CoreToStg.Prep +Note [No eta reduction needed in rhsToBody]. + +But note that we don't want to eta-reduce + \x y. f x y +to + f +The former has arity 2, and repeats for every call of the +function; the latter has arity 0, and shares . We don't want +to change behaviour. Hence the call to exprIsCheap in ok_fun. + +I noticed this when examining #18993 and, although it is delicate, +eta-reducing to a PAP happens to fix the regression in #18993. + +HOWEVER, if we transform + \x. f y x ==> f y +that might mean that f isn't saturated any more, and does not inline. +This led to some other regressions. + +TL;DR currently we do /not/ eta reduce if the result is a PAP. + +Note [Eta reduction with casted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (\(x:t3). f (x |> g)) :: t3 -> t2 + where + f :: t1 -> t2 + g :: t3 ~ t1 +This should be eta-reduced to + + f |> (sym g -> t2) + +So we need to accumulate a coercion, pushing it inward (past +variable arguments only) thus: + f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x + f (x:t) |> co --> (f |> (t -> co)) x + f @ a |> co --> (f |> (forall a.co)) @ a + f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) +These are the equations for ok_arg. + +Note [Eta reduction with casted function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since we are pushing a coercion inwards, it is easy to accommodate + (\xy. (f x |> g) y) + (\xy. (f x y) |> g) + +See the `(Cast e co)` equation for `go` in `tryEtaReduce`. The +eta-expander pushes those casts outwards, so you might think we won't +ever see a cast here, but if we have + \xy. (f x y |> g) +we will call tryEtaReduce [x,y] (f x y |> g), and we'd like that to +work. This happens in GHC.Core.Opt.Simplify.Utils.mkLam, where +eta-expansion may be turned off (by sm_eta_expand). + +Note [Eta reduction based on evaluation context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Eta reduction soundness], criterion (S) allows us to eta-reduce +`g (\x y. e x y)` to `g e` when we know that `g` always calls its parameter with +at least 2 arguments. So how do we read that off `g`'s demand signature? + +Let's take the simple example of #21261, where `g` (actually, `f`) is defined as + g c = c 1 2 + c 3 4 +Then this is how the pieces are put together: + + * Demand analysis infers `` for `g`'s demand signature + + * When the Simplifier next simplifies the argument in `g (\x y. e x y)`, it + looks up the *evaluation context* of the argument in the form of the + sub-demand `C(S,C(1,L))` and stores it in the 'SimplCont'. + (Why does it drop the outer evaluation cardinality of the demand, `S`? + Because it's irrelevant! When we simplify an expression, we do so under the + assumption that it is currently under evaluation.) + This sub-demand literally says "Whenever this expression is evaluated, it + is called with at least two arguments, potentially multiple times". + + * Then the simplifier takes apart the lambda and simplifies the lambda group + and then calls 'tryEtaReduce' when rebuilding the lambda, passing the + evaluation context `C(S,C(1,L))` along. Then we simply peel off 2 call + sub-demands `Cn` and see whether all of the n's (here: `S=C_1N` and + `1=C_11`) were strict. And strict they are! Thus, it will eta-reduce + `\x y. e x y` to `e`. + +Note [Eta reduction in recursive RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following recursive function: + f = \x. ....g (\y. f y).... +The recursive call of f in its own RHS seems like a fine opportunity for +eta-reduction because f has arity 1. And often it is! + +Alas, that is unsound in general if the eta-reduction happens in a tail context. +Making the arity visible in the RHS allows us to eta-reduce + f = \x -> f x +to + f = f +which means we optimise terminating programs like (f `seq` ()) into +non-terminating ones. Nor is this problem just for tail calls. Consider + f = id (\x -> f x) +where we have (for some reason) not yet inlined `id`. We must not eta-reduce to + f = id f +because that will then simplify to `f = f` as before. + +An immediate idea might be to look at whether the called function is a local +loopbreaker and refrain from eta-expanding. But that doesn't work for mutually +recursive function like in #21652: + f = g + g* x = f x +Here, g* is the loopbreaker but f isn't. + +What can we do? + +Fix 1: Zap `idArity` when analysing recursive RHSs and re-attach the info when + entering the let body. + Has the disadvantage that other transformations which make use of arity + (such as dropping of `seq`s when arity > 0) will no longer work in the RHS. + Plus it requires non-trivial refactorings to both the simple optimiser (in + the way `subst_opt_bndr` is used) as well as the Simplifier (in the way + `simplRecBndrs` and `simplRecJoinBndrs` is used), modifying the SimplEnv's + substitution twice in the process. A very complicated stop-gap. + +Fix 2: Pass the set of enclosing recursive binders to `tryEtaReduce`; these are + the ones we should not eta-reduce. All call-site must maintain this set. + Example: + rec { f1 = ....rec { g = ... (\x. g x)...(\y. f2 y)... }... + ; f2 = ...f1... } + when eta-reducing those inner lambdas, we need to know that we are in the + rec group for {f1, f2, g}. + This is very much like the solution in Note [Speculative evaluation] in + GHC.CoreToStg.Prep. + It is a bit tiresome to maintain this info, because it means another field + in SimplEnv and SimpleOptEnv. + +We implement Fix (2) because of it isn't as complicated to maintain as (1). +Plus, it is the correct fix to begin with. After all, the arity is correct, +but doing the transformation isn't. The moving parts are: + * A field `scRecIds` in `SimplEnv` tracks the enclosing recursive binders + * We extend the `scRecIds` set in `GHC.Core.Opt.Simplify.simplRecBind` + * We consult the set in `is_eta_reduction_sound` in `tryEtaReduce` +The situation is very similar to Note [Speculative evaluation] which has the +same fix. +-} + +-- | `tryEtaReduce [x,y,z] e sd` returns `Just e'` if `\x y z -> e` is evaluated +-- according to `sd` and can soundly and gainfully be eta-reduced to `e'`. +-- See Note [Eta reduction soundness] +-- and Note [Eta reduction makes sense] when that is the case. +tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> SubDemand -> Maybe CoreExpr +-- Return an expression equal to (\bndrs. body) +tryEtaReduce rec_ids bndrs body eval_sd + = go (reverse bndrs) body (mkRepReflCo (exprType body)) + where + incoming_arity = count isId bndrs -- See Note [Eta reduction makes sense], point (2) + + go :: [Var] -- Binders, innermost first, types [a3,a2,a1] + -> CoreExpr -- Of type tr + -> Coercion -- Of type tr ~ ts + -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts + -- See Note [Eta reduction with casted arguments] + -- for why we have an accumulating coercion + -- + -- Invariant: (go bs body co) returns an expression + -- equivalent to (\(reverse bs). (body |> co)) + + -- See Note [Eta reduction with casted function] + go bs (Cast e co1) co2 + = go bs e (co1 `mkTransCo` co2) + + go bs (Tick t e) co + | tickishFloatable t + = fmap (Tick t) $ go bs e co + -- Float app ticks: \x -> Tick t (e x) ==> Tick t e + + go (b : bs) (App fun arg) co + | Just (co', ticks) <- ok_arg b arg co (exprType fun) + = fmap (flip (foldr mkTick) ticks) $ go bs fun co' + -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e + + go remaining_bndrs fun co + | all isTyVar remaining_bndrs + -- If all the remaining_bnrs are tyvars, then the etad_exp + -- will be trivial, which is what we want. + -- e.g. We might have /\a \b. f [a] b, and we want to + -- eta-reduce to /\a. f [a] + -- We don't want to give up on this one: see #20040 + -- See Note [Eta reduction makes sense], point (1) + , remaining_bndrs `ltLength` bndrs + -- Only reply Just if /something/ has happened + , ok_fun fun + , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co + reduced_bndrs = mkVarSet (dropList remaining_bndrs bndrs) + -- reduced_bndrs are the ones we are eta-reducing away + , used_vars `disjointVarSet` reduced_bndrs + -- Check for any of the reduced_bndrs (about to be dropped) + -- free in the result, including the accumulated coercion. + -- See Note [Eta reduction makes sense], intro and point (1) + -- NB: don't compute used_vars from exprFreeVars (mkCast fun co) + -- because the latter may be ill formed if the guard fails (#21801) + = Just (mkLams (reverse remaining_bndrs) (mkCast fun co)) + + go _remaining_bndrs _fun _ = -- pprTrace "tER fail" (ppr _fun $$ ppr _remaining_bndrs) $ + Nothing + + --------------- + -- See Note [Eta reduction makes sense], point (1) + ok_fun (App fun (Type {})) = ok_fun fun + ok_fun (Cast fun _) = ok_fun fun + ok_fun (Tick _ expr) = ok_fun expr + ok_fun (Var fun_id) = is_eta_reduction_sound fun_id || all ok_lam bndrs + ok_fun _fun = False + + --------------- + -- See Note [Eta reduction soundness], this is THE place to check soundness! + is_eta_reduction_sound fun = + -- Don't eta-reduce in fun in its own recursive RHSs + not (fun `elemUnVarSet` rec_ids) -- criterion (R) + -- Check that eta-reduction won't make the program stricter... + && (fun_arity fun >= incoming_arity -- criterion (A) and (E) + || all_calls_with_arity incoming_arity) -- criterion (S) + -- ... and that the function can be eta reduced to arity 0 + -- without violating invariants of Core and GHC + && canEtaReduceToArity fun 0 0 -- criteria (L), (J), (W), (B) + all_calls_with_arity n = isStrict (fst $ peelManyCalls n eval_sd) + -- See Note [Eta reduction based on evaluation context] + + --------------- + fun_arity fun + | arity > 0 = arity + | isEvaldUnfolding (idUnfolding fun) = 1 + -- See Note [Eta reduction soundness], criterion (E) + | otherwise = 0 + where + arity = idArity fun + + --------------- + ok_lam v = isTyVar v || isEvVar v + -- See Note [Eta reduction makes sense], point (2) + + --------------- + ok_arg :: Var -- Of type bndr_t + -> CoreExpr -- Of type arg_t + -> Coercion -- Of kind (t1~t2) + -> Type -- Type (arg_t -> t1) of the function + -- to which the argument is supplied + -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) + -- (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 (Var v) co fun_ty + | bndr == v + , let mult = idMult bndr + , Just (_af, fun_mult, _, _) <- splitFunTy_maybe fun_ty + , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort + = Just (mkFunResCo Representational bndr co, []) + ok_arg bndr (Cast e co_arg) co fun_ty + | (ticks, Var v) <- stripTicksTop tickishFloatable e + , Just (_, fun_mult, _, _) <- splitFunTy_maybe fun_ty + , bndr == v + , fun_mult `eqType` idMult bndr + = Just (mkFunCoNoFTF Representational (multToCo fun_mult) (mkSymCo co_arg) co, ticks) + -- The simplifier combines multiple casts into one, + -- so we can have a simple-minded pattern match here + ok_arg bndr (Tick t arg) co fun_ty + | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty + = Just (co', t:ticks) + + ok_arg _ _ _ _ = Nothing + +-- | Can we eta-reduce the given function to the specified arity? +-- See Note [Eta reduction soundness], criteria (B), (J), (W) and (L). +canEtaReduceToArity :: Id -> JoinArity -> Arity -> Bool +canEtaReduceToArity fun dest_join_arity dest_arity = + not $ + hasNoBinding fun -- (B) + -- Don't undersaturate functions with no binding. + + || ( isJoinId fun && dest_join_arity < idJoinArity fun ) -- (J) + -- Don't undersaturate join points. + -- See Note [Invariants on join points] in GHC.Core, and #20599 + + || ( dest_arity < idCbvMarkArity fun ) -- (W) + -- 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" +* * +************************************************************************ + +Here we implement the "push rules" from FC papers: + +* The push-argument rules, where we can move a coercion past an argument. + We have + (fun |> co) arg + and we want to transform it to + (fun arg') |> co' + for some suitable co' and transformed arg'. + +* The PushK rule for data constructors. We have + (K e1 .. en) |> co + and we want to transform to + (K e1' .. en') + by pushing the coercion into the arguments +-} + +pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion) +pushCoArgs co [] = return ([], MCo co) +pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg + ; case m_co1 of + MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args + ; return (arg':args', m_co2) } + MRefl -> return (arg':args, MRefl) } + +pushMCoArg :: MCoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) +pushMCoArg MRefl arg = Just (arg, MRefl) +pushMCoArg (MCo co) arg = pushCoArg co arg + +pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) +-- We have (fun |> co) arg, and we want to transform it to +-- (fun arg) |> co +-- This may fail, e.g. if (fun :: N) where N is a newtype +-- C.f. simplCast in GHC.Core.Opt.Simplify +-- 'co' is always Representational +pushCoArg co arg + | Type ty <- arg + = do { (ty', m_co') <- pushCoTyArg co ty + ; return (Type ty', m_co') } + | otherwise + = do { (arg_mco, m_co') <- pushCoValArg co + ; let arg_mco' = checkReflexiveMCo arg_mco + -- checkReflexiveMCo: see Note [Check for reflexive casts in eta expansion] + -- The coercion is very often (arg_co -> res_co), but without + -- the argument coercion actually being ReflCo + ; return (arg `mkCastMCo` arg_mco', m_co') } + +pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR) +-- We have (fun |> co) @ty +-- Push the coercion through to return +-- (fun @ty') |> co' +-- 'co' is always Representational +-- If the returned coercion is Nothing, then it would have been reflexive; +-- it's faster not to compute it, though. +pushCoTyArg co ty + -- The following is inefficient - don't do `eqType` here, the coercion + -- optimizer will take care of it. See #14737. + -- -- | tyL `eqType` tyR + -- -- = Just (ty, Nothing) + + | isReflCo co + = Just (ty, MRefl) + + | isForAllTy_ty tyL + = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $ + Just (ty `mkCastTy` co1, MCo co2) + + | otherwise + = Nothing + where + Pair tyL tyR = coercionKind co + -- co :: tyL ~R tyR + -- tyL = forall (a1 :: k1). ty1 + -- tyR = forall (a2 :: k2). ty2 + + co1 = mkSymCo (mkSelCo SelForAll co) + -- co1 :: k2 ~N k1 + -- Note that SelCo extracts a Nominal equality between the + -- kinds of the types related by a coercion between forall-types. + -- See the SelCo case in GHC.Core.Lint. + + co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1) + -- co2 :: ty1[ (ty|>co1)/a1 ] ~R ty2[ ty/a2 ] + -- Arg of mkInstCo is always nominal, hence Nominal + +-- | If @pushCoValArg co = Just (co_arg, co_res)@, then +-- +-- > (\x.body) |> co = (\y. let { x = y |> co_arg } in body) |> co_res) +-- +-- or, equivalently +-- +-- > (fun |> co) arg = (fun (arg |> co_arg)) |> co_res +-- +-- If the LHS is well-typed, then so is the RHS. In particular, the argument +-- @arg |> co_arg@ is guaranteed to have a fixed 'RuntimeRep', in the sense of +-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR) +pushCoValArg co + -- The following is inefficient - don't do `eqType` here, the coercion + -- optimizer will take care of it. See #14737. + -- -- | tyL `eqType` tyR + -- -- = Just (mkRepReflCo arg, Nothing) + + | isReflCo co + = Just (MRefl, MRefl) + + | isFunTy tyL + , (co_mult, co1, co2) <- decomposeFunCo co + -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) + -- then co1 :: tyL1 ~ tyR1 + -- co2 :: tyL2 ~ tyR2 + + , isReflexiveCo co_mult + -- We can't push the coercion in the case where co_mult isn't reflexivity: + -- it could be an unsafe axiom, and losing this information could yield + -- ill-typed terms. For instance (fun x ::(1) Int -> (fun _ -> () |> co) x) + -- with co :: (Int -> ()) ~ (Int %1 -> ()), would reduce to (fun x ::(1) Int + -- -> (fun _ ::(Many) Int -> ()) x) which is ill-typed. + + , typeHasFixedRuntimeRep new_arg_ty + -- We can't push the coercion inside if it would give rise to + -- a representation-polymorphic argument. + + = assertPpr (isFunTy tyL && isFunTy tyR) + (vcat [ text "co:" <+> ppr co + , text "old_arg_ty:" <+> ppr old_arg_ty + , text "new_arg_ty:" <+> ppr new_arg_ty ]) $ + Just (coToMCo (mkSymCo co1), coToMCo co2) + -- Critically, coToMCo to checks for ReflCo; the whole coercion may not + -- be reflexive, but either of its components might be + -- We could use isReflexiveCo, but it's not clear if the benefit + -- is worth the cost, and it makes no difference in #18223 + + | otherwise + = Nothing + where + old_arg_ty = funArgTy tyR + new_arg_ty = funArgTy tyL + Pair tyL tyR = coercionKind co + +pushCoercionIntoLambda + :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) +-- This implements the Push rule from the paper on coercions +-- (\x. e) |> co +-- ===> +-- (\x'. e |> co') +pushCoercionIntoLambda in_scope x e co + | assert (not (isTyVar x) && not (isCoVar x)) True + , Pair s1s2 t1t2 <- coercionKind co + , Just {} <- splitFunTy_maybe s1s2 + , Just (_, w1, t1,_t2) <- splitFunTy_maybe t1t2 + , (co_mult, co1, co2) <- decomposeFunCo co + , isReflexiveCo co_mult + -- We can't push the coercion in the case where co_mult isn't + -- reflexivity. See pushCoValArg for more details. + , typeHasFixedRuntimeRep t1 + -- We can't push the coercion into the lambda if it would create + -- a representation-polymorphic binder. + = let + -- Should we optimize the coercions here? + -- Otherwise they might not match too well + x' = x `setIdType` t1 `setIdMult` w1 + in_scope' = in_scope `extendInScopeSet` x' + subst = extendIdSubst (mkEmptySubst in_scope') + x + (mkCast (Var x') (mkSymCo co1)) + -- We substitute x' for x, except we need to preserve types. + -- The types are as follows: + -- x :: s1, x' :: t1, co1 :: s1 ~# t1, + -- so we extend the substitution with x |-> (x' |> sym co1). + in Just (x', substExpr subst e `mkCast` co2) + | otherwise + = Nothing + +pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion + -> 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 +-- 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) + + | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty + , to_tc == dataConTyCon dc + -- These two tests can fail; we might see + -- (C x y) `cast` (g :: T a ~ S [a]), + -- where S is a type function. In fact, exprIsConApp + -- will probably not be called in such circumstances, + -- but there's nothing wrong with it + + = let + tc_arity = tyConArity to_tc + dc_univ_tyvars = dataConUnivTyVars dc + dc_ex_tcvars = dataConExTyCoVars dc + arg_tys = dataConRepArgTys dc + + 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) + + -- 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) + + 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) ] + 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) + + | otherwise + = Nothing + + where + Pair from_ty to_ty = coercionKind co + +collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) +-- Collect lambda binders, pushing coercions inside if possible +-- E.g. (\x.e) |> g g :: -> blah +-- = (\x. e |> SelCo (SelFun SelRes) g) +-- +-- That is, +-- +-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> SelCo (SelFun SelRes) g) +collectBindersPushingCo e + = go [] e + where + -- Peel off lambdas until we hit a cast. + go :: [Var] -> CoreExpr -> ([Var], CoreExpr) + -- The accumulator is in reverse order + go bs (Lam b e) = go (b:bs) e + go bs (Cast e co) = go_c bs e co + go bs e = (reverse bs, e) + + -- We are in a cast; peel off casts until we hit a lambda. + go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr) + -- (go_c bs e c) is same as (go bs e (e |> c)) + go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) + go_c bs (Lam b e) co = go_lam bs b e co + go_c bs e co = (reverse bs, mkCast e co) + + -- We are in a lambda under a cast; peel off lambdas and build a + -- new coercion for the body. + go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr) + -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) + go_lam bs b e co + | isTyVar b + , let Pair tyL tyR = coercionKind co + , assert (isForAllTy_ty tyL) $ + isForAllTy_ty tyR + , isReflCo (mkSelCo SelForAll co) -- See Note [collectBindersPushingCo] + = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) + + | isCoVar b + , let Pair tyL tyR = coercionKind co + , assert (isForAllTy_co tyL) $ + isForAllTy_co tyR + , isReflCo (mkSelCo SelForAll co) -- See Note [collectBindersPushingCo] + , let cov = mkCoVarCo b + = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov))) + + | isId b + , let Pair tyL tyR = coercionKind co + , assert (isFunTy tyL) $ isFunTy tyR + , (co_mult, co_arg, co_res) <- decomposeFunCo co + , isReflCo co_mult -- See Note [collectBindersPushingCo] + , isReflCo co_arg -- See Note [collectBindersPushingCo] + = go_c (b:bs) e co_res + + | otherwise = (reverse bs, mkCast (Lam b e) co) + +{- + +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. + +-} + +{- ********************************************************************* +* * + Join points +* * +********************************************************************* -} + +------------------- +-- | Split an expression into the given number of binders and a body, +-- eta-expanding if necessary. Counts value *and* type binders. +etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr) +etaExpandToJoinPoint join_arity expr + = go join_arity [] expr + where + go 0 rev_bs e = (reverse rev_bs, e) + go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e + go n rev_bs e = case etaBodyForJoinPoint n e of + (bs, e') -> (reverse rev_bs ++ bs, e') + +etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule +etaExpandToJoinPointRule _ rule@(BuiltinRule {}) + = warnPprTrace True "Can't eta-expand built-in rule:" (ppr rule) + -- How did a local binding get a built-in rule anyway? Probably a plugin. + rule +etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs + , ru_args = args }) + | need_args == 0 + = rule + | need_args < 0 + = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule) + | otherwise + = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args + , ru_rhs = new_rhs } + where + need_args = join_arity - length args + (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs + new_args = varsToCoreExprs new_bndrs + +-- 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 + where + go 0 _ _ rev_bs e + = (reverse rev_bs, e) + go n ty subst rev_bs e + | Just (tv, res_ty) <- splitForAllTyCoVar_maybe ty + , let (subst', tv') = substVarBndr subst tv + = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv') + -- The varToCoreExpr is important: `tv` might be a coercion variable + + | Just (_, mult, arg_ty, res_ty) <- splitFunTy_maybe ty + , let (subst', b) = freshEtaId n subst (Scaled mult arg_ty) + = go (n-1) res_ty subst' (b : rev_bs) (e `App` varToCoreExpr b) + -- The varToCoreExpr is important: `b` might be a coercion variable + + | otherwise + = pprPanic "etaBodyForJoinPoint" $ int need_args $$ + ppr body $$ ppr (exprType body) + + init_subst e = mkEmptySubst (mkInScopeSet (exprFreeVars e)) + + + +-------------- +freshEtaId :: Int -> Subst -> Scaled Type -> (Subst, Id) +-- Make a fresh Id, with specified type (after applying substitution) +-- It should be "fresh" in the sense that it's not in the in-scope set +-- of the TvSubstEnv; and it should itself then be added to the in-scope +-- set of the TvSubstEnv +-- +-- The Int is just a reasonable starting point for generating a unique; +-- it does not necessarily have to be unique itself. +freshEtaId n subst ty + = (subst', eta_id') + where + Scaled mult' ty' = Type.substScaledTyUnchecked subst ty + eta_id' = uniqAway (getSubstInScope subst) $ + mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) mult' ty' + -- "OrCoVar" since this can be used to eta-expand + -- coercion abstractions + subst' = extendSubstInScope subst eta_id' 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 @@ -4,11 +4,6 @@ \section{Common subexpression} -} - - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where import GHC.Prelude @@ -19,7 +14,7 @@ import GHC.Types.Id ( Id, idType, idHasRules, zapStableUnfolding , idInlineActivation, setInlineActivation , zapIdOccInfo, zapIdUsageInfo, idInlinePragma - , isJoinId, isJoinId_maybe ) + , isJoinId, isJoinId_maybe, idUnfolding ) import GHC.Core.Utils ( mkAltExpr , exprIsTickedString , stripTicksE, stripTicksT, mkTicks ) @@ -32,6 +27,7 @@ import GHC.Core.Map.Expr import GHC.Utils.Misc ( filterOut, equalLength ) import GHC.Utils.Panic +import Data.Functor.Identity ( Identity (..) ) import Data.List ( mapAccumL ) {- @@ -144,7 +140,7 @@ the binding instead? Well, not at top level! See Note [Top level and postInlineUnconditionally] in GHC.Core.Opt.Simplify.Utils; and in any case CSE applies only to the /bindings/ of the program, and we leave -it to the simplifier to propate effects to the RULES. Finally, it +it to the simplifier to propagate effects to the RULES. Finally, it doesn't seem worth the effort to discard the nested bindings because the simplifier will do it next. @@ -228,7 +224,7 @@ might replace by 'bar', and then later be unable to see that it really was . -An except to the rule is when the INLINE pragma is not from the user, e.g. from +An exception to the rule is when the INLINE pragma is not from the user, e.g. from WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec is then true. @@ -262,28 +258,32 @@ but now bar's inlining behaviour will change, and importing modules might see that. So it seems dodgy and we don't do it. -Stable unfoldings are also created during worker/wrapper when we decide -that a function's definition is so small that it should always inline. -In this case we still want to do CSE (#13340). Hence the use of -isAnyInlinePragma rather than isStableUnfolding. +Wrinkles -Now consider - foo = - bar {-# Unf = Stable ... #-} - = +* Stable unfoldings are also created during worker/wrapper when we + decide that a function's definition is so small that it should + always inline, or indeed for the wrapper function itself. In this + case we still want to do CSE (#13340). Hence the use of + isStableUserUnfolding/isStableSystemUnfolding rather than + isStableUnfolding. -where the unfolding was added by strictness analysis, say. Then -CSE goes ahead, so we get - bar = foo -and probably use SUBSTITUTE that will make 'bar' dead. But just -possibly not -- see Note [Dealing with ticks]. In that case we might -be left with - bar = tick t1 (tick t2 foo) -in which case we would really like to get rid of the stable unfolding -(generated by the strictness analyser, say). Hence the zapStableUnfolding -in cse_bind. Not a big deal, and only makes a difference when ticks -get into the picture. +* Consider + foo = + bar {-# Unf = Stable ... #-} + = + where the unfolding was added by strictness analysis, say. Then + CSE goes ahead, so we get + bar = foo + and probably use SUBSTITUTE that will make 'bar' dead. But just + possibly not -- see Note [Dealing with ticks]. In that case we might + be left with + bar = tick t1 (tick t2 foo) + in which case we would really like to get rid of the stable unfolding + (generated by the strictness analyser, say). + Hence the zapStableUnfolding in cse_bind. Not a big deal, and only + makes a difference when ticks get into the picture. + Note [Corner case for case expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is another reason that we do not use SUBSTITUTE for @@ -291,8 +291,8 @@ case x |> co of (y::Array# Int) { ... } We do not want to extend the substitution with (y -> x |> co); since y -is of unlifted type, this would destroy the let/app invariant if (x |> -co) was not ok-for-speculation. +is of unlifted type, this would destroy the let-can-float invariant if +(x |> co) was not ok-for-speculation. But surely (x |> co) is ok-for-speculation, because it's a trivial expression, and x's type is also unlifted, presumably. Well, maybe @@ -356,7 +356,7 @@ Note [Separate envs for let rhs and body] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Substituting occurances of the binder in the rhs with the +Substituting occurrences of the binder in the rhs with the renamed binder is wrong for non-recursive bindings. Why? Consider this core. @@ -408,7 +408,7 @@ = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')]) where - (env1, [out_id]) = addRecBinders env [in_id] + (env1, Identity out_id) = addRecBinders env (Identity in_id) rhs' = cseExpr env1 rhs rhs'' = stripTicksE tickishFloatable rhs' ticks = stripTicksT tickishFloatable rhs' @@ -508,14 +508,17 @@ -- | Given a binder `let x = e`, this function -- determines whether we should add `e -> x` to the cs_map noCSE :: InId -> Bool -noCSE id = not (isAlwaysActive (idInlineActivation id)) && - not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id))) - -- See Note [CSE for INLINE and NOINLINE] - || isAnyInlinePragma (idInlinePragma id) - -- See Note [CSE for stable unfoldings] - || isJoinId id - -- See Note [CSE for join points?] - +noCSE id + | isJoinId id = no_cse -- See Note [CSE for join points?] + | isStableUserUnfolding unf = no_cse -- See Note [CSE for stable unfoldings] + | user_activation_control = no_cse -- See Note [CSE for INLINE and NOINLINE] + | otherwise = yes_cse + where + unf = idUnfolding id + user_activation_control = not (isAlwaysActive (idInlineActivation id)) + && not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id))) + yes_cse = False + no_cse = True {- Note [Take care with literal strings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -696,7 +699,7 @@ where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) } cseExpr :: CSEnv -> InExpr -> OutExpr -cseExpr env (Type t) = Type (substTy (csEnvSubst env) t) +cseExpr env (Type t) = Type (substTyUnchecked (csEnvSubst env) t) cseExpr env (Coercion c) = Coercion (substCo (csEnvSubst env) c) cseExpr _ (Lit lit) = Lit lit cseExpr env (Var v) = lookupSubst env v @@ -714,7 +717,7 @@ = Case scrut1 bndr3 ty' $ combineAlts (map cse_alt alts) where - ty' = substTy (csEnvSubst env) ty + ty' = substTyUnchecked (csEnvSubst env) ty (cse_done, scrut1) = try_for_cse env scrut bndr1 = zapIdOccInfo bndr @@ -810,7 +813,7 @@ W y z -> e2 In the simplifier we use cheapEqExpr, because it is called a lot. -But here in CSE we use the full eqExpr. After all, two alternatives usually +But here in CSE we use the full eqCoreExpr. After all, two alternatives usually differ near the root, so it probably isn't expensive to compare the full alternative. It seems like the same kind of thing that CSE is supposed to be doing, which is why I put it here. @@ -909,7 +912,8 @@ where (sub', vs') = substBndrs (cs_subst cse) vs -addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) -addRecBinders cse vs = (cse { cs_subst = sub' }, vs') - where - (sub', vs') = substRecBndrs (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') +{-# 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 @@ -150,7 +150,7 @@ any useful co-call information. Return (fv e)² * Case alternatives alt₁,alt₂,...: - Only one can be execuded, so + Only one can be executed, so Return (alt₁ ∪ alt₂ ∪...) * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂: We get the results from both sides, with the argument evaluated at most once. @@ -277,7 +277,7 @@ Note [Analysis type signature] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The work-hourse of the analysis is the function `callArityAnal`, with the +The workhorse of the analysis is the function `callArityAnal`, with the following type: type CallArityRes = (UnVarGraph, VarEnv Arity) @@ -377,15 +377,14 @@ CallArityRes (the co-call graph is the complete graph, all arityies 0). Note [Trimming arity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - +~~~~~~~~~~~~~~~~~~~~~ In the Call Arity papers, we are working on an untyped lambda calculus with no other id annotations, where eta-expansion is always possible. But this is not the case for Core! 1. We need to ensure the invariant callArity e <= typeArity (exprType e) for the same reasons that exprArity needs this invariant (see Note - [exprArity invariant] in GHC.Core.Opt.Arity). + [typeArity invariants] in GHC.Core.Opt.Arity). If we are not doing that, a too-high arity annotation will be stored with the id, confusing the simplifier later on. @@ -544,7 +543,7 @@ -- Which bindings should we look at? -- See Note [Which variables are interesting] isInteresting :: Var -> Bool -isInteresting v = not $ null (typeArity (idType v)) +isInteresting v = typeArity (idType v) > 0 interestingBinds :: CoreBind -> [Var] interestingBinds = filter isInteresting . bindersOf @@ -700,7 +699,7 @@ trimArity :: Id -> Arity -> Arity trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig] where - max_arity_by_type = length (typeArity (idType v)) + max_arity_by_type = typeArity (idType v) max_arity_by_strsig | isDeadEndDiv result_info = length demands | otherwise = a @@ -729,7 +728,7 @@ resDel v (!g, !ae) = (g `delNode` v, ae `delVarEnv` v) domRes :: CallArityRes -> UnVarSet -domRes (_, ae) = varEnvDom ae +domRes (_, ae) = varEnvDomain ae -- In the result, find out the minimum arity and whether the variable is called -- at most once. 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 @@ -27,12 +27,10 @@ import GHC.Prelude import GHC.Utils.Outputable as Outputable import GHC.Driver.Session -import GHC.Driver.Ppr import GHC.Types.CostCentre import GHC.Types.CostCentre.State import GHC.Types.Name hiding (varName) import GHC.Types.Tickish -import GHC.Unit.Module.Name import GHC.Unit.Module.ModGuts import GHC.Types.SrcLoc import GHC.Types.Var @@ -44,6 +42,8 @@ import qualified GHC.Utils.Binary as B import Data.Char +import Language.Haskell.Syntax.Module.Name + addCallerCostCentres :: ModGuts -> CoreM ModGuts addCallerCostCentres guts = do dflags <- getDynFlags @@ -52,7 +52,7 @@ env = Env { thisModule = mg_module guts , ccState = newCostCentreState - , dflags = dflags + , countEntries = gopt Opt_ProfCountEntries dflags , revParents = [] , filters = filters } @@ -78,13 +78,13 @@ hcat (punctuate dot (map ppr (parents env))) <> parens (text "calling:" <> ppr v) ccName :: CcName - ccName = mkFastString $ showSDoc (dflags env) nameDoc + ccName = mkFastString $ renderWithContext defaultSDocContext nameDoc ccIdx <- getCCIndex' ccName - let count = gopt Opt_ProfCountEntries (dflags env) + let count = countEntries env span = case revParents env of top:_ -> nameSrcSpan $ varName top _ -> noSrcSpan - cc = NormalCC (ExprCC ccIdx) ccName (thisModule env) span + cc = NormalCC (mkExprCCFlavour ccIdx) ccName (thisModule env) span tick :: CoreTickish tick = ProfNote cc count True pure $ Tick tick e @@ -109,7 +109,7 @@ data Env = Env { thisModule :: Module - , dflags :: DynFlags + , countEntries :: !Bool , ccState :: CostCentreState , revParents :: [Id] , filters :: [CallerCcFilter] 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 @@ -34,7 +34,7 @@ import GHC.Platform -import GHC.Types.Id.Make ( voidPrimId ) +import GHC.Types.Id.Make ( unboxedUnitExpr ) import GHC.Types.Id import GHC.Types.Literal import GHC.Types.Name.Occurrence ( occNameFS ) @@ -46,10 +46,12 @@ import GHC.Core.Make import GHC.Core.SimpleOpt ( exprIsConApp_maybe, exprIsLiteral_maybe ) import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) -import GHC.Core.Utils ( cheapEqExpr, exprIsHNF, exprType +import GHC.Core.Utils ( cheapEqExpr, exprIsHNF , stripTicksTop, stripTicksTopT, mkTicks ) import GHC.Core.Multiplicity +import GHC.Core.Rules.Config import GHC.Core.Type +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCon ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon , isNewTyCon, tyConDataCons @@ -69,7 +71,6 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Trace import Control.Applicative ( Alternative(..) ) import Control.Monad @@ -419,15 +420,14 @@ [Lit (LitNumber _ l1), Lit (LitNumber _ l2)] <- getArgs platform <- getPlatform let r = l1 * l2 - pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy] + pure $ mkCoreUnboxedTuple [ Lit (if platformInIntRange platform r then zeroi platform else onei platform) , mkIntLitWrap platform (r `shiftR` platformWordSizeInBits platform) , mkIntLitWrap platform r ] , zeroElem >>= \z -> - pure (mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy] - [z,z,z]) + pure (mkCoreUnboxedTuple [z,z,z]) -- timesInt2# 1# other -- ~~~> @@ -436,7 +436,7 @@ -- repeated to fill a word. , identityPlatform onei >>= \other -> do platform <- getPlatform - pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy] + pure $ mkCoreUnboxedTuple [ Lit (zeroi platform) , mkCoreApps (Var (primOpId IntSubOp)) [ Lit (zeroi platform) @@ -999,8 +999,7 @@ retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr retLitNoC l = do platform <- getPlatform let lit = l platform - let ty = literalType lit - return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi platform)] + return $ mkCoreUnboxedTuple [Lit lit, Lit (zeroi platform)] word8Op2 :: (Integral a, Integral b) @@ -1095,9 +1094,8 @@ -------------------------- floatDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr floatDecodeOp env (LitFloat ((decodeFloat . fromRational @Float) -> (m, e))) - = Just $ mkCoreUbxTup [intPrimTy, intPrimTy] - [ mkIntVal (roPlatform env) (toInteger m) - , mkIntVal (roPlatform env) (toInteger e) ] + = Just $ mkCoreUnboxedTuple [ mkIntVal (roPlatform env) (toInteger m) + , mkIntVal (roPlatform env) (toInteger e) ] floatDecodeOp _ _ = Nothing @@ -1112,9 +1110,8 @@ -------------------------- doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e))) - = Just $ mkCoreUbxTup [int64PrimTy, intPrimTy] - [ Lit (mkLitInt64Wrap (toInteger m)) - , mkIntVal platform (toInteger e) ] + = Just $ mkCoreUnboxedTuple [ Lit (mkLitInt64Wrap (toInteger m)) + , mkIntVal platform (toInteger e) ] where platform = roPlatform env doubleDecodeOp _ _ @@ -1221,9 +1218,8 @@ -- Integer is in the target Int range and the corresponding overflow flag -- (@0#@/@1#@) if it wasn't. intCResult :: Platform -> Integer -> Maybe CoreExpr -intCResult platform result = Just (mkPair [Lit lit, Lit c]) +intCResult platform result = Just (mkCoreUnboxedTuple [Lit lit, Lit c]) where - mkPair = mkCoreUbxTup [intPrimTy, intPrimTy] (lit, b) = mkLitIntWrapC platform result c = if b then onei platform else zeroi platform @@ -1263,9 +1259,8 @@ -- Integer is in the target Word range and the corresponding carry flag -- (@0#@/@1#@) if it wasn't. wordCResult :: Platform -> Integer -> Maybe CoreExpr -wordCResult platform result = Just (mkPair [Lit lit, Lit c]) +wordCResult platform result = Just (mkCoreUnboxedTuple [Lit lit, Lit c]) where - mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy] (lit, b) = mkLitWordWrapC platform result c = if b then onei platform else zeroi platform @@ -1282,7 +1277,7 @@ word64Result' result = Lit (mkLitWord64Wrap result) --- | 'ambiant (primop x) = x', but not nececesarily 'primop (ambient x) = x'. +-- | 'ambient (primop x) = x', but not necessarily 'primop (ambient x) = x'. semiInversePrimOp :: PrimOp -> RuleM CoreExpr semiInversePrimOp primop = do [Var primop_id `App` e] <- getArgs @@ -1409,11 +1404,11 @@ let x = I# (error "invalid shift") in ... -This was originally done in the fix to #16449 but this breaks the let/app -invariant (see Note [Core let/app 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 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 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. Consequently we instead take advantage of the fact that large shifts are undefined behavior (see associated documentation in primops.txt.pp) and @@ -1619,7 +1614,7 @@ [Lit l1, e2] <- getArgs guard $ l1 == id_lit platform let no_c = Lit (zeroi platform) - return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c]) + return (mkCoreUnboxedTuple [e2, no_c]) rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr rightIdentityPlatform id_lit = do @@ -1636,7 +1631,7 @@ [e1, Lit l2] <- getArgs guard $ l2 == id_lit platform let no_c = Lit (zeroi platform) - return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c]) + return (mkCoreUnboxedTuple [e1, no_c]) identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr identityPlatform lit = @@ -1811,7 +1806,7 @@ -- See Note [tagToEnum#] _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $ - return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" + return $ mkImpossibleExpr ty "tagToEnum# on non-enumeration type" ------------------------------ dataToTagRule :: RuleM CoreExpr @@ -1830,12 +1825,12 @@ -- dataToTag x -- where x's unfolding is a constructor application b = do - dflags <- getPlatform + platform <- getPlatform [_, val_arg] <- getArgs in_scope <- getInScopeEnv (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg massert (not (isNewTyCon (dataConTyCon dc))) - return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc))) + return $ wrapFloats floats (mkIntVal platform (toInteger (dataConTagZ dc))) {- Note [dataToTag# magic] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1951,9 +1946,9 @@ seqRule :: RuleM CoreExpr seqRule = do - [Type ty_a, Type _ty_s, a, s] <- getArgs + [Type _ty_a, Type _ty_s, a, s] <- getArgs guard $ exprIsHNF a - return $ mkCoreUbxTup [exprType s, ty_a] [s, a] + return $ mkCoreUnboxedTuple [s, a] -- spark# :: forall a s . a -> State# s -> (# State# s, a #) sparkRule :: RuleM CoreExpr @@ -2098,10 +2093,10 @@ x <- isNaturalLiteral a0 y <- isNaturalLiteral a1 -- return an unboxed sum: (# (# #) | Natural #) - let ret n v = pure $ mkCoreUbxSum 2 n [unboxedUnitTy,naturalTy] v + let ret n v = pure $ mkCoreUnboxedSum 2 n [unboxedUnitTy,naturalTy] v platform <- getPlatform if x < y - then ret 1 $ Var voidPrimId + then ret 1 unboxedUnitExpr else ret 2 $ mkNaturalExpr platform (x - y) -- unary operations @@ -2131,12 +2126,12 @@ , divop_one "integerRem" integerRemName rem mkIntegerExpr , divop_one "integerDiv" integerDivName div mkIntegerExpr , divop_one "integerMod" integerModName mod mkIntegerExpr - , divop_both "integerDivMod" integerDivModName divMod mkIntegerExpr integerTy - , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr integerTy + , divop_both "integerDivMod" integerDivModName divMod mkIntegerExpr + , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr , divop_one "naturalQuot" naturalQuotName quot mkNaturalExpr , divop_one "naturalRem" naturalRemName rem mkNaturalExpr - , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr naturalTy + , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr -- conversions from Rational for Float/Double literals , rational_to "rationalToFloat" rationalToFloatName mkFloatExpr @@ -2238,7 +2233,7 @@ -- We use a host Int to compute the popCount. If we compile on a 32-bit -- host for a 64-bit target, the result may be different than if computed -- by the target. So we disable this rule if sizes don't match. - guard (platformWordSizeInBits platform == finiteBitSize (0 :: Word)) + guard (platformWordSizeInBits platform <= finiteBitSize (0 :: Word)) [a0] <- getArgs x <- isBignumLiteral a0 pure $ Lit (mk_lit platform (fromIntegral (popCount x))) @@ -2286,14 +2281,14 @@ platform <- getPlatform pure $ mk_lit platform (n `divop` d) - divop_both str name divop mk_lit ty = mkRule str name 2 $ do + divop_both str name divop mk_lit = mkRule str name 2 $ do [a0,a1] <- getArgs n <- isBignumLiteral a0 d <- isBignumLiteral a1 guard (d /= 0) let (r,s) = n `divop` d platform <- getPlatform - pure $ mkCoreUbxTup [ty,ty] [mk_lit platform r, mk_lit platform s] + pure $ mkCoreUnboxedTuple [mk_lit platform r, mk_lit platform s] integer_encode_float :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule integer_encode_float str name mk_lit = mkRule str name 2 $ do @@ -2403,7 +2398,7 @@ -- Also, look into variable's unfolding just in case the expression we look for -- is in a top-level thunk. stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr) -stripStrTopTicks (_,id_unf) e = case e of +stripStrTopTicks (ISE _ id_unf) e = case e of Var v | Just rhs <- expandUnfolding_maybe (id_unf v) -> stripTicksTop tickishFloatable rhs @@ -2903,7 +2898,7 @@ andFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr andFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of - -- R2) * `or` `and` simplications + -- R2) * `or` `and` simplifications -- l1 and (l2 and x) ==> (l1 and l2) and x (L l1, is_lit_and num_ops -> Just (l2, x)) -> Just (mkL (l1 .&. l2) `and` x) @@ -2926,7 +2921,7 @@ orFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr orFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of - -- R2) * `or` `and` simplications + -- R2) * `or` `and` simplifications -- l1 or (l2 or x) ==> (l1 or l2) or x (L l1, is_lit_or num_ops -> Just (l2, x)) -> Just (mkL (l1 .|. l2) `or` x) 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 @@ -10,7 +10,7 @@ import GHC.Prelude -import GHC.Driver.Session +import GHC.Driver.Flags ( DumpFlag (..) ) import GHC.Builtin.Names ( runRWKey ) @@ -553,13 +553,16 @@ *workers*, because their transformers need to adapt to CPR for their arguments in 'cprTransformDataConWork' to enable Note [Nested CPR]. Better keep it all in this module! The alternative would be that - 'GHC.Types.Id.Make' depends on DmdAnal. + 'GHC.Types.Id.Make' depends on CprAnal. 3. In the future, Nested CPR could take a better account of incoming args in cprAnalApp and do some beta-reduction on the fly, like !1866 did. If any of those args had the CPR property, then we'd even get Nested CPR for DataCon wrapper calls, for free. Not so if we simply give the wrapper a single CPR sig in 'GHC.Types.Id.Make.mkDataConRep'! +DmdAnal also looks through the wrapper's unfolding: +See Note [DmdAnal for DataCon wrappers]. + Note [Trimming to mAX_CPR_SIZE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We do not treat very big tuples as CPR-ish: @@ -741,7 +744,7 @@ Note that - * Whether or not something unboxes is decided by 'wantToUnboxArg', else we may + * Whether or not something unboxes is decided by 'canUnboxArg', else we may get over-optimistic CPR results (e.g., from \(x :: a) -> x!). * If the demand unboxes deeply, we can give the binder a /nested/ CPR 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 @@ -31,2258 +31,2578 @@ 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.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.Builtin.PrimOps -import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) -import GHC.Types.Unique.Set -import GHC.Types.Unique.MemoFun - -import GHC.Utils.Trace -_ = pprTrace -- Tired of commenting out the import all the time - -{- -************************************************************************ -* * -\subsection{Top level stuff} -* * -************************************************************************ --} - --- | Options for the demand analysis -data DmdAnalOpts = DmdAnalOpts - { dmd_strict_dicts :: !Bool -- ^ Use strict dictionaries - , dmd_unbox_width :: !Int -- ^ Use strict dictionaries - , dmd_max_worker_args :: !Int - } - --- This is a strict alternative to (,) --- See Note [Space Leaks in Demand Analysis] -data WithDmdType a = WithDmdType !DmdType !a - -getAnnotated :: WithDmdType a -> a -getAnnotated (WithDmdType _ a) = a - -data DmdResult a b = R !a !b - --- | 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 --- [Stamp out space leaks in demand analysis]) -dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram -dmdAnalProgram opts fam_envs rules binds - = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds - where - -- See Note [Analysing top-level bindings] - -- and Note [Why care for top-level demand annotations?] - go _ [] = WithDmdType nopDmdType [] - go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body - where - anal_body env' - | WithDmdType body_ty bs' <- go env' bs - = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs' - - cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b] - cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') - - keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv - -- See Note [Absence analysis for stable unfoldings and RULES] - -- Here we keep alive "roots", e.g., exported ids and stuff mentioned in - -- orphan RULES - keep_alive_roots env ids = plusDmdEnvs (map (demandRoot env) (filter is_root ids)) - - is_root :: Id -> Bool - is_root id = isExportedId id || elemVarSet id rule_fvs - - rule_fvs :: IdSet - rule_fvs = rulesRhsFreeIds rules - -demandRoot :: AnalEnv -> Id -> DmdEnv --- See Note [Absence analysis for stable unfoldings and RULES] -demandRoot env id = fst (dmdAnalStar env topDmd (Var id)) - -demandRoots :: AnalEnv -> [Id] -> DmdEnv --- See Note [Absence analysis for stable unfoldings and RULES] -demandRoots env roots = plusDmdEnvs (map (demandRoot env) roots) - -demandRootSet :: AnalEnv -> IdSet -> DmdEnv -demandRootSet env ids = demandRoots env (nonDetEltsUniqSet ids) - -- It's OK to use nonDetEltsUniqSet here because plusDmdType is commutative - --- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings --- that satisfy this function. --- --- Basically, we want to know how top-level *functions* are *used* --- (e.g. called). The information will always be lazy. --- Any other top-level bindings are boring. --- --- See also Note [Why care for top-level demand annotations?]. -isInterestingTopLevelFn :: Id -> Bool --- SG tried to set this to True and got a +2% ghc/alloc regression in T5642 --- (which is dominated by the Simplifier) at no gain in analysis precision. --- If there was a gain, that regression might be acceptable. --- Plus, we could use LetUp for thunks and share some code with local let --- bindings. -isInterestingTopLevelFn id = - typeArity (idType id) `lengthExceeds` 0 - -{- Note [Stamp out space leaks in demand analysis] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The demand analysis pass outputs a new copy of the Core program in -which binders have been annotated with demand and strictness -information. It's tiresome to ensure that this information is fully -evaluated everywhere that we produce it, so we just run a single -seqBinds over the output before returning it, to ensure that there are -no references holding on to the input Core program. - -This makes a ~30% reduction in peak memory usage when compiling -DynFlags (cf #9675 and #13426). - -This is particularly important when we are doing late demand analysis, -since we don't do a seqBinds at any point thereafter. Hence code -generation would hold on to an extra copy of the Core program, via -unforced thunks in demand or strictness information; and it is the -most memory-intensive part of the compilation process, so this added -seqBinds makes a big difference in peak memory usage. - -Note [Analysing top-level bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a CoreProgram like - e1 = ... - n1 = ... - e2 = \a b -> ... fst (n1 a b) ... - n2 = \c d -> ... snd (e2 c d) ... - ... -where e* are exported, but n* are not. -Intuitively, we can see that @n1@ is only ever called with two arguments -and in every call site, the first component of the result of the call -is evaluated. Thus, we'd like it to have idDemandInfo @LCL(CM(P(1L,A))@. -NB: We may *not* give e2 a similar annotation, because it is exported and -external callers might use it in arbitrary ways, expressed by 'topDmd'. -This can then be exploited by Nested CPR and eta-expansion, -see Note [Why care for top-level demand annotations?]. - -How do we get this result? Answer: By analysing the program as if it was a let -expression of this form: - let e1 = ... in - let n1 = ... in - let e2 = ... in - let n2 = ... in - (e1,e2, ...) -E.g. putting all bindings in nested lets and returning all exported binders in a tuple. -Of course, we will not actually build that CoreExpr! Instead we faithfully -simulate analysis of said expression by adding the free variable 'DmdEnv' -of @e*@'s strictness signatures to the 'DmdType' we get from analysing the -nested bindings. - -And even then the above form blows up analysis performance in T10370: -If @e1@ uses many free variables, we'll unnecessarily carry their demands around -with us from the moment we analyse the pair to the moment we bubble back up to -the binding for @e1@. So instead we analyse as if we had - let e1 = ... in - (e1, let n1 = ... in - ( let e2 = ... in - (e2, let n2 = ... in - ( ...)))) -That is, a series of right-nested pairs, where the @fst@ are the exported -binders of the last enclosing let binding and @snd@ continues the nested -lets. - -Variables occurring free in RULE RHSs are to be handled the same as exported Ids. -See also Note [Absence analysis for stable unfoldings and RULES]. - -Note [Why care for top-level demand annotations?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Reading Note [Analysing top-level bindings], you might think that we go through -quite some trouble to get useful demands for top-level bindings. They can never -be strict, for example, so why bother? - -First, we get to eta-expand top-level bindings that we weren't able to -eta-expand before without Call Arity. From T18894b: - module T18894b (f) where - eta :: Int -> Int -> Int - eta x = if fst (expensive x) == 13 then \y -> ... else \y -> ... - f m = ... eta m 2 ... eta 2 m ... -Since only @f@ is exported, we see all call sites of @eta@ and can eta-expand to -arity 2. - -The call demands we get for some top-level bindings will also allow Nested CPR -to unbox deeper. From T18894: - module T18894 (h) where - g m n = (2 * m, 2 `div` n) - {-# NOINLINE g #-} - h :: Int -> Int - h m = ... snd (g m 2) ... uncurry (+) (g 2 m) ... -Only @h@ is exported, hence we see that @g@ is always called in contexts were we -also force the division in the second component of the pair returned by @g@. -This allows Nested CPR to evaluate the division eagerly and return an I# in its -position. --} - -{- -************************************************************************ -* * -\subsection{The analyser itself} -* * -************************************************************************ --} - --- | Analyse a binding group and its \"body\", e.g. where it is in scope. --- --- It calls a function that knows how to analyse this \"body\" given --- an 'AnalEnv' with updated demand signatures for the binding group --- (reflecting their 'idDmdSigInfo') and expects to receive a --- 'DmdType' in return, which it uses to annotate the binding group with their --- 'idDemandInfo'. -dmdAnalBind - :: TopLevelFlag - -> AnalEnv - -> SubDemand -- ^ Demand put on the "body" - -- (important for join points) - -> CoreBind - -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g. - -- where the binding is in scope - -> WithDmdType (DmdResult CoreBind a) -dmdAnalBind top_lvl env dmd bind anal_body = case bind of - NonRec id rhs - | useLetUp top_lvl id - -> dmdAnalBindLetUp top_lvl env_rhs id rhs anal_body - _ -> dmdAnalBindLetDown top_lvl env_rhs dmd bind anal_body - where - env_rhs = enterDFun bind env - --- | Annotates uninteresting top level functions ('isInterestingTopLevelFn') --- with 'topDmd', the rest with the given demand. -setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id -setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of - TopLevel | not (isInterestingTopLevelFn id) -> topDmd - _ -> dmd - --- | Let bindings can be processed in two ways: --- Down (RHS before body) or Up (body before RHS). --- This function handles the up variant. --- --- It is very simple. For let x = rhs in body --- * Demand-analyse 'body' in the current environment --- * Find the demand, 'rhs_dmd' placed on 'x' by 'body' --- * Demand-analyse 'rhs' in 'rhs_dmd' --- --- This is used for a non-recursive local let without manifest lambdas (see --- 'useLetUp'). --- --- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnalBindLetUp :: TopLevelFlag - -> AnalEnv - -> Id - -> CoreExpr - -> (AnalEnv -> WithDmdType a) - -> WithDmdType (DmdResult CoreBind a) -dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) - where - WithDmdType body_ty body' = anal_body (addInScopeAnalEnv env id) - -- See Note [Bringing a new variable into scope] - WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id - -- See Note [Finalising boxity for demand signatures] - - id_dmd' = finaliseLetBoxity (ae_fam_envs env) (idType id) id_dmd - !id' = setBindIdDemandInfo top_lvl id id_dmd' - (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd') rhs - - -- See Note [Absence analysis for stable unfoldings and RULES] - rule_fvs = bndrRuleAndUnfoldingIds id - final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs - --- | Let bindings can be processed in two ways: --- Down (RHS before body) or Up (body before RHS). --- This function handles the down variant. --- --- It computes a demand signature (by means of 'dmdAnalRhsSig') and uses --- that at call sites in the body. --- --- It is used for toplevel definitions, recursive definitions and local --- non-recursive definitions that have manifest lambdas (cf. 'useLetUp'). --- Local non-recursive definitions without a lambda are handled with LetUp. --- --- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. -dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) -dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of - NonRec id rhs - | (env', weak_fv, id1, rhs1) <- - dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs - -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only) - Rec pairs - | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs - -> do_rest env' weak_fv pairs' Rec - where - do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body') - where - WithDmdType body_ty body' = anal_body env' - -- see Note [Lazy and unleashable free variables] - dmd_ty = addWeakFVs body_ty weak_fv - WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1) - -- Important to force this as build_bind might not force it. - !pairs2 = strictZipWith do_one pairs1 id_dmds - do_one (id', rhs') dmd = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs' - -- If the actual demand is better than the vanilla call - -- demand, you might think that we might do better to re-analyse - -- the RHS with the stronger demand. - -- But (a) That seldom happens, because it means that *every* path in - -- the body of the let has to use that stronger demand - -- (b) It often happens temporarily in when fixpointing, because - -- the recursive function at first seems to place a massive demand. - -- But we don't want to go to extra work when the function will - -- probably iterate to something less demanding. - -- In practice, all the times the actual demand on id2 is more than - -- the vanilla call demand seem to be due to (b). So we don't - -- bother to re-analyse the RHS. - --- If e is complicated enough to become a thunk, its contents will be evaluated --- at most once, so oneify it. -dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand -dmdTransformThunkDmd e - | exprIsTrivial e = id - | otherwise = oneifyDmd - --- Do not process absent demands --- Otherwise act like in a normal demand analysis --- See ↦* relation in the Cardinality Analysis paper -dmdAnalStar :: AnalEnv - -> Demand -- This one takes a *Demand* - -> CoreExpr - -> (DmdEnv, CoreExpr) -dmdAnalStar env (n :* sd) e - -- NB: (:*) expands AbsDmd and BotDmd as needed - -- See Note [Analysing with absent demand] - | WithDmdType dmd_ty e' <- dmdAnal env sd e - = assertPpr (mightBeLiftedType (exprType e) || exprOkForSpeculation e) (ppr e) - -- The argument 'e' should satisfy the let/app invariant - (discardArgDmds $ multDmdType n dmd_ty, e') - --- Main Demand Analsysis machinery -dmdAnal, dmdAnal' :: AnalEnv - -> SubDemand -- The main one takes a *SubDemand* - -> CoreExpr -> WithDmdType CoreExpr - -dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ - dmdAnal' env d e - -dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit) -dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact -dmdAnal' _ _ (Coercion co) - = WithDmdType (noArgsDmdType (coercionDmdEnv co)) (Coercion co) - -dmdAnal' env dmd (Var var) - = WithDmdType (dmdTransform env var dmd) (Var var) - -dmdAnal' env dmd (Cast e co) - = WithDmdType (dmd_ty `plusDmdType` coercionDmdEnv co) (Cast e' co) - where - WithDmdType dmd_ty e' = dmdAnal env dmd e - -dmdAnal' env dmd (Tick t e) - = WithDmdType dmd_ty (Tick t e') - where - WithDmdType dmd_ty e' = dmdAnal env dmd e - -dmdAnal' env dmd (App fun (Type ty)) - = WithDmdType fun_ty (App fun' (Type ty)) - where - WithDmdType fun_ty fun' = dmdAnal env dmd fun - --- Lots of the other code is there to make this --- beautiful, compositional, application rule :-) -dmdAnal' env dmd (App fun arg) - = -- This case handles value arguments (type args handled above) - -- Crucially, coercions /are/ handled here, because they are - -- value arguments (#10288) - let - call_dmd = mkCalledOnceDmd dmd - WithDmdType fun_ty fun' = dmdAnal env call_dmd fun - (arg_dmd, res_ty) = splitDmdTy fun_ty - (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg - in --- pprTrace "dmdAnal:app" (vcat --- [ text "dmd =" <+> ppr dmd --- , text "expr =" <+> ppr (App fun arg) --- , text "fun dmd_ty =" <+> ppr fun_ty --- , text "arg dmd =" <+> ppr arg_dmd --- , text "arg dmd_ty =" <+> ppr arg_ty --- , text "res dmd_ty =" <+> ppr res_ty --- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ]) - WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg') - -dmdAnal' env dmd (Lam var body) - | isTyVar var - = let - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body - -- See Note [Bringing a new variable into scope] - in - WithDmdType body_ty (Lam var body') - - | otherwise - = let (n, body_dmd) = peelCallDmd dmd - -- body_dmd: a demand to analyze the body - - WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body - -- See Note [Bringing a new variable into scope] - WithDmdType lam_ty var' = annotateLamIdBndr env body_ty var - new_dmd_type = multDmdType n lam_ty - in - WithDmdType new_dmd_type (Lam var' body') - -dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) - -- Only one alternative. - -- If it's a DataAlt, it should be the only constructor of the type and we - -- can consider its field demands when analysing the scrutinee. - | want_precise_field_dmds alt - = let - rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - WithDmdType rhs_ty rhs' = dmdAnal rhs_env dmd rhs - WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs - WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd - -- Evaluation cardinality on the case binder is irrelevant and a no-op. - -- What matters is its nested sub-demand! - -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is - -- what we want, because then `seq` will put a `seqDmd` on its scrut. - (_ :* case_bndr_sd) = case_bndr_dmd - -- Compute demand on the scrutinee - -- FORCE the result, otherwise thunks will end up retaining the - -- whole DmdEnv - !(!bndrs', !scrut_sd) - | DataAlt _ <- alt - -- See Note [Demand on the scrutinee of a product case] - , let !scrut_sd = scrutSubDmd case_bndr_sd fld_dmds - -- See Note [Demand on case-alternative binders] - , let !fld_dmds' = fieldBndrDmds scrut_sd (length fld_dmds) - , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds' - = (bndrs', scrut_sd) - | otherwise - -- __DEFAULT and literal alts. Simply add demands and discard the - -- evaluation cardinality, as we evaluate the scrutinee exactly once. - = assert (null bndrs) (bndrs, case_bndr_sd) - alt_ty3 - -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" - | exprMayThrowPreciseException (ae_fam_envs env) scrut - = deferAfterPreciseException alt_ty2 - | otherwise - = alt_ty2 - - WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut - res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty - in --- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut --- , text "dmd" <+> ppr dmd --- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') --- , text "scrut_sd" <+> ppr scrut_sd --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_ty" <+> ppr alt_ty2 --- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt bndrs' rhs']) - where - want_precise_field_dmds alt = case alt of - (DataAlt dc) - | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc -> False - | DefinitelyRecursive <- ae_rec_dc env dc -> False - -- See Note [Demand analysis for recursive data constructors] - _ -> True - - - - -dmdAnal' env dmd (Case scrut case_bndr ty alts) - = let -- Case expression with multiple alternatives - WithDmdType alt_ty alts' = combineAltDmds alts - - combineAltDmds [] = WithDmdType botDmdType [] - combineAltDmds (a:as) = - let - WithDmdType cur_ty a' = dmdAnalSumAlt env dmd case_bndr a - WithDmdType rest_ty as' = combineAltDmds as - in WithDmdType (lubDmdType cur_ty rest_ty) (a':as') - - WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr - !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd - WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut - -- NB: Base case is botDmdType, for empty case alternatives - -- This is a unit for lubDmdType, and the right result - -- when there really are no alternatives - fam_envs = ae_fam_envs env - alt_ty2 - -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" - | exprMayThrowPreciseException fam_envs scrut - = deferAfterPreciseException alt_ty1 - | otherwise - = alt_ty1 - res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2 - - in --- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut --- , text "scrut_ty" <+> ppr scrut_ty --- , text "alt_tys" <+> ppr alt_tys --- , text "alt_ty2" <+> ppr alt_ty2 --- , text "res_ty" <+> ppr res_ty ]) $ - WithDmdType res_ty (Case scrut' case_bndr' ty alts') - -dmdAnal' env dmd (Let bind body) - = WithDmdType final_ty (Let bind' body') - where - !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go' - go' !env' = dmdAnal env' dmd body - --- | A simple, syntactic analysis of whether an expression MAY throw a precise --- exception when evaluated. It's always sound to return 'True'. --- See Note [Which scrutinees may throw precise exceptions]. -exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool -exprMayThrowPreciseException envs e - | not (forcesRealWorld envs (exprType e)) - = False -- 1. in the Note - | (Var f, _) <- collectArgs e - , Just op <- isPrimOpId_maybe f - , op /= RaiseIOOp - = False -- 2. in the Note - | (Var f, _) <- collectArgs e - , Just fcall <- isFCallId_maybe f - , not (isSafeForeignCall fcall) - = False -- 3. in the Note - | otherwise - = True -- _. in the Note - --- | Recognises types that are --- * @State# RealWorld@ --- * Unboxed tuples with a @State# RealWorld@ field --- modulo coercions. This will detect 'IO' actions (even post Nested CPR! See --- T13380e) and user-written variants thereof by their type. -forcesRealWorld :: FamInstEnvs -> Type -> Bool -forcesRealWorld fam_envs ty - | ty `eqType` realWorldStatePrimTy - = True - | Just (tc, tc_args, _co) <- normSplitTyConApp_maybe fam_envs ty - , isUnboxedTupleTyCon tc - , let field_tys = dataConInstArgTys (tyConSingleDataCon tc) tc_args - = any (eqType realWorldStatePrimTy . scaledThing) field_tys - | otherwise - = False - -dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType CoreAlt -dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) - | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) - -- See Note [Bringing a new variable into scope] - , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs - , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs - , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr - -- See Note [Demand on case-alternative binders] - -- we can't use the scrut_sd, because it says 'Prod' and we'll use - -- topSubDmd anyway for scrutinees of sum types. - scrut_sd = scrutSubDmd case_bndr_sd dmds - dmds' = fieldBndrDmds scrut_sd (length dmds) - -- Do not put a thunk into the Alt - !new_ids = setBndrsDemandInfo bndrs dmds' - = WithDmdType alt_ty (Alt con new_ids rhs') - --- See Note [Demand on the scrutinee of a product case] -scrutSubDmd :: SubDemand -> [Demand] -> SubDemand -scrutSubDmd case_sd fld_dmds = - -- pprTraceWith "scrutSubDmd" (\scrut_sd -> ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) $ - case_sd `plusSubDmd` mkProd Unboxed fld_dmds - --- See Note [Demand on case-alternative binders] -fieldBndrDmds :: SubDemand -- on the scrutinee - -> Arity - -> [Demand] -- Final demands for the components of the DataCon -fieldBndrDmds scrut_sd n_flds = - case viewProd n_flds scrut_sd of - Just (_, ds) -> ds - Nothing -> replicate n_flds topDmd - -- Either an arity mismatch or scrut_sd was a call demand. - -- See Note [Untyped demand on case-alternative binders] - -{- -Note [Analysing with absent demand] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we analyse an expression with demand A. The "A" means -"absent", so this expression will never be needed. What should happen? -There are several wrinkles: - -* We *do* want to analyse the expression regardless. - Reason: Note [Always analyse in virgin pass] - - But we can post-process the results to ignore all the usage - demands coming back. This is done by multDmdType. - -* Nevertheless, which sub-demand should we pick for analysis? - Since the demand was absent, any would do. Worker/wrapper will replace - absent bindings with an absent filler anyway, so annotations in the RHS - of an absent binding don't matter much. - Picking 'botSubDmd' would be the most useful, but would also look a bit - misleading in the Core output of DmdAnal, because all nested annotations would - be bottoming. Better pick 'seqSubDmd', so that we annotate many of those - nested bindings with A themselves. - -* In a previous incarnation of GHC we needed to be extra careful in the - case of an *unlifted type*, because unlifted values are evaluated - even if they are not used. Example (see #9254): - f :: (() -> (# Int#, () #)) -> () - -- Strictness signature is - -- - -- I.e. calls k, but discards first component of result - f k = case k () of (# _, r #) -> r - - g :: Int -> () - g y = f (\n -> (# case y of I# y2 -> y2, n #)) - - Here f's strictness signature says (correctly) that it calls its - argument function and ignores the first component of its result. - This is correct in the sense that it'd be fine to (say) modify the - function so that always returned 0# in the first component. - - But in function g, we *will* evaluate the 'case y of ...', because - it has type Int#. So 'y' will be evaluated. So we must record this - usage of 'y', else 'g' will say 'y' is absent, and will w/w so that - 'y' is bound to an aBSENT_ERROR thunk. - - However, the argument of toSubDmd always satisfies the let/app - invariant; so if it is unlifted it is also okForSpeculation, and so - can be evaluated in a short finite time -- and that rules out nasty - cases like the one above. (I'm not quite sure why this was a - problem in an earlier version of GHC, but it isn't now.) - -Note [Always analyse in virgin pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tricky point: make sure that we analyse in the 'virgin' pass. Consider - rec { f acc x True = f (...rec { g y = ...g... }...) - f acc x False = acc } -In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. -That might mean that we analyse the sub-expression containing the -E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* -E, but just returned botType. - -Then in the *next* (non-virgin) iteration for 'f', we might analyse E -in a weaker demand, and that will trigger doing a fixpoint iteration -for g. But *because it's not the virgin pass* we won't start g's -iteration at bottom. Disaster. (This happened in $sfibToList' of -nofib/spectral/fibheaps.) - -So in the virgin pass we make sure that we do analyse the expression -at least once, to initialise its signatures. - -Note [Which scrutinees may throw precise exceptions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This is the specification of 'exprMayThrowPreciseExceptions', -which is important for Scenario 2 of -Note [Precise exceptions and strictness analysis] in GHC.Types.Demand. - -For an expression @f a1 ... an :: ty@ we determine that - 1. False If ty is *not* @State# RealWorld@ or an unboxed tuple thereof. - This check is done by 'forcesRealWorld'. - (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') - _. 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). - See haddock on GHC.Types.ForeignCall.PlayRisky. - -We *need* to return False in those cases, because - 1. We would lose too much strictness in pure code, all over the place. - 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, - 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. - -In !3014 we tried a more sophisticated analysis by introducing ConOrDiv (nic) -to the Divergence lattice, but in practice it turned out to be hard to untaint -from 'topDiv' to 'conDiv', leading to bugs, performance regressions and -complexity that didn't justify the single fixed testcase T13380c. - -Note [Demand analysis for recursive data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -T11545 features a single-product, recursive data type - data A = A A A ... A - deriving Eq -Naturally, `(==)` is deeply strict in `A` and in fact will never terminate. That -leads to very large (exponential in the depth) demand signatures and fruitless -churn in boxity analysis, demand analysis and worker/wrapper. -So we detect `A` as a recursive data constructor -(see Note [Detecting recursive data constructors]) analysing `case x of A ...` -and simply assume L for the demand on field binders, which is the same code -path as we take for sum types. -Combined with the B demand on the case binder, we get the very small demand -signature <1S><1S>b on `(==)`. This improves ghc/alloc performance on T11545 -tenfold! See also Note [CPR for recursive data constructors] which describes the -sibling mechanism in CPR analysis. - -Note [Demand on the scrutinee of a product case] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When figuring out the demand on the scrutinee of a product case, -we use the demands of the case alternative, i.e. id_dmds. -But note that these include the demand on the case binder; -see Note [Demand on case-alternative binders]. -This is crucial. Example: - f x = case x of y { (a,b) -> k y a } -If we just take scrut_demand = 1P(L,A), then we won't pass x to the -worker, so the worker will rebuild - x = (a, absent-error) -and that'll crash. - -Note [Demand on case-alternative binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The demand on a binder in a case alternative comes - (a) From the demand on the binder itself - (b) From the demand on the case binder -Forgetting (b) led directly to #10148. - -Example. Source code: - f x@(p,_) = if p then foo x else True - - foo (p,True) = True - foo (p,q) = foo (q,p) - -After strictness analysis, forgetting (b): - f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) -> - case x_an1 - of wild_X7 [Dmd=MP(ML,ML)] - { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) -> - case p_an2 of _ { - False -> GHC.Types.True; - True -> foo wild_X7 } - -Note that ds_dnz is syntactically dead, but the expression bound to it is -reachable through the case binder wild_X7. Now watch what happens if we inline -foo's wrapper: - f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) -> - case x_an1 - of _ [Dmd=MP(ML,ML)] - { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) -> - case p_an2 of _ { - False -> GHC.Types.True; - True -> $wfoo_soq GHC.Types.True ds_dnz } - -Look at that! ds_dnz has come back to life in the call to $wfoo_soq! A second -run of demand analysis would no longer infer ds_dnz to be absent. -But unlike occurrence analysis, which infers properties of the *syntactic* -shape of the program, the results of demand analysis describe expressions -*semantically* and are supposed to be mostly stable across Simplification. -That's why we should better account for (b). -In #10148, we ended up emitting a single-entry thunk instead of an updateable -thunk for a let binder that was an an absent case-alt binder during DmdAnal. - -This is needed even for non-product types, in case the case-binder -is used but the components of the case alternative are not. - -Note [Untyped demand on case-alternative binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -With unsafeCoerce, #8037 and #22039 taught us that the demand on the case binder -may be a call demand or have a different number of fields than the constructor -of the case alternative it is used in. From T22039: - - blarg :: (Int, Int) -> Int - blarg (x,y) = x+y - -- blarg :: <1!P(1L,1L)> - - f :: Either Int Int -> Int - f Left{} = 0 - f e = blarg (unsafeCoerce e) - ==> { desugars to } - f = \ (ds_d1nV :: Either Int Int) -> - case ds_d1nV of wild_X1 { - Left ds_d1oV -> lvl_s1Q6; - Right ipv_s1Pl -> - blarg - (case unsafeEqualityProof @(*) @(Either Int Int) @(Int, Int) of - { UnsafeRefl co_a1oT -> - wild_X1 `cast` (Sub (Sym co_a1oT) :: Either Int Int ~R# (Int, Int)) - }) - } - -The case binder `e`/`wild_X1` has demand 1!P(1L,1L), with two fields, from the call -to `blarg`, but `Right` only has one field. Although the code will crash when -executed, we must be able to analyse it in 'fieldBndrDmds' and conservatively -approximate with Top instead of panicking because of the mismatch. -In #22039, this kind of code was guarded behind a safe `cast` and thus dead -code, but nevertheless led to a panic of the compiler. - -You might wonder why the same problem doesn't come up when scrutinising a -product type instead of a sum type. It appears that for products, `wild_X1` -will be inlined before DmdAnal. - -See also Note [mkWWstr and unsafeCoerce] for a related issue. - -Note [Aggregated demand for cardinality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -FIXME: This Note should be named [LetUp vs. LetDown] and probably predates -said separation. SG - -We use different strategies for strictness and usage/cardinality to -"unleash" demands captured on free variables by bindings. Let us -consider the example: - -f1 y = let {-# NOINLINE h #-} - h = y - in (h, h) - -We are interested in obtaining cardinality demand U1 on |y|, as it is -used only in a thunk, and, therefore, is not going to be updated any -more. Therefore, the demand on |y|, captured and unleashed by usage of -|h| is U1. However, if we unleash this demand every time |h| is used, -and then sum up the effects, the ultimate demand on |y| will be U1 + -U1 = U. In order to avoid it, we *first* collect the aggregate demand -on |h| in the body of let-expression, and only then apply the demand -transformer: - -transf[x](U) = {y |-> U1} - -so the resulting demand on |y| is U1. - -The situation is, however, different for strictness, where this -aggregating approach exhibits worse results because of the nature of -|both| operation for strictness. Consider the example: - -f y c = - let h x = y |seq| x - in case of - True -> h True - False -> y - -It is clear that |f| is strict in |y|, however, the suggested analysis -will infer from the body of |let| that |h| is used lazily (as it is -used in one branch only), therefore lazy demand will be put on its -free variable |y|. Conversely, if the demand on |h| is unleashed right -on the spot, we will get the desired result, namely, that |f| is -strict in |y|. - - -************************************************************************ -* * - Demand transformer -* * -************************************************************************ --} - -dmdTransform :: AnalEnv -- ^ The analysis environment - -> Id -- ^ The variable - -> SubDemand -- ^ The evaluation context of the var - -> 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" -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 - -- Dictionary component selectors - -- Used to be controlled by a flag. - -- See #18429 for some perf measurements. - | Just _ <- isClassOpId_maybe var - = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr (idDmdSig var) $$ ppr sd) $ - dmdTransformDictSelSig (idDmdSig var) sd - -- Imported functions - | isGlobalId var - , let res = dmdTransformSig (idDmdSig var) sd - = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idDmdSig var), ppr sd, ppr res]) - res - -- Top-level or local let-bound thing for which we use LetDown ('useLetUp'). - -- In that case, we have a strictness signature to unleash in our AnalEnv. - | Just (sig, top_lvl) <- lookupSigEnv env var - , let fn_ty = dmdTransformSig sig sd - = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr sd, ppr fn_ty]) $ - case top_lvl of - NotTopLevel -> addVarDmd fn_ty var (C_11 :* sd) - 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 - -- 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 - | otherwise - -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later - -- Everything else: - -- * Local let binders for which we use LetUp (cf. 'useLetUp') - -- * Lambda binders - -- * Case and constructor field binders - | otherwise - = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $ - noArgsDmdType (addVarDmdEnv nopDmdEnv var (C_11 :* sd)) - -{- ********************************************************************* -* * - Binding right-hand sides -* * -********************************************************************* -} - --- | An environment in which all demands are weak according to 'isWeakDmd'. --- See Note [Lazy and unleashable free variables]. -type WeakDmds = VarEnv Demand - --- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature --- for the LetDown rule. It works as follows: --- --- * assuming the weakest possible body sub-demand, L --- * looking at the definition --- * determining a strictness signature --- --- Since it assumed a body sub-demand of L, the resulting signature is --- applicable at any call site. -dmdAnalRhsSig - :: TopLevelFlag - -> RecFlag - -> AnalEnv -> SubDemand - -> Id -> CoreExpr - -> (AnalEnv, WeakDmds, Id, CoreExpr) --- 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 - = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $ - (final_env, weak_fvs, final_id, final_rhs) - where - rhs_arity = idArity id - -- See Note [Demand signatures are computed for a threshold demand based on idArity] - - rhs_dmd = mkCalledOnceDmds rhs_arity body_dmd - - body_dmd - | isJoinId id - -- See Note [Demand analysis for join points] - -- See Note [Invariants on join points] invariant 2b, in GHC.Core - -- rhs_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 - -- 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 - DmdType rhs_env rhs_dmds = rhs_dmd_ty - (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs' (de_div rhs_env) - `orElse` (rhs_dmds, rhs') - - sig = mkDmdSigForArity rhs_arity (DmdType sig_env final_rhs_dmds) - - final_id = id `setIdDmdSig` sig - !final_env = extendAnalEnv top_lvl env final_id sig - - -- See Note [Aggregated demand for cardinality] - -- FIXME: That Note doesn't explain the following lines at all. The reason - -- is really much different: When we have a recursive function, we'd - -- have to also consider the free vars of the strictness signature - -- when checking whether we found a fixed-point. That is expensive; - -- we only want to check whether argument demands of the sig changed. - -- reuseEnv makes it so that the FV results are stable as long as the - -- last argument demands were. Strictness won't change. But used-once - -- might turn into used-many even if the signature was stable and - -- we'd have to do an additional iteration. reuseEnv makes sure that - -- we never get used-once info for FVs of recursive functions. - -- See #14816 where we try to get rid of reuseEnv. - rhs_env1 = case rec_flag of - Recursive -> reuseEnv rhs_env - NonRecursive -> rhs_env - - -- See Note [Absence analysis for stable unfoldings and RULES] - rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (bndrRuleAndUnfoldingIds id) - - -- See Note [Lazy and unleashable free variables] - !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 - -splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds) -splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs) - where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs - --- | 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 -resultType_maybe id - | (pis,ret_ty) <- splitPiTys (idType id) - , count (not . isNamedBinder) pis == idArity id - = Just $! ret_ty - | otherwise - = Nothing - -unboxedWhenSmall :: AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand --- See Note [Unboxed demand on function bodies returning small products] -unboxedWhenSmall _ _ Nothing sd = sd -unboxedWhenSmall env rec_flag (Just ret_ty) sd = go 1 ret_ty sd - where - -- Magic constant, bounding the depth of optimistic 'Unboxed' flags. We - -- might want to minmax in the future. - max_depth | isRec rec_flag = 3 -- So we get at most something as deep as !P(L!P(L!L)) - | otherwise = 1 -- Otherwise be unbox too deep in T18109, T18174 and others and get a bunch of stack overflows - go :: Int -> Type -> SubDemand -> SubDemand - 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 - , dataConRepArity dc <= dmd_unbox_width (ae_opts env) - , Just (_, ds) <- viewProd (dataConRepArity dc) sd - , arg_tys <- map scaledThing $ dataConInstArgTys dc tc_args - , equalLength ds arg_tys - = mkProd Unboxed $! strictZipWith (go_dmd (depth+1)) arg_tys ds - | otherwise - = sd - - go_dmd :: Int -> Type -> Demand -> Demand - go_dmd depth ty dmd = case dmd of - AbsDmd -> AbsDmd - BotDmd -> BotDmd - n :* sd -> n :* go depth ty sd - --- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines --- whether we should process the binding up (body before rhs) or down (rhs --- before body). --- --- We use LetDown if there is a chance to get a useful strictness signature to --- unleash at call sites. LetDown is generally more precise than LetUp if we can --- correctly guess how it will be used in the body, that is, for which incoming --- demand the strictness signature should be computed, which allows us to --- unleash higher-order demands on arguments at call sites. This is mostly the --- case when --- --- * The binding takes any arguments before performing meaningful work (cf. --- 'idArity'), in which case we are interested to see how it uses them. --- * The binding is a join point, hence acting like a function, not a value. --- As a big plus, we know *precisely* how it will be used in the body; since --- it's always tail-called, we can directly unleash the incoming demand of --- the let binding on its RHS when computing a strictness signature. See --- [Demand analysis for join points]. --- --- Thus, if the binding is not a join point and its arity is 0, we have a thunk --- and use LetUp, implying that we have no usable demand signature available --- when we analyse the let body. --- --- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free --- vars at most once, regardless of how many times it was forced in the body. --- This makes a real difference wrt. usage demands. The other reason is being --- able to unleash a more precise product demand on its RHS once we know how the --- thunk was used in the let body. --- --- Characteristic examples, always assuming a single evaluation: --- --- * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that --- the expression uses @y@ at most once. --- * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that --- @b@ is absent. --- * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that --- the expression uses @y@ strictly, because we have @f@'s demand signature --- available at the call site. --- * @join exit = 2*y in if a then exit else if b then exit else 3*y@ => --- LetDown. Compared to LetUp, we find out that the expression uses @y@ --- strictly, because we can unleash @exit@'s signature at each call site. --- * For a more convincing example with join points, see Note [Demand analysis --- for join points]. --- -useLetUp :: TopLevelFlag -> Var -> Bool -useLetUp top_lvl f = isNotTopLevel top_lvl && idArity f == 0 && not (isJoinId f) - -{- Note [Demand analysis for join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - g :: (Int,Int) -> Int - g (p,q) = p+q - - f :: T -> Int -> Int - f x p = g (join j y = (p,y) - in case x of - A -> j 3 - 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. - -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). - -Another win for join points! #13543. - -However, note that the strictness signature for a join point can -look a little puzzling. E.g. - - (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 C1(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 C1(L) -context the RHS of the join point is indeed bottom. - -Note [Demand signatures are computed for a threshold demand based on idArity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We compute demand signatures assuming idArity incoming arguments to approximate -behavior for when we have a call site with at least that many arguments. 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]). - -Because idArity of a function varies independently of its cardinality -properties (cf. Note [idArity varies independently of dmdTypeDepth]), we -implicitly encode the arity for when a demand signature is sound to unleash -in its 'dmdTypeDepth' (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 Note [What are demand signatures?] in GHC.Types.Demand for more details -on soundness. - -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. - -There might be functions for which we might want to analyse for more incoming -arguments than idArity. Example: - - f x = - if expensive - then \y -> ... y ... - else \y -> ... y ... - -We'd analyse `f` under a unary call demand C1(L), corresponding to idArity -being 1. That's enough to look under the manifest lambda and find out how a -unary call would use `x`, but not enough to look into the lambdas in the if -branches. - -On the other hand, if we analysed for call demand C1(C1(L)), we'd get useful -strictness info for `y` (and more precise info on `x`) and possibly CPR -information, but - - * We would no longer be able to unleash the signature at unary call sites - * Performing the worker/wrapper split based on this information would be - implicitly eta-expanding `f`, playing fast and loose with divergence and - even being unsound in the presence of newtypes, so we refrain from doing so. - Also see Note [Don't eta expand in w/w] in GHC.Core.Opt.WorkWrap. - -Since we only compute one signature, we do so for arity 1. Computing multiple -signatures for different arities (i.e., polyvariance) would be entirely -possible, if it weren't for the additional runtime and implementation -complexity. - -Note [idArity varies independently of dmdTypeDepth] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to check in GHC.Core.Lint that dmdTypeDepth <= idArity for a let-bound -identifier. But that means we would have to zap demand signatures every time we -reset or decrease arity. That's an unnecessary dependency, because - - * The demand signature captures a semantic property that is independent of - what the binding's current arity is - * idArity is analysis information itself, thus volatile - * We already *have* dmdTypeDepth, wo why not just use it to encode the - threshold for when to unleash the signature - (cf. Note [Understanding DmdType and DmdSig] in GHC.Types.Demand) - -Consider the following expression, for example: - - (let go x y = `x` seq ... in go) |> co - -`go` might have a strictness signature of `<1L>`. The simplifier will identify -`go` as a nullary join point through `joinPointBinding_maybe` and float the -coercion into the binding, leading to an arity decrease: - - join go = (\x y -> `x` seq ...) |> co in go - -With the CoreLint check, we would have to zap `go`'s perfectly viable strictness -signature. - -Note [Demand analysis for trivial right-hand sides] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - foo = plusInt |> co -where plusInt is an arity-2 function with known strictness. Clearly -we want plusInt's strictness to propagate to foo! But because it has -no manifest lambdas, it won't do so automatically, and indeed 'co' might -have type (Int->Int->Int) ~ T. - -Fortunately, GHC.Core.Opt.Arity gives 'foo' arity 2, which is enough for LetDown to -forward plusInt's demand signature, and all is well (see Note [Newtype arity] in -GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity. - -Note [Absence analysis for stable unfoldings and RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Among others, tickets #18638 and #23208 show that it's really important to treat -stable unfoldings as demanded. Consider - - g = blah - - f = \x. ...no use of g.... - {- f's stable unfolding is f = \x. ...g... -} - -If f is ever inlined we use 'g'. But f's current RHS makes no use -of 'g', so if we don't look at the unfolding we'll mark g as Absent, -and transform to - - g = error "Entered absent value" - f = \x. ... - {- f's stable unfolding is f = \x. ...g... -} - -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 -'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. - -Wrinkles: - - (W1) You may wonder how it can be that f's optimised RHS has somehow - discarded 'g', but when f is inlined we /don't/ discard g in the same - way. I think a simple example is - g = (a,b) - f = \x. fst g - {-# INLINE f #-} - - Now f's optimised RHS will be \x.a, but if we change g to (error "..") - (since it is apparently Absent) and then inline (\x. fst g) we get - disaster. But regardless, #18638 was a more complicated version of - this, that actually happened in practice. - - (W2) You might wonder why we don't simply take the free vars of the - unfolding/RULE and map them to topDmd. The reason is that any of the free vars - might have demand signatures themselves that in turn demand transitive free - variables and that we hence need to unleash! This came up in #23208. - Consider - - err :: Int -> b - err = error "really important message" - - sg :: Int -> Int - sg _ = case err of {} -- Str=<1B>b {err:->S} - - g :: a -> a -- g is exported - g x = x - {-# RULES "g" g @Int = sg #-} - - Here, `err` is only demanded by `sg`'s demand signature: It doesn't occur - in the weak_fvs of `sg`'s RHS at all. Hence when we `demandRoots` `sg` - because it occurs in the RULEs of `g` (which is exported), we better unleash - the demand signature of `sg`, too! Before #23208 we simply added a 'topDmd' - for `sg`, failing to unleash the signature and hence observed an absent - error instead of the `really important message`. - -Note [Boxity for bottoming functions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider -```hs -indexError :: Show a => (a, a) -> a -> String -> b --- Str=<..><1!P(S,S)><1S>b -indexError rng i s = error (show rng ++ show i ++ show s) - -get :: (Int, Int) -> Int -> [a] -> a -get p@(l,u) i xs - | l <= i, i < u = xs !! (i-u) - | otherwise = indexError p i "get" -``` -The hot path of `get` certainly wants to unbox `p` as well as `l` and `u`, but -the unimportant, diverging error path needs `l` and `u` boxed (although the -wrapper for `indexError` *will* unbox `p`). This pattern often occurs in -performance sensitive code that does bounds-checking. - -It would be a shame to let `Boxed` win for the fields! So here's what we do: -While to summarising `indexError`'s boxity signature in `finaliseArgBoxities`, -we `unboxDeeplyDmd` all its argument demands and are careful not to discard -excess boxity in the `StopUnboxing` case, to get the signature -`<1!P(!S,!S)><1!S>b`. - -Then worker/wrapper will not only unbox the pair passed to `indexError` (as it -would do anyway), demand analysis will also pretend that `indexError` needs `l` -and `u` unboxed (and the two other args). Which is a lie, because `indexError`'s -type abstracts over their types and could never unbox them. - -The important change is at the *call sites* of `$windexError`: Boxity analysis -will conclude to unbox `l` and `u`, which *will* incur reboxing of crud that -should better float to the call site of `$windexError`. There we don't care -much, because it's in the slow, diverging code path! And that floating often -happens, but not always. See Note [Reboxed crud for bottoming calls]. - -Note [Reboxed crud for bottoming calls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For functions like `get` in Note [Boxity for bottoming functions], it's clear -that the reboxed crud will be floated inside to the call site of `$windexError`. -But here's an example where that is not the case: -```hs -import GHC.Ix - -theresCrud :: Int -> Int -> Int -theresCrud x y = go x - where - go 0 = index (0,y) 0 - go 1 = index (x,y) 1 - go n = go (n-1) - {-# NOINLINE theresCrud #-} -``` -If you look at the Core, you'll see that `y` will be reboxed and used in the -two exit join points for the `$windexError` calls, while `x` is only reboxed in the -exit join point for `index (x,y) 1` (happens in lvl below): -``` -$wtheresCrud = \ ww ww1 -> - let { y = I# ww1 } in - join { lvl2 = ... case lvl1 ww y of wild { }; ... } in - join { lvl3 = ... case lvl y of wild { }; ... } in - ... -``` -This is currently a bug that we willingly accept and it's documented in #21128. --} - -{- ********************************************************************* -* * - Finalising boxity -* * -********************************************************************* -} - -{- Note [Finalising boxity for demand signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The worker/wrapper pass must strictly adhere to the boxity decisions -encoded in the demand signature, because that is the information that -demand analysis propagates throughout the program. Failing to -implement the strategy laid out in the signature can result in -reboxing in unexpected places. Hence, we must completely anticipate -unboxing decisions during demand analysis and reflect these decicions -in demand annotations. That is the job of 'finaliseArgBoxities', -which is defined here and called from demand analysis. - -Here is a list of different Notes it has to take care of: - - * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in - general, but still allow Note [Unboxing evaluated arguments] - * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)` - * Implement fixes for corner cases Note [Do not unbox class dictionaries] - and Note [mkWWstr and unsafeCoerce] - -Then, in worker/wrapper blindly trusts the boxity info in the demand signature -and will not look at strictness info *at all*, in 'wantToUnboxArg'. - -Note [Finalising boxity for let-bound Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let x = e in body -where the demand on 'x' is 1!P(blah). We want to unbox x according to -Note [Thunk splitting] in GHC.Core.Opt.WorkWrap. We must do this becuase -worker/wrapper ignores stricness and looks only at boxity flags; so if -x's demand is L!P(blah) we might still split it (wrongly). We want to -switch to Boxed on any lazy demand. - -That is what finaliseLetBoxity does. It has no worker-arg budget, so it -is much simpler than finaliseArgBoxities. - -Note [No nested Unboxed inside Boxed in demand signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider -``` -f p@(x,y) - | even (x+y) = [] - | otherwise = [p] -``` -Demand analysis will infer that the function body puts a demand of `1P(1!L,1!L)` -on 'p', e.g., Boxed on the outside but Unboxed on the inside. But worker/wrapper -can't unbox the pair components without unboxing the pair! So we better say -`1P(1L,1L)` in the demand signature in order not to spread wrong Boxity info. -That happens via the call to trimBoxity in 'finaliseArgBoxities'/'finaliseLetBoxity'. - -Note [No lazy, Unboxed demands in demand signature] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider T19407: - - data Huge = Huge Bool () ... () -- think: DynFlags - data T = T { h :: Huge, n :: Int } - f t@(T h _) = g h t - g (H b _ ... _) t = if b then 1 else n t - -The body of `g` puts (approx.) demand `L!P(A,1)` on `t`. But we better -not put that demand in `g`'s demand signature, because worker/wrapper will not -in general unbox a lazy-and-unboxed demand like `L!P(..)`. -(The exception are known-to-be-evaluated arguments like strict fields, -see Note [Unboxing evaluated arguments].) - -The program above is an example where spreading misinformed boxity through the -signature is particularly egregious. If we give `g` that signature, then `f` -puts demand `S!P(1!P(1L,A,..),ML)` on `t`. Now we will unbox `t` in `f` it and -we get - - f (T (H b _ ... _) n) = $wf b n - $wf b n = $wg b (T (H b x ... x) n) - $wg = ... - -Massive reboxing in `$wf`! Solution: Trim boxity on lazy demands in -'trimBoxity', modulo Note [Unboxing evaluated arguments]. - -Note [Unboxing evaluated arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this program (due to Roman): - - data X a = X !a - - foo :: X Int -> Int -> Int - foo x@(X a) n = go 0 - where - go i | i < n = a + go (i+1) - | otherwise = 0 - -We want the worker for 'foo' to look like this: - - $wfoo :: Int# -> Int# -> Int# - -with the first argument unboxed, so that it is not eval'd each time around the -'go' loop (which would otherwise happen, since 'foo' is not strict in 'a'). It -is sound for the wrapper to pass an unboxed arg because X is strict -(see Note [Strictness and Unboxing] in "GHC.Core.Opt.DmdAnal"), so its argument -must be evaluated. And if we *don't* pass an unboxed argument, we can't even -repair it by adding a `seq` thus: - - foo (X a) n = a `seq` go 0 - -because the seq is discarded (very early) since X is strict! - -So here's what we do - -* Since this has nothing to do with how 'foo' uses 'a', we leave demand - analysis alone, but account for the additional evaluatedness when - annotating the binder 'finaliseArgBoxities', which will retain the Unboxed - boxity on 'a' in the definition of 'foo' in the demand 'L!P(L)'; meaning - it's used lazily but unboxed nonetheless. This seems to contradict Note - [No lazy, Unboxed demands in demand signature], but we know that 'a' is - evaluated and thus can be unboxed. - -* When 'finaliseArgBoxities' decides to unbox a record, it will zip the field demands - together with the respective 'StrictnessMark'. In case of 'x', it will pair - up the lazy field demand 'L!P(L)' on 'a' with 'MarkedStrict' to account for - the strict field. - -* Said 'StrictnessMark' is passed to the recursive invocation of 'go_args' in - 'finaliseArgBoxities' when deciding whether to unbox 'a'. 'a' was used lazily, but - since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'. - -* Worker/wrapper will consult 'wantToUnboxArg' for its unboxing decision. It will - /not/ look at the strictness bits of the demand, only at Boxity flags. As such, - it will happily unbox 'a' despite the lazy demand on it. - -The net effect is that boxity analysis and the w/w transformation are more -aggressive about unboxing the strict arguments of a data constructor than when -looking at strictness info exclusively. It is very much like (Nested) CPR, which -needs its nested fields to be evaluated in order for it to unbox nestedly. - -There is the usual danger of reboxing, which as usual we ignore. But -if X is monomorphic, and has an UNPACK pragma, then this optimisation -is even more important. We don't want the wrapper to rebox an unboxed -argument, and pass an Int to $wfoo! - -This works in nested situations like T10482 - - data family Bar a - data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) - newtype instance Bar Int = Bar Int - - foo :: Bar ((Int, Int), Int) -> Int -> Int - foo f k = case f of BarPair x y -> - case burble of - True -> case x of - BarPair p q -> ... - False -> ... - -The extra eagerness lets us produce a worker of type: - $wfoo :: Int# -> Int# -> Int# -> Int -> Int - $wfoo p# q# y# = ... - -even though the `case x` is only lazily evaluated. - ---------- Historical note ------------ -We used to add data-con strictness demands when demand analysing case -expression. However, it was noticed in #15696 that this misses some cases. For -instance, consider the program (from T10482) - - data family Bar a - data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) - newtype instance Bar Int = Bar Int - - foo :: Bar ((Int, Int), Int) -> Int -> Int - foo f k = - case f of - BarPair x y -> case burble of - True -> case x of - BarPair p q -> ... - False -> ... - -We really should be able to assume that `p` is already evaluated since it came -from a strict field of BarPair. This strictness would allow us to produce a -worker of type: - - $wfoo :: Int# -> Int# -> Int# -> Int -> Int - $wfoo p# q# y# = ... - -even though the `case x` is only lazily evaluated - -Indeed before we fixed #15696 this would happen since we would float the inner -`case x` through the `case burble` to get: - - foo f k = - case f of - BarPair x y -> case x of - BarPair p q -> case burble of - True -> ... - False -> ... - -However, after fixing #15696 this could no longer happen (for the reasons -discussed in ticket:15696#comment:76). This means that the demand placed on `f` -would then be significantly weaker (since the False branch of the case on -`burble` is not strict in `p` or `q`). - -Consequently, we now instead account for data-con strictness in mkWWstr_one, -applying the strictness demands to the final result of DmdAnal. The result is -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] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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. - -But in any other situation, a dictionary is just an ordinary value, -and can be unpacked. So we track the INLINABLE pragma, and discard the boxity -flag in finaliseArgBoxities (see the isClassPred test). - -Historical note: #14955 describes how I got this fix wrong the first time. - -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 -argument when, say given a strict record with zillions of fields. So we -limit the maximum number of worker args to the maximum of - - -fmax-worker-args=N - - The number of args in the original function; if it already has has - zillions of arguments we don't want to seek /fewer/ args in the worker. -(Maybe we should /add/ them instead of maxing?) - -We pursue a "layered" strategy for unboxing: we unbox the top level of the -argument(s), subject to budget; if there are any arguments left we unbox the -next layer, using that depleted budget. - -To achieve this, we use the classic almost-circular programming technique in -which we we write one pass that takes a lazy list of the Budgets for every -layer. - -Note [The OPAQUE pragma and avoiding the reboxing of arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In https://gitlab.haskell.org/ghc/ghc/-/issues/13143 it was identified that when -a function 'f' with a NOINLINE pragma is W/W transformed, then the worker for -'f' should get the NOINLINE annotation, while the wrapper /should/ be inlined. - -That's because if the wrapper for 'f' had stayed NOINLINE, then any worker of a -W/W-transformed /caller of/ 'f' would immediately rebox any unboxed arguments -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 -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. --} - -data Budgets = MkB Arity Budgets -- An infinite list of arity budgets - -incTopBudget :: Budgets -> Budgets -incTopBudget (MkB n bg) = MkB (n+1) bg - -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 - - | otherwise - = Just (arg_dmds', add_demands arg_dmds' rhs) - -- add_demands: 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 - fam_envs = ae_fam_envs env - is_inlinable_fn = isStableUnfolding (realIdUnfolding fn) - (bndrs, _body) = collectBinders rhs - max_wkr_args = dmd_max_worker_args opts `max` arity - -- See 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 - - arg_triples :: [(Type, StrictnessMark, Demand)] - arg_triples = take arity $ - map mk_triple $ - filter isRuntimeVar bndrs - - mk_triple :: Id -> (Type,StrictnessMark,Demand) - mk_triple bndr | is_cls_arg ty = (ty, NotMarkedStrict, trimBoxity dmd) - | is_bot_fn = (ty, NotMarkedStrict, unboxDeeplyDmd dmd) - -- See Note [OPAQUE pragma] - -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] - | is_opaque = (ty, NotMarkedStrict, trimBoxity dmd) - | otherwise = (ty, NotMarkedStrict, dmd) - where - ty = idType bndr - dmd = idDemandInfo bndr - is_opaque = isOpaquePragma (idInlinePragma fn) - - -- is_cls_arg: see Note [Do not unbox class dictionaries] - is_cls_arg arg_ty = is_inlinable_fn && isClassPred arg_ty - -- is_bot_fn: see Note [Boxity for bottoming functions] - is_bot_fn = div == botDiv - - go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand]) - go_args bg triples = mapAccumL go_arg bg triples - - go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand) - go_arg bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _)) - = case wantToUnboxArg False fam_envs ty dmd of - StopUnboxing - | not is_bot_fn - -- If bot: Keep deep boxity even though WW won't unbox - -- See Note [Boxity for bottoming functions] - -> (MkB (bg_top-1) bg_inner, trimBoxity dmd) - - Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds - -> (MkB (bg_top-1) final_bg_inner, final_dmd) - where - dc_arity = dataConRepArity dc - arg_tys = dubiousDataConInstArgTys dc tc_args - (bg_inner', dmds') = go_args (incTopBudget bg_inner) $ - zip3 arg_tys (dataConRepStrictness dc) dmds - dmd' = n :* (mkProd Unboxed $! dmds') - (final_bg_inner, final_dmd) - | dmds `lengthIs` dc_arity - , isStrict n || isMarkedStrict str_mark - -- isStrict: see Note [No lazy, Unboxed demands in demand signature] - -- isMarkedStrict: see Note [Unboxing evaluated arguments] - , positiveTopBudget bg_inner' - , NonRecursiveOrUnsure <- ae_rec_dc env dc - -- See Note [Which types are unboxed?] - -- and Note [Demand analysis for recursive data constructors] - = (bg_inner', dmd') - | otherwise - = (bg_inner, trimBoxity dmd) - _ -> (bg, dmd) - - add_demands :: [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) - -finaliseLetBoxity - :: FamInstEnvs - -> Type -- ^ Type of the let-bound Id - -> Demand -- ^ How the Id is used - -> Demand --- See Note [Finalising boxity for let-bound Ids] --- This function is like finaliseArgBoxities, but much simpler because --- it has no "budget". It simply unboxes strict demands, and stops --- when it reaches a lazy one. -finaliseLetBoxity env ty dmd - = go ty NotMarkedStrict dmd - where - go ty mark dmd@(n :* _) = - case wantToUnboxArg False env ty dmd of - DropAbsent -> dmd - StopUnboxing -> trimBoxity dmd - Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds - | isStrict n || isMarkedStrict mark - , dmds `lengthIs` dataConRepArity dc - , let arg_tys = dubiousDataConInstArgTys dc tc_args - dmds' = strictZipWith3 go arg_tys (dataConRepStrictness dc) dmds - -> n :* (mkProd Unboxed $! dmds') - | otherwise - -> trimBoxity dmd - Unlift -> panic "No unlifting in DmdAnal" - - -{- ********************************************************************* -* * - Fixpoints -* * -********************************************************************* -} - --- Recursive bindings -dmdFix :: TopLevelFlag - -> AnalEnv -- Does not include bindings for this binding - -> SubDemand - -> [(Id,CoreExpr)] - -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info -dmdFix top_lvl env let_dmd orig_pairs - = loop 1 initial_pairs - where - -- See Note [Initialising strictness] - initial_pairs | ae_virgin env = [(setIdDmdSig id botSig, rhs) | (id, rhs) <- orig_pairs ] - | otherwise = orig_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, WeakDmds, [(Id,CoreExpr)]) - abort = (env, weak_fv', zapped_pairs) - where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs) - -- Note [Lazy and unleashable free variables] - weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs' - weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs - zapped_pairs = zapIdDmdSig pairs' - - -- The fixed-point varies the idDmdSig field of the binders, and terminates if that - -- annotation does not change any more. - loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) - loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) - -- | (id,_)<- pairs]) $ - loop' n pairs - - loop' n pairs - | found_fixpoint = (final_anal_env, weak_fv, pairs') - | n == 10 = abort - | otherwise = loop (n+1) pairs' - where - found_fixpoint = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs - first_round = n == 1 - (weak_fv, pairs') = step first_round pairs - final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') - - step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)]) - step first_round pairs = (weak_fv, pairs') - where - -- In all but the first iteration, delete the virgin flag - start_env | first_round = env - | otherwise = nonVirgin env - - start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) - - !((_,!weak_fv), !pairs') = mapAccumL my_downRhs start pairs - -- mapAccumL: Use the new signature to do the next pair - -- The occurrence analyser has arranged them in a good order - -- so this can significantly reduce the number of iterations needed - - my_downRhs (env, weak_fv) (id,rhs) - = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $ - ((env', weak_fv'), (id', rhs')) - where - !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs - !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1 - - zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] - zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ] - -{- Note [Safe abortion in the fixed-point iteration] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Fixed-point iteration may fail to terminate. But we cannot simply give up and -return the environment and code unchanged! We still need to do one additional -round, for two reasons: - - * To get information on used free variables (both lazy and strict!) - (see Note [Lazy and unleashable free variables]) - * To ensure that all expressions have been traversed at least once, and any left-over - strictness annotations have been updated. - -This final iteration does not add the variables to the strictness signature -environment, which effectively assigns them 'nopSig' (see "getStrictness") - -Note [Trimming a demand to a type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are two reasons we sometimes trim a demand to match a type. - 1. GADTs - 2. Recursive products and widening - -More on both below. But the botttom line is: we really don't want to -have a binder whose demand is more deeply-nested than its type -"allows". So in findBndrDmd we call trimToType and findTypeShape to -trim the demand on the binder to a form that matches the type - -Now to the reasons. For (1) consider - f :: a -> Bool - f x = case ... of - A g1 -> case (x |> g1) of (p,q) -> ... - B -> error "urk" - -where A,B are the constructors of a GADT. We'll get a 1P(L,L) demand -on x from the A branch, but that's a stupid demand for x itself, which -has type 'a'. Indeed we get ASSERTs going off (notably in -splitUseProdDmd, #8569). - -For (2) consider - data T = MkT Int T -- A recursive product - f :: Int -> T -> Int - f 0 _ = 0 - f _ (MkT n t) = f n t - -Here f is lazy in T, but its *usage* is infinite: P(L,P(L,P(L, ...))). -Notice that this happens because T is a product type, and is recrusive. -If we are not careful, we'll fail to iterate to a fixpoint in dmdFix, -and bale out entirely, which is inefficient and over-conservative. - -Worse, as we discovered in #18304, the size of the usages we compute -can grow /exponentially/, so even 10 iterations costs far too much. -Especially since we then discard the result. - -To avoid this we use the same findTypeShape function as for (1), but -arrange that it trims the demand if it encounters the same type constructor -twice (or three times, etc). We use our standard RecTcChecker mechanism -for this -- see GHC.Core.Opt.WorkWrap.Utils.findTypeShape. - -This is usually call "widening". We could do it just in dmdFix, but -since are doing this findTypeShape business /anyway/ because of (1), -and it has all the right information to hand, it's extremely -convenient to do it there. - --} - -{- ********************************************************************* -* * - Strictness signatures and types -* * -********************************************************************* -} - -noArgsDmdType :: DmdEnv -> DmdType -noArgsDmdType dmd_env = DmdType dmd_env [] - -coercionDmdEnv :: Coercion -> DmdEnv -coercionDmdEnv co = coercionsDmdEnv [co] - -coercionsDmdEnv :: [Coercion] -> DmdEnv -coercionsDmdEnv cos - = mkTermDmdEnv $ mapVarEnv (const topDmd) $ getUniqSet $ coVarsOfCos cos - -- The VarSet from coVarsOfCos is really a VarEnv Var - -addVarDmd :: DmdType -> Var -> Demand -> DmdType -addVarDmd (DmdType fv ds) var dmd - = DmdType (addVarDmdEnv fv var dmd) ds - -addWeakFVs :: DmdType -> WeakDmds -> DmdType -addWeakFVs dmd_ty weak_fvs - = dmd_ty `plusDmdType` mkTermDmdEnv weak_fvs - -- Using plusDmdType (rather than just plus'ing the envs) - -- is vital. Consider - -- let f = \x -> (x,y) - -- in error (f 3) - -- Here, y is treated as a lazy-fv of f, but we must `plusDmd` that L - -- demand with the bottom coming up from 'error' - -- - -- I got a loop in the fixpointer without this, due to an interaction - -- with the weak_fv filtering in dmdAnalRhsSig. Roughly, it was - -- letrec f n x - -- = letrec g y = x `fatbar` - -- letrec h z = z + ...g... - -- in h (f (n-1) x) - -- in ... - -- In the initial iteration for f, f=Bot - -- Suppose h is found to be strict in z, but the occurrence of g in its RHS - -- is lazy. Now consider the fixpoint iteration for g, esp the demands it - -- places on its free variables. Suppose it places none. Then the - -- x `fatbar` ...call to h... - -- will give a x->V demand for x. That turns into a L demand for x, - -- which floats out of the defn for h. Without the modifyEnv, that - -- 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 (b:bs) ds - | isTyVar b = b : setBndrsDemandInfo bs ds -setBndrsDemandInfo (b:bs) (d:ds) = - let !new_info = setIdDemandInfo b d - !vars = setBndrsDemandInfo bs ds - in new_info : vars -setBndrsDemandInfo [] ds = assert (null ds) [] -setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) - -annotateLamIdBndr :: AnalEnv - -> DmdType -- Demand type of body - -> Id -- Lambda binder - -> WithDmdType Id -- Demand type of lambda - -- and binder annotated with demand - -annotateLamIdBndr env dmd_ty id --- For lambdas we add the demand to the argument demands --- Only called for Ids - = assert (isId id) $ - -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ - WithDmdType main_ty new_id - where - new_id = setIdDemandInfo id dmd - main_ty = addDemand dmd dmd_ty' - WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id - -{- Note [NOINLINE and strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At one point we disabled strictness for NOINLINE functions, on the -grounds that they should be entirely opaque. But that lost lots of -useful semantic strictness information, so now we analyse them like -any other function, and pin strictness information on them. - -That in turn forces us to worker/wrapper them; see -Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. - - -Note [Lazy and unleashable free variables] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We put the strict and once-used FVs in the DmdType of the Id, so -that at its call sites we unleash demands on its strict fvs. -An example is 'roll' in imaginary/wheel-sieve2 -Something like this: - roll x = letrec - go y = if ... then roll (x-1) else x+1 - in - go ms -We want to see that roll is strict in x, which is because -go is called. So we put the DmdEnv for x in go's DmdType. - -Another example: - - f :: Int -> Int -> Int - f x y = let t = x+1 - h z = if z==0 then t else - if z==1 then x+1 else - x + h (z-1) - in h y - -Calling h does indeed evaluate x, but we can only see -that if we unleash a demand on x at the call site for t. - -Incidentally, here's a place where lambda-lifting h would -lose the cigar --- we couldn't see the joint strictness in t/x - - ON THE OTHER HAND - -We don't want to put *all* the fv's from the RHS into the -DmdType. Because - - * it makes the strictness signatures larger, and hence slows down fixpointing - -and - - * it is useless information at the call site anyways: - For lazy, used-many times fv's we will never get any better result than - that, no matter how good the actual demand on the function at the call site - is (unless it is always absent, but then the whole binder is useless). - -Therefore we exclude lazy multiple-used fv's from the environment in the -DmdType. - -But now the signature lies! (Missing variables are assumed to be absent.) To -make up for this, the code that analyses the binding keeps the demand on those -variable separate (usually called "weak_fv") and adds it to the demand of the -whole binding later. - -What if we decide _not_ to store a strictness signature for a binding at all, as -we do when aborting a fixed-point iteration? The we risk losing the information -that the strict variables are being used. In that case, we take all free variables -mentioned in the (unsound) strictness signature, conservatively approximate the -demand put on them (topDmd), and add that to the "weak_fv" returned by "dmdFix". - - -************************************************************************ -* * -\subsection{Strictness signatures} -* * -************************************************************************ --} - - -data AnalEnv = AE - { ae_opts :: !DmdAnalOpts - -- ^ Analysis options - , ae_sigs :: !SigEnv - , ae_virgin :: !Bool - -- ^ True on first iteration only. See Note [Initialising strictness] - , ae_fam_envs :: !FamInstEnvs - , ae_rec_dc :: DataCon -> IsRecDataConResult - -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon' - } - - -- We use the se_env to tell us whether to - -- record info about a variable in the DmdEnv - -- We do so if it's a LocalId, but not top-level - -- - -- The DmdEnv gives the demand on the free vars of the function - -- when it is given enough args to satisfy the strictness signature - -type SigEnv = VarEnv (DmdSig, TopLevelFlag) - -instance Outputable AnalEnv where - ppr env = text "AE" <+> braces (vcat - [ text "ae_virgin =" <+> ppr (ae_virgin env) - , text "ae_sigs =" <+> ppr (ae_sigs env) - ]) - -emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv -emptyAnalEnv opts fam_envs - = AE { ae_opts = opts - , ae_sigs = emptySigEnv - , ae_virgin = True - , ae_fam_envs = fam_envs - , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs 3) - } - --- | Unset the 'dmd_strict_dicts' flag if any of the given bindings is a DFun --- binding. Part of the mechanism that detects --- Note [Do not strictify a DFun's parameter dictionaries]. -enterDFun :: CoreBind -> AnalEnv -> AnalEnv -enterDFun bind env - | any isDFunId (bindersOf bind) - = env { ae_opts = (ae_opts env) { dmd_strict_dicts = False } } - | otherwise - = env - -emptySigEnv :: SigEnv -emptySigEnv = emptyVarEnv - --- | Extend an environment with the strictness sigs attached to the Ids -extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv -extendAnalEnvs top_lvl env vars - = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } - -extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv -extendSigEnvs top_lvl sigs vars - = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars] - -extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv -extendAnalEnv top_lvl env var sig - = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } - -extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> DmdSig -> SigEnv -extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) - -lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag) -lookupSigEnv env id = lookupVarEnv (ae_sigs env) id - -addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv -addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id } - -addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv -addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids } - -nonVirgin :: AnalEnv -> AnalEnv -nonVirgin env = env { ae_virgin = False } - -findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] --- Return the demands on the Ids in the [Var] -findBndrsDmds env dmd_ty bndrs - = go dmd_ty bndrs - where - go dmd_ty [] = WithDmdType dmd_ty [] - go dmd_ty (b:bs) - | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs - WithDmdType dmd_ty2 dmd = findBndrDmd env dmd_ty1 b - in WithDmdType dmd_ty2 (dmd : dmds) - | otherwise = go dmd_ty bs - -findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand --- See Note [Trimming a demand to a type] -findBndrDmd env dmd_ty id - = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $ - WithDmdType dmd_ty' dmd' - where - dmd' = strictify $ - trimToType starting_dmd (findTypeShape fam_envs id_ty) - - (dmd_ty', starting_dmd) = peelFV dmd_ty id - - id_ty = idType id - - strictify dmd - -- See Note [Making dictionary parameters strict] - -- and Note [Do not strictify a DFun's parameter dictionaries] - | dmd_strict_dicts (ae_opts env) - = strictifyDictDmd id_ty dmd - | otherwise - = dmd - - fam_envs = ae_fam_envs env - -{- Note [Bringing a new variable into scope] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f x = blah - g = ...(\f. ...f...)... - -In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`, -not the top-level `f` (which will be in `ae_sigs`). So it's very important -to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`. -Otherwise chaos results (#22718). - -Note [Making dictionary parameters strict] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries. Why? - -* Generally CBV is more efficient. - -* A datatype dictionary is always non-bottom and never takes much work to - compute. E.g. a DFun from an instance decl always returns a dictionary - record immediately. See DFunUnfolding in CoreSyn. - See also Note [Recursive superclasses] in TcInstDcls. - -See #17758 for more background and perf numbers. - -Wrinkles: - -* A newtype dictionary is *not* always non-bottom. E.g. - class C a where op :: a -> a - instance C Int where op = error "urk" - Now a value of type (C Int) is just a newtype wrapper (a cast) around - the error thunk. Don't strictify these! - -* Strictifying DFuns risks destroying the invariant that DFuns never take much - work to compute, so we don't do it. - See Note [Do not strictify a DFun's parameter dictionaries] for details. - -* Although worker/wrapper *could* unbox strictly used dictionaries, we do not do - so; see Note [Do not unbox class dictionaries]. - -The implementation is extremly simple: just make the strictness -analyser strictify the demand on a dictionary binder in -'findBndrDmd' if the binder does not belong to a DFun. - -Note [Do not strictify a DFun's parameter dictionaries] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker can tie recursive knots involving (non-recursive) DFuns, so -we must not strictify a DFun's parameter dictionaries (#22549). -T22549 has an example involving undecidable instances that <>s when we -strictify the DFun of, e.g., `$fEqSeqT`: - - Main.$fEqSeqT - = \@m @a ($dEq :: Eq (m (ViewT m a))) ($dMonad :: Monad m) -> - GHC.Classes.C:Eq @(SeqT m a) ($c== @m @a $dEq $dMonad) - ($c/= @m @a $dEq $dMonad) - - Rec { - $dEq_a = Main.$fEqSeqT @Identity @Int $dEq_b Main.$fMonadIdentity - $dEq_b = ... $dEq_a ... - } - -If we make `$fEqSeqT` strict in `$dEq`, we'll collapse the Rec group into a -giant, <>ing thunk. - -To prevent that, we never strictify dictionary params when inside a DFun. -That is implemented by unsetting 'dmd_strict_dicts' when entering a DFun. - -See also Note [Speculative evaluation] in GHC.CoreToStg.Prep which has a rather -similar example in #20836. We may never speculate *arguments* of (recursive) -DFun calls, likewise we should not mark *formal parameters* of recursive DFuns -as strict. - -Note [Initialising strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See section 9.2 (Finding fixpoints) of the paper. - -Our basic plan is to initialise the strictness of each Id in a -recursive group to "bottom", and find a fixpoint from there. However, -this group B might be inside an *enclosing* recursive group A, in -which case we'll do the entire fixpoint shebang on for each iteration -of A. This can be illustrated by the following example: - -Example: - - f [] = [] - f (x:xs) = let g [] = f xs - g (y:ys) = y+1 : g ys - in g (h x) - -At each iteration of the fixpoint for f, the analyser has to find a -fixpoint for the enclosed function g. In the meantime, the demand -values for g at each iteration for f are *greater* than those we -encountered in the previous iteration for f. Therefore, we can begin -the fixpoint for g not with the bottom value but rather with the -result of the previous analysis. I.e., when beginning the fixpoint -process for g, we can start from the demand signature computed for g -previously and attached to the binding occurrence of g. - -To speed things up, we initialise each iteration of A (the enclosing -one) from the result of the last one, which is neatly recorded in each -binder. That way we make use of earlier iterations of the fixpoint -algorithm. (Cunning plan.) - -But on the *first* iteration we want to *ignore* the current strictness -of the Id, and start from "bottom". Nowadays the Id can have a current -strictness, because interface files record strictness for nested bindings. -To know when we are in the first iteration, we look at the ae_virgin -field of the AnalEnv. - - -Note [Final Demand Analyser run] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some of the information that the demand analyser determines is not always -preserved by the simplifier. For example, the simplifier will happily rewrite - \y [Demand=MU] let x = y in x + x -to - \y [Demand=MU] y + y -which is quite a lie: Now y occurs more than just once. - -The once-used information is (currently) only used by the code -generator, though. So: - - * We zap the used-once info in the worker-wrapper; - see Note [Zapping Used Once info in WorkWrap] in - GHC.Core.Opt.WorkWrap. - If it's not reliable, it's better not to have it at all. - - * Just before TidyCore, we add a pass of the demand analyser, - but WITHOUT subsequent worker/wrapper and simplifier, - right before TidyCore. See SimplCore.getCoreToDo. - - This way, correct information finds its way into the module interface - (strictness signatures!) and the code generator (single-entry thunks!) - -Note that, in contrast, the single-call information (CM(..)) /can/ be +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.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.Builtin.PrimOps +import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) +import GHC.Types.Unique.Set +import GHC.Types.Unique.MemoFun +import GHC.Types.RepType + + +{- +************************************************************************ +* * +\subsection{Top level stuff} +* * +************************************************************************ +-} + +-- | Options for the demand analysis +data DmdAnalOpts = DmdAnalOpts + { dmd_strict_dicts :: !Bool + -- ^ Value of `-fdicts-strict` (on by default). + -- When set, all functons are implicitly strict in dictionary args. + , dmd_do_boxity :: !Bool + -- ^ Governs whether the analysis should update boxity signatures. + -- See Note [Don't change boxity without worker/wrapper]. + , dmd_unbox_width :: !Int + -- ^ Value of `-fdmd-unbox-width`. + -- See Note [Unboxed demand on function bodies returning small products] + , dmd_max_worker_args :: !Int + -- ^ Value of `-fmax-worker-args`. + -- Don't unbox anything if we end up with more than this many args. + } + +-- This is a strict alternative to (,) +-- See Note [Space Leaks in Demand Analysis] +data WithDmdType a = WithDmdType !DmdType !a + +getAnnotated :: WithDmdType a -> a +getAnnotated (WithDmdType _ a) = a + +data DmdResult a b = R !a !b + +-- | 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 +-- [Stamp out space leaks in demand analysis]) +dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram +dmdAnalProgram opts fam_envs rules binds + = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds + where + -- See Note [Analysing top-level bindings] + -- and Note [Why care for top-level demand annotations?] + go _ [] = WithDmdType nopDmdType [] + go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body + where + anal_body env' + | WithDmdType body_ty bs' <- go env' bs + = WithDmdType (add_exported_uses env' body_ty (bindersOf b)) bs' + + cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b] + cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') + + add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType + add_exported_uses env = foldl' (add_exported_use env) + + -- If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@ + -- corresponds to the demand type of @(id, e)@, but is a lot more direct. + -- See Note [Analysing top-level bindings]. + add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType + add_exported_use env dmd_ty id + | isExportedId id || elemVarSet id rule_fvs + -- See Note [Absence analysis for stable unfoldings and RULES] + = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id)) + | otherwise + = dmd_ty + + rule_fvs :: IdSet + rule_fvs = rulesRhsFreeIds rules + +-- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings +-- that satisfy this function. +-- +-- Basically, we want to know how top-level *functions* are *used* +-- (e.g. called). The information will always be lazy. +-- Any other top-level bindings are boring. +-- +-- See also Note [Why care for top-level demand annotations?]. +isInterestingTopLevelFn :: Id -> Bool +-- SG tried to set this to True and got a +2% ghc/alloc regression in T5642 +-- (which is dominated by the Simplifier) at no gain in analysis precision. +-- If there was a gain, that regression might be acceptable. +-- Plus, we could use LetUp for thunks and share some code with local let +-- bindings. +isInterestingTopLevelFn id = typeArity (idType id) > 0 + +{- Note [Stamp out space leaks in demand analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand analysis pass outputs a new copy of the Core program in +which binders have been annotated with demand and strictness +information. It's tiresome to ensure that this information is fully +evaluated everywhere that we produce it, so we just run a single +seqBinds over the output before returning it, to ensure that there are +no references holding on to the input Core program. + +This makes a ~30% reduction in peak memory usage when compiling +DynFlags (cf #9675 and #13426). + +This is particularly important when we are doing late demand analysis, +since we don't do a seqBinds at any point thereafter. Hence code +generation would hold on to an extra copy of the Core program, via +unforced thunks in demand or strictness information; and it is the +most memory-intensive part of the compilation process, so this added +seqBinds makes a big difference in peak memory usage. + +Note [Don't change boxity without worker/wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (T21754) + f n = n+1 + {-# NOINLINE f #-} +With `-fno-worker-wrapper`, we should not give `f` a boxity signature that says +that it unboxes its argument! Client modules would never be able to cancel away +the box for n. Likewise we shouldn't give `f` the CPR property. + +Similarly, in the last run of DmdAnal before codegen (which does not have a +worker/wrapper phase) we should not change boxity in any way. Remember: an +earlier result of the demand analyser, complete with worker/wrapper, has aleady +given a demand signature (with boxity info) to the function. +(The "last run" is mainly there to attach demanded-once info to let-bindings.) + +In general, we should not run Note [Boxity analysis] unless worker/wrapper +follows to exploit the boxity and make sure that calling modules can observe the +reported boxity. + +Hence DmdAnal is configured by a flag `dmd_do_boxity` that is True only +if worker/wrapper follows after DmdAnal. If it is not set, and the signature +is not subject to Note [Boxity for bottoming functions], DmdAnal tries +to transfer over the previous boxity to the new demand signature, in +`setIdDmdAndBoxSig`. + +Why isn't CprAnal configured with a similar flag? Because if we aren't going to +do worker/wrapper we don't run CPR analysis at all. (see GHC.Core.Opt.Pipeline) + +It might be surprising that we only try to preserve *arg* boxity, not boxity on +FVs. But FV demands won't make it into interface files anyway, so it's a waste +of energy. +Besides, W/W zaps the `DmdEnv` portion of a signature, so we don't know the old +boxity to begin with; see Note [Zapping DmdEnv after Demand Analyzer]. + +Note [Analysing top-level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a CoreProgram like + e1 = ... + n1 = ... + e2 = \a b -> ... fst (n1 a b) ... + n2 = \c d -> ... snd (e2 c d) ... + ... +where e* are exported, but n* are not. +Intuitively, we can see that @n1@ is only ever called with two arguments +and in every call site, the first component of the result of the call +is evaluated. Thus, we'd like it to have idDemandInfo @LC(L,C(M,P(1L,A))@. +NB: We may *not* give e2 a similar annotation, because it is exported and +external callers might use it in arbitrary ways, expressed by 'topDmd'. +This can then be exploited by Nested CPR and eta-expansion, +see Note [Why care for top-level demand annotations?]. + +How do we get this result? Answer: By analysing the program as if it was a let +expression of this form: + let e1 = ... in + let n1 = ... in + let e2 = ... in + let n2 = ... in + (e1,e2, ...) +E.g. putting all bindings in nested lets and returning all exported binders in a tuple. +Of course, we will not actually build that CoreExpr! Instead we faithfully +simulate analysis of said expression by adding the free variable 'DmdEnv' +of @e*@'s strictness signatures to the 'DmdType' we get from analysing the +nested bindings. + +And even then the above form blows up analysis performance in T10370: +If @e1@ uses many free variables, we'll unnecessarily carry their demands around +with us from the moment we analyse the pair to the moment we bubble back up to +the binding for @e1@. So instead we analyse as if we had + let e1 = ... in + (e1, let n1 = ... in + ( let e2 = ... in + (e2, let n2 = ... in + ( ...)))) +That is, a series of right-nested pairs, where the @fst@ are the exported +binders of the last enclosing let binding and @snd@ continues the nested +lets. + +Variables occurring free in RULE RHSs are to be handled the same as exported Ids. +See also Note [Absence analysis for stable unfoldings and RULES]. + +Note [Why care for top-level demand annotations?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Reading Note [Analysing top-level bindings], you might think that we go through +quite some trouble to get useful demands for top-level bindings. They can never +be strict, for example, so why bother? + +First, we get to eta-expand top-level bindings that we weren't able to +eta-expand before without Call Arity. From T18894b: + module T18894b (f) where + eta :: Int -> Int -> Int + eta x = if fst (expensive x) == 13 then \y -> ... else \y -> ... + f m = ... eta m 2 ... eta 2 m ... +Since only @f@ is exported, we see all call sites of @eta@ and can eta-expand to +arity 2. + +The call demands we get for some top-level bindings will also allow Nested CPR +to unbox deeper. From T18894: + module T18894 (h) where + g m n = (2 * m, 2 `div` n) + {-# NOINLINE g #-} + h :: Int -> Int + h m = ... snd (g m 2) ... uncurry (+) (g 2 m) ... +Only @h@ is exported, hence we see that @g@ is always called in contexts were we +also force the division in the second component of the pair returned by @g@. +This allows Nested CPR to evaluate the division eagerly and return an I# in its +position. +-} + +{- +************************************************************************ +* * +\subsection{The analyser itself} +* * +************************************************************************ +-} + +-- | Analyse a binding group and its \"body\", e.g. where it is in scope. +-- +-- It calls a function that knows how to analyse this \"body\" given +-- an 'AnalEnv' with updated demand signatures for the binding group +-- (reflecting their 'idDmdSigInfo') and expects to receive a +-- 'DmdType' in return, which it uses to annotate the binding group with their +-- 'idDemandInfo'. +dmdAnalBind + :: TopLevelFlag + -> AnalEnv + -> SubDemand -- ^ Demand put on the "body" + -- (important for join points) + -> CoreBind + -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g. + -- where the binding is in scope + -> WithDmdType (DmdResult CoreBind a) +dmdAnalBind top_lvl env dmd bind anal_body = case bind of + NonRec id rhs + | useLetUp top_lvl id + -> dmdAnalBindLetUp top_lvl env_rhs id rhs anal_body + _ -> dmdAnalBindLetDown top_lvl env_rhs dmd bind anal_body + where + env_rhs = enterDFun bind env + +-- | Annotates uninteresting top level functions ('isInterestingTopLevelFn') +-- with 'topDmd', the rest with the given demand. +setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id +setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of + TopLevel | not (isInterestingTopLevelFn id) -> topDmd + _ -> dmd + +-- | Update the demand signature, but be careful not to change boxity info if +-- `dmd_do_boxity` is True or if the signature is bottom. +-- See Note [Don't change boxity without worker/wrapper] +-- and Note [Boxity for bottoming functions]. +setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id +setIdDmdAndBoxSig opts id sig = setIdDmdSig id $ + if dmd_do_boxity opts || isBottomingSig sig + then sig + else transferArgBoxityDmdSig (idDmdSig id) sig + +-- | Let bindings can be processed in two ways: +-- Down (RHS before body) or Up (body before RHS). +-- This function handles the up variant. +-- +-- It is very simple. For let x = rhs in body +-- * Demand-analyse 'body' in the current environment +-- * Find the demand, 'rhs_dmd' placed on 'x' by 'body' +-- * Demand-analyse 'rhs' in 'rhs_dmd' +-- +-- This is used for a non-recursive local let without manifest lambdas (see +-- 'useLetUp'). +-- +-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”. +dmdAnalBindLetUp :: TopLevelFlag + -> AnalEnv + -> Id + -> CoreExpr + -> (AnalEnv -> WithDmdType a) + -> WithDmdType (DmdResult CoreBind a) +dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) + where + WithDmdType body_ty body' = anal_body (addInScopeAnalEnv env id) + -- See Note [Bringing a new variable into scope] + WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id + -- See Note [Finalising boxity for demand signatures] + + id_dmd' = finaliseLetBoxity env (idType id) id_dmd + !id' = setBindIdDemandInfo top_lvl id id_dmd' + (rhs_ty, rhs') = dmdAnalStar env id_dmd' rhs + + -- See Note [Absence analysis for stable unfoldings and RULES] + rule_fvs = bndrRuleAndUnfoldingIds id + final_ty = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs + +-- | Let bindings can be processed in two ways: +-- Down (RHS before body) or Up (body before RHS). +-- This function handles the down variant. +-- +-- It computes a demand signature (by means of 'dmdAnalRhsSig') and uses +-- that at call sites in the body. +-- +-- It is used for toplevel definitions, recursive definitions and local +-- non-recursive definitions that have manifest lambdas (cf. 'useLetUp'). +-- Local non-recursive definitions without a lambda are handled with LetUp. +-- +-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. +dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) +dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of + NonRec id rhs + | (env', lazy_fv, id1, rhs1) <- + dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs + -> do_rest env' lazy_fv [(id1, rhs1)] (uncurry NonRec . only) + Rec pairs + | (env', lazy_fv, pairs') <- dmdFix top_lvl env dmd pairs + -> do_rest env' lazy_fv pairs' Rec + where + do_rest env' lazy_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body') + where + WithDmdType body_ty body' = anal_body env' + -- see Note [Lazy and unleashable free variables] + dmd_ty = addLazyFVs body_ty lazy_fv + WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1) + -- Important to force this as build_bind might not force it. + !pairs2 = strictZipWith do_one pairs1 id_dmds + do_one (id', rhs') dmd = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs' + -- If the actual demand is better than the vanilla call + -- demand, you might think that we might do better to re-analyse + -- the RHS with the stronger demand. + -- But (a) That seldom happens, because it means that *every* path in + -- the body of the let has to use that stronger demand + -- (b) It often happens temporarily in when fixpointing, because + -- the recursive function at first seems to place a massive demand. + -- But we don't want to go to extra work when the function will + -- probably iterate to something less demanding. + -- In practice, all the times the actual demand on id2 is more than + -- the vanilla call demand seem to be due to (b). So we don't + -- bother to re-analyse the RHS. + +-- | Mimic the effect of 'GHC.Core.Prep.mkFloat', turning non-trivial argument +-- expressions/RHSs into a proper let-bound thunk (lifted) or a case (with +-- unlifted scrutinee). +anticipateANF :: CoreExpr -> Card -> Card +anticipateANF e n + | exprIsTrivial e = n -- trivial expr won't have a binding + | Just Unlifted <- typeLevity_maybe (exprType e) + , not (isAbs n && exprOkForSpeculation e) = case_bind n + | otherwise = let_bind n + where + case_bind _ = C_11 -- evaluated exactly once + let_bind = oneifyCard -- evaluated at most once + +-- Do not process absent demands +-- Otherwise act like in a normal demand analysis +-- See ↦* relation in the Cardinality Analysis paper +dmdAnalStar :: AnalEnv + -> Demand -- This one takes a *Demand* + -> CoreExpr + -> (PlusDmdArg, CoreExpr) +dmdAnalStar env (n :* sd) e + -- NB: (:*) expands AbsDmd and BotDmd as needed + | WithDmdType dmd_ty e' <- dmdAnal env sd e + , n' <- anticipateANF e n + -- See Note [Anticipating ANF in demand analysis] + -- and Note [Analysing with absent demand] + = (toPlusDmdArg $ multDmdType n' dmd_ty, e') + +-- Main Demand Analysis machinery +dmdAnal, dmdAnal' :: AnalEnv + -> SubDemand -- The main one takes a *SubDemand* + -> CoreExpr -> WithDmdType CoreExpr + +dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ + dmdAnal' env d e + +dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit) +dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact +dmdAnal' _ _ (Coercion co) + = WithDmdType (unitDmdType (coercionDmdEnv co)) (Coercion co) + +dmdAnal' env dmd (Var var) + = WithDmdType (dmdTransform env var dmd) (Var var) + +dmdAnal' env dmd (Cast e co) + = WithDmdType (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co)) (Cast e' co) + where + WithDmdType dmd_ty e' = dmdAnal env dmd e + +dmdAnal' env dmd (Tick t e) + = WithDmdType dmd_ty (Tick t e') + where + WithDmdType dmd_ty e' = dmdAnal env dmd e + +dmdAnal' env dmd (App fun (Type ty)) + = WithDmdType fun_ty (App fun' (Type ty)) + where + WithDmdType fun_ty fun' = dmdAnal env dmd fun + +-- Lots of the other code is there to make this +-- beautiful, compositional, application rule :-) +dmdAnal' env dmd (App fun arg) + = -- This case handles value arguments (type args handled above) + -- Crucially, coercions /are/ handled here, because they are + -- value arguments (#10288) + let + call_dmd = mkCalledOnceDmd dmd + WithDmdType fun_ty fun' = dmdAnal env call_dmd fun + (arg_dmd, res_ty) = splitDmdTy fun_ty + (arg_ty, arg') = dmdAnalStar env arg_dmd arg + in +-- pprTrace "dmdAnal:app" (vcat +-- [ text "dmd =" <+> ppr dmd +-- , text "expr =" <+> ppr (App fun arg) +-- , text "fun dmd_ty =" <+> ppr fun_ty +-- , text "arg dmd =" <+> ppr arg_dmd +-- , text "arg dmd_ty =" <+> ppr arg_ty +-- , text "res dmd_ty =" <+> ppr res_ty +-- , text "overall res dmd_ty =" <+> ppr (res_ty `plusDmdType` arg_ty) ]) + WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg') + +dmdAnal' env dmd (Lam var body) + | isTyVar var + = let + WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body + -- See Note [Bringing a new variable into scope] + in + WithDmdType body_ty (Lam var body') + + | otherwise + = let (n, body_dmd) = peelCallDmd dmd + -- body_dmd: a demand to analyze the body + + WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body + -- See Note [Bringing a new variable into scope] + WithDmdType lam_ty var' = annotateLamIdBndr env body_ty var + new_dmd_type = multDmdType n lam_ty + in + WithDmdType new_dmd_type (Lam var' body') + +dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) + -- Only one alternative. + -- If it's a DataAlt, it should be the only constructor of the type and we + -- can consider its field demands when analysing the scrutinee. + | want_precise_field_dmds alt_con + = let + rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + WithDmdType rhs_ty rhs' = dmdAnal rhs_env dmd rhs + WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs + WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr + !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + + -- Evaluation cardinality on the case binder is irrelevant and a no-op. + -- What matters is its nested sub-demand! + -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is + -- what we want, because then `seq` will put a `seqDmd` on its scrut. + (_ :* case_bndr_sd) = strictifyDmd case_bndr_dmd + + -- Compute demand on the scrutinee + -- FORCE the result, otherwise thunks will end up retaining the + -- whole DmdEnv + !(!bndrs', !scrut_sd) + | DataAlt _ <- alt_con + -- See Note [Demand on the scrutinee of a product case] + , let !scrut_sd = scrutSubDmd case_bndr_sd fld_dmds + -- See Note [Demand on case-alternative binders] + , let !fld_dmds' = fieldBndrDmds scrut_sd (length fld_dmds) + , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds' + = (bndrs', scrut_sd) + | otherwise + -- DEFAULT alts. Simply add demands and discard the evaluation + -- cardinality, as we evaluate the scrutinee exactly once. + = assert (null bndrs) (bndrs, case_bndr_sd) + + alt_ty3 + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + | exprMayThrowPreciseException (ae_fam_envs env) scrut + = deferAfterPreciseException alt_ty2 + | otherwise + = alt_ty2 + + WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut + res_ty = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty + in +-- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut +-- , text "dmd" <+> ppr dmd +-- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') +-- , text "scrut_sd" <+> ppr scrut_sd +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) $ + 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 + = False -- Not a product type, even though this is the + -- only remaining possible data constructor + | DefinitelyRecursive <- ae_rec_dc env dc + = False -- See Note [Demand analysis for recursive data constructors] + | otherwise + = True + want_precise_field_dmds (LitAlt {}) = False -- Like the non-product datacon above + want_precise_field_dmds DEFAULT = True + +dmdAnal' env dmd (Case scrut case_bndr ty alts) + = let -- Case expression with multiple alternatives + WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut + + WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr + !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd + WithDmdType alt_ty alts' = dmdAnalSumAlts env dmd case_bndr alts + + fam_envs = ae_fam_envs env + alt_ty2 + -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" + | exprMayThrowPreciseException fam_envs scrut + = deferAfterPreciseException alt_ty1 + | otherwise + = alt_ty1 + res_ty = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty + + in +-- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut +-- , text "scrut_ty" <+> ppr scrut_ty +-- , text "alt_ty1" <+> ppr alt_ty1 +-- , text "alt_ty2" <+> ppr alt_ty2 +-- , text "res_ty" <+> ppr res_ty ]) $ + WithDmdType res_ty (Case scrut' case_bndr' ty alts') + +dmdAnal' env dmd (Let bind body) + = WithDmdType final_ty (Let bind' body') + where + !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go' + go' !env' = dmdAnal env' dmd body + +-- | A simple, syntactic analysis of whether an expression MAY throw a precise +-- exception when evaluated. It's always sound to return 'True'. +-- See Note [Which scrutinees may throw precise exceptions]. +exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool +exprMayThrowPreciseException envs e + | not (forcesRealWorld envs (exprType e)) + = False -- 1. in the Note + | (Var f, _) <- collectArgs e + , Just op <- isPrimOpId_maybe f + , op /= RaiseIOOp + = False -- 2. in the Note + | (Var f, _) <- collectArgs e + , Just fcall <- isFCallId_maybe f + , not (isSafeForeignCall fcall) + = False -- 3. in the Note + | otherwise + = True -- _. in the Note + +-- | Recognises types that are +-- * @State# RealWorld@ +-- * Unboxed tuples with a @State# RealWorld@ field +-- modulo coercions. This will detect 'IO' actions (even post Nested CPR! See +-- T13380e) and user-written variants thereof by their type. +forcesRealWorld :: FamInstEnvs -> Type -> Bool +forcesRealWorld fam_envs ty + | ty `eqType` realWorldStatePrimTy + = True + | Just (tc, tc_args, _co) <- normSplitTyConApp_maybe fam_envs ty + , isUnboxedTupleTyCon tc + , let field_tys = dataConInstArgTys (tyConSingleDataCon tc) tc_args + = any (eqType realWorldStatePrimTy . scaledThing) field_tys + | otherwise + = False + +dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt] +dmdAnalSumAlts _ _ _ [] = WithDmdType botDmdType [] + -- Base case is botDmdType, for empty case alternatives + -- This is a unit for lubDmdType, and the right result + -- when there really are no alternatives +dmdAnalSumAlts env dmd case_bndr (alt:alts) + = let + WithDmdType cur_ty alt' = dmdAnalSumAlt env dmd case_bndr alt + WithDmdType rest_ty alts' = dmdAnalSumAlts env dmd case_bndr alts + in WithDmdType (lubDmdType cur_ty rest_ty) (alt':alts') + + +dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt +dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) + | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs) + -- See Note [Bringing a new variable into scope] + , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs + , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs + , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr + -- See Note [Demand on case-alternative binders] + -- we can't use the scrut_sd, because it says 'Prod' and we'll use + -- topSubDmd anyway for scrutinees of sum types. + scrut_sd = scrutSubDmd case_bndr_sd dmds + dmds' = fieldBndrDmds scrut_sd (length dmds) + -- Do not put a thunk into the Alt + !new_ids = setBndrsDemandInfo bndrs dmds' + = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $ + WithDmdType alt_ty (Alt con new_ids rhs') + +-- See Note [Demand on the scrutinee of a product case] +scrutSubDmd :: SubDemand -> [Demand] -> SubDemand +scrutSubDmd case_sd fld_dmds = + -- pprTraceWith "scrutSubDmd" (\scrut_sd -> ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) $ + case_sd `plusSubDmd` mkProd Unboxed fld_dmds + +-- See Note [Demand on case-alternative binders] +fieldBndrDmds :: SubDemand -- on the scrutinee + -> Arity + -> [Demand] -- Final demands for the components of the DataCon +fieldBndrDmds scrut_sd n_flds = + case viewProd n_flds scrut_sd of + Just (_, ds) -> ds + Nothing -> replicate n_flds topDmd + -- Either an arity mismatch or scrut_sd was a call demand. + -- See Note [Untyped demand on case-alternative binders] + +{- +Note [Anticipating ANF in demand analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When analysing non-complex (e.g., trivial) thunks and complex function +arguments, we have to pretend that the expression is really in administrative +normal form (ANF), the conversion to which is done by CorePrep. + +Consider +``` +f x = let y = x |> co in y `seq` y `seq` () +``` +E.g., 'y' is a let-binding with a trivial RHS. That may occur if 'y' can't be +inlined, for example. Now, is 'x' used once? It may appear as if that is the +case, since its only occurrence is in 'y's memoised RHS. But actually, CorePrep +will *not* allocate a thunk for 'y', because it is trivial and could just +re-use the memoisation mechanism of 'x'! By saying that 'x' is used once it +becomes a single-entry thunk and a call to 'f' will evaluate it twice. +The same applies to trivial arguments, e.g., `f z` really evaluates `z` twice. + +So, somewhat counter-intuitively, trivial arguments and let RHSs will *not* be +memoised. On the other hand, evaluation of non-trivial arguments and let RHSs +*will* be memoised. In fact, consider the effect of conversion to ANF on complex +function arguments (as done by 'GHC.Core.Prep.mkFloat'): +``` +f2 (g2 x) ===> let y = g2 x in f2 y (if `y` is lifted) +f3 (g3 x) ===> case g3 x of y { __DEFAULT -> f3 y } (if `y` is not lifted) +``` +So if a lifted argument like `g2 x` is complex enough, it will be memoised. +Regardless how many times 'f2' evaluates its parameter, the argument will be +evaluated at most once to WHNF. +Similarly, when an unlifted argument like `g3 x` is complex enough, we will +evaluate it *exactly* once to WHNF, no matter how 'f3' evaluates its parameter. + +Note that any evaluation beyond WHNF is not affected by memoisation. So this +Note affects the outer 'Card' of a 'Demand', but not its nested 'SubDemand'. +'anticipateANF' predicts the effect of case-binding and let-binding complex +arguments, as well as the lack of memoisation for trivial let RHSs. +In particular, this takes care of the gripes in +Note [Analysing with absent demand] relating to unlifted types. + +Note [Analysing with absent demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we analyse an expression with demand A. The "A" means +"absent", so this expression will never be needed. What should happen? +There are several wrinkles: + +* We *do* want to analyse the expression regardless. + Reason: Note [Always analyse in virgin pass] + + But we can post-process the results to ignore all the usage + demands coming back. This is done by 'multDmdType' with the appropriate + (absent) evaluation cardinality A or B. + +* Nevertheless, which sub-demand should we pick for analysis? + Since the demand was absent, any would do. Worker/wrapper will replace + absent bindings with an absent filler anyway, so annotations in the RHS + of an absent binding don't matter much. + Picking 'botSubDmd' would be the most useful, but would also look a bit + misleading in the Core output of DmdAnal, because all nested annotations would + be bottoming. Better pick 'seqSubDmd', so that we annotate many of those + nested bindings with A themselves. + +* Since we allow unlifted arguments that are not ok-for-speculation, + we need to be extra careful in the following situation, because unlifted + values are evaluated even if they are not used. Example from #9254: + f :: (() -> (# Int#, () #)) -> () + -- Strictness signature is + -- <1C(1,P(A,1L))> + -- I.e. calls k, but discards first component of result + f k = case k () of (# _, r #) -> r + + g :: Int -> () + g y = f (\n -> (# case y of I# y2 -> y2, n #)) + + Here, f's strictness signature says (correctly) that it calls its argument + function and ignores the first component of its result. + + But in function g, we *will* evaluate the 'case y of ...', because it has type + Int#. So in the program as written, 'y' will be evaluated. Hence we must + record this usage of 'y', else 'g' will say 'y' is absent, and will w/w so + that 'y' is bound to an absent filler (see Note [Absent fillers]), leading + to a crash when 'y' is evaluated. + + Now, worker/wrapper could be smarter and replace `case y of I# y2 -> y2` + with a suitable absent filler such as `RUBBISH[IntRep] @Int#`. + But as long as worker/wrapper isn't equipped to do so, we must be cautious, + and follow Note [Anticipating ANF in demand analysis]. That is, in + 'dmdAnalStar', we will set the evaluation cardinality to C_11, anticipating + the case binding of the complex argument `case y of I# y2 -> y2`. This + cardinlities' only effect is in the call to 'multDmdType', where it makes sure + that the demand on the arg's free variable 'y' is not absent and strict, so + that it is ultimately passed unboxed to 'g'. + +Note [Always analyse in virgin pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tricky point: make sure that we analyse in the 'virgin' pass. Consider + rec { f acc x True = f (...rec { g y = ...g... }...) + f acc x False = acc } +In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. +That might mean that we analyse the sub-expression containing the +E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* +E, but just returned botType. + +Then in the *next* (non-virgin) iteration for 'f', we might analyse E +in a weaker demand, and that will trigger doing a fixpoint iteration +for g. But *because it's not the virgin pass* we won't start g's +iteration at bottom. Disaster. (This happened in $sfibToList' of +nofib/spectral/fibheaps.) + +So in the virgin pass we make sure that we do analyse the expression +at least once, to initialise its signatures. + +Note [Which scrutinees may throw precise exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is the specification of 'exprMayThrowPreciseExceptions', +which is important for Scenario 2 of +Note [Precise exceptions and strictness analysis] in GHC.Types.Demand. + +For an expression @f a1 ... an :: ty@ we determine that + 1. False If ty is *not* @State# RealWorld@ or an unboxed tuple thereof. + This check is done by 'forcesRealWorld'. + (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') + _. 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). + See haddock on GHC.Types.ForeignCall.PlayRisky. + +We *need* to return False in those cases, because + 1. We would lose too much strictness in pure code, all over the place. + 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, + 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. + +In !3014 we tried a more sophisticated analysis by introducing ConOrDiv (nic) +to the Divergence lattice, but in practice it turned out to be hard to untaint +from 'topDiv' to 'conDiv', leading to bugs, performance regressions and +complexity that didn't justify the single fixed testcase T13380c. + +Note [Demand analysis for recursive data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +T11545 features a single-product, recursive data type + data A = A A A ... A + deriving Eq +Naturally, `(==)` is deeply strict in `A` and in fact will never terminate. That +leads to very large (exponential in the depth) demand signatures and fruitless +churn in boxity analysis, demand analysis and worker/wrapper. + +So we detect `A` as a recursive data constructor (see +Note [Detecting recursive data constructors]) analysing `case x of A ...` +and simply assume L for the demand on field binders, which is the same code +path as we take for sum types. This code happens in want_precise_field_dmds +in the Case equation for dmdAnal. + +Combined with the B demand on the case binder, we get the very small demand +signature <1S><1S>b on `(==)`. This improves ghc/alloc performance on T11545 +tenfold! See also Note [CPR for recursive data constructors] which describes the +sibling mechanism in CPR analysis. + +Note [Demand on the scrutinee of a product case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When figuring out the demand on the scrutinee of a product case, +we use the demands of the case alternative, i.e. id_dmds. +But note that these include the demand on the case binder; +see Note [Demand on case-alternative binders]. +This is crucial. Example: + f x = case x of y { (a,b) -> k y a } +If we just take scrut_demand = 1P(L,A), then we won't pass x to the +worker, so the worker will rebuild + x = (a, absent-error) +and that'll crash. + +Note [Demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand on a binder in a case alternative comes + (a) From the demand on the binder itself + (b) From the demand on the case binder +Forgetting (b) led directly to #10148. + +Example. Source code: + f x@(p,_) = if p then foo x else True + + foo (p,True) = True + foo (p,q) = foo (q,p) + +After strictness analysis, forgetting (b): + f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) -> + case x_an1 + of wild_X7 [Dmd=MP(ML,ML)] + { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) -> + case p_an2 of _ { + False -> GHC.Types.True; + True -> foo wild_X7 } + +Note that ds_dnz is syntactically dead, but the expression bound to it is +reachable through the case binder wild_X7. Now watch what happens if we inline +foo's wrapper: + f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) -> + case x_an1 + of _ [Dmd=MP(ML,ML)] + { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) -> + case p_an2 of _ { + False -> GHC.Types.True; + True -> $wfoo_soq GHC.Types.True ds_dnz } + +Look at that! ds_dnz has come back to life in the call to $wfoo_soq! A second +run of demand analysis would no longer infer ds_dnz to be absent. +But unlike occurrence analysis, which infers properties of the *syntactic* +shape of the program, the results of demand analysis describe expressions +*semantically* and are supposed to be mostly stable across Simplification. +That's why we should better account for (b). +In #10148, we ended up emitting a single-entry thunk instead of an updateable +thunk for a let binder that was an an absent case-alt binder during DmdAnal. + +This is needed even for non-product types, in case the case-binder +is used but the components of the case alternative are not. + +Note [Untyped demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With unsafeCoerce, #8037 and #22039 taught us that the demand on the case binder +may be a call demand or have a different number of fields than the constructor +of the case alternative it is used in. From T22039: + + blarg :: (Int, Int) -> Int + blarg (x,y) = x+y + -- blarg :: <1!P(1L,1L)> + + f :: Either Int Int -> Int + f Left{} = 0 + f e = blarg (unsafeCoerce e) + ==> { desugars to } + f = \ (ds_d1nV :: Either Int Int) -> + case ds_d1nV of wild_X1 { + Left ds_d1oV -> lvl_s1Q6; + Right ipv_s1Pl -> + blarg + (case unsafeEqualityProof @(*) @(Either Int Int) @(Int, Int) of + { UnsafeRefl co_a1oT -> + wild_X1 `cast` (Sub (Sym co_a1oT) :: Either Int Int ~R# (Int, Int)) + }) + } + +The case binder `e`/`wild_X1` has demand 1!P(1L,1L), with two fields, from the call +to `blarg`, but `Right` only has one field. Although the code will crash when +executed, we must be able to analyse it in 'fieldBndrDmds' and conservatively +approximate with Top instead of panicking because of the mismatch. +In #22039, this kind of code was guarded behind a safe `cast` and thus dead +code, but nevertheless led to a panic of the compiler. + +You might wonder why the same problem doesn't come up when scrutinising a +product type instead of a sum type. It appears that for products, `wild_X1` +will be inlined before DmdAnal. + +See also Note [mkWWstr and unsafeCoerce] for a related issue. + +Note [Aggregated demand for cardinality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +FIXME: This Note should be named [LetUp vs. LetDown] and probably predates +said separation. SG + +We use different strategies for strictness and usage/cardinality to +"unleash" demands captured on free variables by bindings. Let us +consider the example: + +f1 y = let {-# NOINLINE h #-} + h = y + in (h, h) + +We are interested in obtaining cardinality demand U1 on |y|, as it is +used only in a thunk, and, therefore, is not going to be updated any +more. Therefore, the demand on |y|, captured and unleashed by usage of +|h| is U1. However, if we unleash this demand every time |h| is used, +and then sum up the effects, the ultimate demand on |y| will be U1 + +U1 = U. In order to avoid it, we *first* collect the aggregate demand +on |h| in the body of let-expression, and only then apply the demand +transformer: + +transf[x](U) = {y |-> U1} + +so the resulting demand on |y| is U1. + +The situation is, however, different for strictness, where this +aggregating approach exhibits worse results because of the nature of +|both| operation for strictness. Consider the example: + +f y c = + let h x = y |seq| x + in case of + True -> h True + False -> y + +It is clear that |f| is strict in |y|, however, the suggested analysis +will infer from the body of |let| that |h| is used lazily (as it is +used in one branch only), therefore lazy demand will be put on its +free variable |y|. Conversely, if the demand on |h| is unleashed right +on the spot, we will get the desired result, namely, that |f| is +strict in |y|. + + +************************************************************************ +* * + Demand transformer +* * +************************************************************************ +-} + +dmdTransform :: AnalEnv -- ^ The analysis environment + -> Id -- ^ The variable + -> SubDemand -- ^ The evaluation context of the var + -> 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" +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) + , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs + = dmd_ty + -- Dictionary component selectors + -- Used to be controlled by a flag. + -- See #18429 for some perf measurements. + | Just _ <- isClassOpId_maybe var + = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr (idDmdSig var) $$ ppr sd) $ + dmdTransformDictSelSig (idDmdSig var) sd + -- Imported functions + | isGlobalId var + , let res = dmdTransformSig (idDmdSig var) sd + = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idDmdSig var), ppr sd, ppr res]) + res + -- Top-level or local let-bound thing for which we use LetDown ('useLetUp'). + -- In that case, we have a strictness signature to unleash in our AnalEnv. + | Just (sig, top_lvl) <- lookupSigEnv env var + , let fn_ty = dmdTransformSig sig sd + = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr sd, ppr fn_ty]) $ + case top_lvl of + NotTopLevel -> addVarDmd fn_ty var (C_11 :* sd) + 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 + -- 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 + | otherwise + -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later + -- Everything else: + -- * Local let binders for which we use LetUp (cf. 'useLetUp') + -- * Lambda binders + -- * Case and constructor field binders + | otherwise + = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $ + unitDmdType (unitVarEnv var (C_11 :* sd)) + +{- ********************************************************************* +* * + Binding right-hand sides +* * +********************************************************************* -} + +-- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature +-- for the LetDown rule. It works as follows: +-- +-- * assuming the weakest possible body sub-demand, L +-- * looking at the definition +-- * determining a strictness signature +-- +-- Since it assumed a body sub-demand of L, the resulting signature is +-- applicable at any call site. +dmdAnalRhsSig + :: TopLevelFlag + -> RecFlag + -> AnalEnv -> SubDemand + -> Id -> CoreExpr + -> (AnalEnv, DmdEnv, Id, CoreExpr) +-- 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 + = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr lazy_fv) $ + (final_env, lazy_fv, final_id, final_rhs) + where + threshold_arity = thresholdArity id rhs + + rhs_dmd = mkCalledOnceDmds threshold_arity body_dmd + + body_dmd + | isJoinId id + -- 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 + -- 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 + DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty + -- See Note [Boxity for bottoming functions] + (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity rhs' rhs_div + `orElse` (rhs_dmds, rhs') + + sig = mkDmdSigForArity threshold_arity (DmdType sig_fv final_rhs_dmds rhs_div) + + opts = ae_opts env + final_id = setIdDmdAndBoxSig opts id sig + !final_env = extendAnalEnv top_lvl env final_id sig + + -- See Note [Aggregated demand for cardinality] + -- FIXME: That Note doesn't explain the following lines at all. The reason + -- is really much different: When we have a recursive function, we'd + -- have to also consider the free vars of the strictness signature + -- when checking whether we found a fixed-point. That is expensive; + -- we only want to check whether argument demands of the sig changed. + -- reuseEnv makes it so that the FV results are stable as long as the + -- last argument demands were. Strictness won't change. But used-once + -- might turn into used-many even if the signature was stable and + -- we'd have to do an additional iteration. reuseEnv makes sure that + -- we never get used-once info for FVs of recursive functions. + -- See #14816 where we try to get rid of reuseEnv. + rhs_fv1 = case rec_flag of + Recursive -> reuseEnv rhs_fv + NonRecursive -> rhs_fv + + -- See Note [Absence analysis for stable unfoldings and RULES] + rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id + + -- See Note [Lazy and unleashable free variables] + !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 + +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 +resultType_maybe id + | (pis,ret_ty) <- splitPiTys (idType id) + , count isAnonPiTyBinder pis == idArity id + = Just $! ret_ty + | otherwise + = Nothing + +unboxedWhenSmall :: AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand +-- See Note [Unboxed demand on function bodies returning small products] +unboxedWhenSmall _ _ Nothing sd = sd +unboxedWhenSmall env rec_flag (Just ret_ty) sd = go 1 ret_ty sd + where + -- Magic constant, bounding the depth of optimistic 'Unboxed' flags. We + -- might want to minmax in the future. + max_depth | isRec rec_flag = 3 -- So we get at most something as deep as !P(L!P(L!L)) + | otherwise = 1 -- Otherwise be unbox too deep in T18109, T18174 and others and get a bunch of stack overflows + go :: Int -> Type -> SubDemand -> SubDemand + 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 + , dataConRepArity dc <= dmd_unbox_width (ae_opts env) + , Just (_, ds) <- viewProd (dataConRepArity dc) sd + , arg_tys <- map scaledThing $ dataConInstArgTys dc tc_args + , equalLength ds arg_tys + = mkProd Unboxed $! strictZipWith (go_dmd (depth+1)) arg_tys ds + | otherwise + = sd + + go_dmd :: Int -> Type -> Demand -> Demand + go_dmd depth ty dmd = case dmd of + AbsDmd -> AbsDmd + BotDmd -> BotDmd + n :* sd -> n :* go depth ty sd + +-- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines +-- whether we should process the binding up (body before rhs) or down (rhs +-- before body). +-- +-- We use LetDown if there is a chance to get a useful strictness signature to +-- unleash at call sites. LetDown is generally more precise than LetUp if we can +-- correctly guess how it will be used in the body, that is, for which incoming +-- demand the strictness signature should be computed, which allows us to +-- unleash higher-order demands on arguments at call sites. This is mostly the +-- case when +-- +-- * The binding takes any arguments before performing meaningful work (cf. +-- 'idArity'), in which case we are interested to see how it uses them. +-- * The binding is a join point, hence acting like a function, not a value. +-- As a big plus, we know *precisely* how it will be used in the body; since +-- it's always tail-called, we can directly unleash the incoming demand of +-- the let binding on its RHS when computing a strictness signature. See +-- [Demand analysis for join points]. +-- +-- Thus, if the binding is not a join point and its arity is 0, we have a thunk +-- and use LetUp, implying that we have no usable demand signature available +-- when we analyse the let body. +-- +-- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free +-- vars at most once, regardless of how many times it was forced in the body. +-- This makes a real difference wrt. usage demands. The other reason is being +-- able to unleash a more precise product demand on its RHS once we know how the +-- thunk was used in the let body. +-- +-- Characteristic examples, always assuming a single evaluation: +-- +-- * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that +-- the expression uses @y@ at most once. +-- * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that +-- @b@ is absent. +-- * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that +-- the expression uses @y@ strictly, because we have @f@'s demand signature +-- available at the call site. +-- * @join exit = 2*y in if a then exit else if b then exit else 3*y@ => +-- LetDown. Compared to LetUp, we find out that the expression uses @y@ +-- strictly, because we can unleash @exit@'s signature at each call site. +-- * For a more convincing example with join points, see Note [Demand analysis +-- for join points]. +-- +useLetUp :: TopLevelFlag -> Var -> Bool +useLetUp top_lvl f = isNotTopLevel top_lvl && idArity f == 0 && not (isJoinId f) + +{- Note [Demand analysis for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + g :: (Int,Int) -> Int + g (p,q) = p+q + + f :: T -> Int -> Int + f x p = g (join j y = (p,y) + in case x of + A -> j 3 + 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. + +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). + +Another win for join points! #13543. + +However, note that the strictness signature for a join point can +look a little puzzling. E.g. + + (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. + +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. + +The threshold we use is + +* Ordinary bindings: 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. + + 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. + +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. + +Note that there might, in principle, be functions for which we might want to +analyse for more incoming arguments than idArity. Example: + + f x = + if expensive + then \y -> ... y ... + else \y -> ... y ... + +We'd analyse `f` under a unary call demand C(1,L), corresponding to idArity +being 1. That's enough to look under the manifest lambda and find out how a +unary call would use `x`, but not enough to look into the lambdas in the if +branches. + +On the other hand, if we analysed for call demand C(1,C(1,L)), we'd get useful +strictness info for `y` (and more precise info on `x`) and possibly CPR +information, but + + * We would no longer be able to unleash the signature at unary call sites + + * Performing the worker/wrapper split based on this information would be + implicitly eta-expanding `f`, playing fast and loose with divergence and + even being unsound in the presence of newtypes, so we refrain from doing so. + Also see Note [Don't eta expand in w/w] in GHC.Core.Opt.WorkWrap. + +Since we only compute one signature, we do so for arity 1. Computing multiple +signatures for different arities (i.e., polyvariance) would be entirely +possible, if it weren't for the additional runtime and implementation +complexity. + +Note [idArity varies independently of dmdTypeDepth] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, an Id `f` has two independently varying attributes: + +* f's idArity, and +* the dmdTypeDepth of f's demand signature + +For example, if f's demand signature is , f's arity could be +greater than, or less than 2. Why? Because both are conservative +approximations: + +* Arity n means "does no expensive work until applied to at least n args" + (e.g. (f x1..xm) is cheap to bring to HNF for m co + +`go` might have a strictness signature of `<1L>`. The simplifier will identify +`go` as a nullary join point through `joinPointBinding_maybe` and float the +coercion into the binding, leading to an arity decrease: + + join go = (\x y -> `x` seq ...) |> co in go + +With the CoreLint check, we would have to zap `go`'s perfectly viable strictness +signature. + +However, in the case of a /bottoming/ signature, f : b, we /can/ +say that f's arity is no greater than 2, because it'd be false to say +that f does no work when applied to 3 args. Lint checks this constraint, +in `GHC.Core.Lint.lintLetBind`. + +Note [Demand analysis for trivial right-hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + foo = plusInt |> co +where plusInt is an arity-2 function with known strictness. Clearly +we want plusInt's strictness to propagate to foo! But because it has +no manifest lambdas, it won't do so automatically, and indeed 'co' might +have type (Int->Int->Int) ~ T. + +Fortunately, GHC.Core.Opt.Arity gives 'foo' arity 2, which is enough for LetDown to +forward plusInt's demand signature, and all is well (see Note [Newtype arity] in +GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity. + +Note [Absence analysis for stable unfoldings and RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticket #18638 shows that it's really important to do absence analysis +for stable unfoldings. Consider + + g = blah + + f = \x. ...no use of g.... + {- f's stable unfolding is f = \x. ...g... -} + +If f is ever inlined we use 'g'. But f's current RHS makes no use +of 'g', so if we don't look at the unfolding we'll mark g as Absent, +and transform to + + g = error "Entered absent value" + f = \x. ... + {- f's stable unfolding is f = \x. ...g... -} + +Now if f is subsequently inlined, we'll use 'g' and ... disaster. + +SOLUTION: if f has a stable unfolding, adjust its DmdEnv (the demands +on its free variables) so that no variable mentioned in its unfolding +is Absent. This is done by the function Demand.keepAliveDmdEnv. + +ALSO: do the same for Ids free in the RHS of any RULES for f. + +PS: You may wonder how it can be that f's optimised RHS has somehow +discarded 'g', but when f is inlined we /don't/ discard g in the same +way. I think a simple example is + g = (a,b) + f = \x. fst g + {-# INLINE f #-} + +Now f's optimised RHS will be \x.a, but if we change g to (error "..") +(since it is apparently Absent) and then inline (\x. fst g) we get +disaster. But regardless, #18638 was a more complicated version of +this, that actually happened in practice. + +Note [DmdAnal for DataCon wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We give DataCon wrappers a (necessarily flat) demand signature in +`GHC.Types.Id.Make.mkDataConRep`, so that passes such as the Simplifier can +exploit it via the call to `GHC.Core.Opt.Simplify.Utils.isStrictArgInfo` in +`GHC.Core.Opt.Simplify.Iteration.rebuildCall`. But during DmdAnal, we *ignore* +the demand signature of a DataCon wrapper, and instead analyse its unfolding at +every call site. + +The reason is that DataCon *worker*s have very precise demand transformers, +computed by `dmdTransformDataConSig`. It would be awkward if DataCon *wrappers* +would behave much less precisely during DmdAnal. Example: + + data T1 = MkT1 { get_x1 :: Int, get_y1 :: Int } + data T2 = MkT2 { get_x2 :: !Int, get_y2 :: Int } + f1 x y = get_x1 (MkT1 x y) + f2 x y = get_x2 (MkT2 x y) + +Here `MkT1` has no wrapper. `get_x1` puts a demand `!P(1!L,A)` on its argument, +and `dmdTransformDataConSig` will transform that demand to an absent demand on +`y` in `f1` and an unboxing demand on `x`. +But `MkT2` has a wrapper (to evaluate the first field). If demand analysis deals +with `MkT2` only through its demand signature, demand signatures can't transform +an incoming demand `P(1!L,A)` in a useful way, so we won't get an absent demand +on `y` in `f2` or see that `x` can be unboxed. That's a serious loss. + +The example above will not actually occur, because $WMkT2 would be inlined. +Nevertheless, we can get interesting sub-demands on DataCon wrapper +applications in boring contexts; see T22241. + +You might worry about the efficiency cost of demand-analysing datacon wrappers +at every call site. But in fact they are inlined /anyway/ in the Final phase, +which happens before DmdAnal, so few wrappers remain. And analysing the +unfoldings for the remaining calls (which are those in a boring context) will be +exactly as (in)efficent as if we'd inlined those calls. It turns out to be not +measurable in practice. + +See also Note [CPR for DataCon wrappers] in `GHC.Core.Opt.CprAnal`. + +Note [Boxity for bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (A) + indexError :: Show a => (a, a) -> a -> String -> b + -- Str=<..><1!P(S,S)><1S>b + indexError rng i s = error (show rng ++ show i ++ show s) + + get :: (Int, Int) -> Int -> [a] -> a + get p@(l,u) i xs + | l <= i, i < u = xs !! (i-u) + | otherwise = indexError p i "get" + +The hot path of `get` certainly wants to unbox `p` as well as `l` and +`u`, but the unimportant, diverging error path needs `l::a` and `u::a` +boxed, since `indexError` can't unbox them because they are polymorphic. +This pattern often occurs in performance sensitive code that does +bounds-checking. + +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/ +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. + +Then at call sites of `indexError`, we will end up doing some +reboxing, because `$windexError` still takes boxed arguments. This +reboxing should usually float into the slow, diverging code path; but +sometimes (sadly) it doesn't: see Note [Reboxed crud for bottoming calls]. + +Here is another important case (B): + f x = Just x -- Suppose f is not inlined for some reason + -- Main point: f takes its argument boxed + + wombat x = error (show (f x)) + + g :: Bool -> Int -> a + g True x = x+1 + g False x = wombat x + +Again we want `wombat` to pretend to take its Int-typed argument unboxed, +even though it has to pass it boxed to `f`, so that `g` can take its +argument unboxed (and rebox it before calling `wombat`). + +So here's what we do: while summarising `indexError`'s boxity signature in +`finaliseArgBoxities`: + +* To address (B), for bottoming functions, we start by using `unboxDeeplyDmd` + to make all its argument demands unboxed, right to the leaves; regardless + of what the analysis said. + +* To address (A), for bottoming functions, in the DontUnbox case when the + argument is a type variable, we /refrain/ from using trimBoxity. + (Remember the previous bullet: we have already doen `unboxDeeplyDmd`.) + +Wrinkle: + +* Remember Note [No lazy, Unboxed demands in demand signature]. So + unboxDeeplyDmd doesn't recurse into lazy demands. It's extremely unusual + to have lazy demands in the arguments of a bottoming function anyway. + But it can happen, when the demand analyser gives up because it + encounters a recursive data type; see Note [Demand analysis for recursive + data constructors]. + +Note [Reboxed crud for bottoming calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For functions like `get` in Note [Boxity for bottoming functions], it's clear +that the reboxed crud will be floated inside to the call site of `$windexError`. +But here's an example where that is not the case: +```hs +import GHC.Ix + +theresCrud :: Int -> Int -> Int +theresCrud x y = go x + where + go 0 = index (0,y) 0 + go 1 = index (x,y) 1 + go n = go (n-1) + {-# NOINLINE theresCrud #-} +``` +If you look at the Core, you'll see that `y` will be reboxed and used in the +two exit join points for the `$windexError` calls, while `x` is only reboxed in the +exit join point for `index (x,y) 1` (happens in lvl below): +``` +$wtheresCrud = \ ww ww1 -> + let { y = I# ww1 } in + join { lvl2 = ... case lvl1 ww y of wild { }; ... } in + join { lvl3 = ... case lvl y of wild { }; ... } in + ... +``` +This is currently a bug that we willingly accept and it's documented in #21128. + +See also Note [indexError] in base:GHC.Ix, which describes how we use +SPECIALISE to mitigate this problem for indexError. +-} + +{- ********************************************************************* +* * + Finalising boxity +* * +********************************************************************* -} + +{- Note [Finalising boxity for demand signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The worker/wrapper pass must strictly adhere to the boxity decisions +encoded in the demand signature, because that is the information that +demand analysis propagates throughout the program. Failing to +implement the strategy laid out in the signature can result in +reboxing in unexpected places. Hence, we must completely anticipate +unboxing decisions during demand analysis and reflect these decisions +in demand annotations. That is the job of 'finaliseArgBoxities', +which is defined here and called from demand analysis. + +Here is a list of different Notes it has to take care of: + + * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in + general, but still allow Note [Unboxing evaluated arguments] + * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)` + * Note [mkWWstr and unsafeCoerce] + +NB: Then, the worker/wrapper blindly trusts the boxity info in the +demand signature; that is why 'canUnboxArg' does not look at +strictness -- it is redundant to do so. + +Note [Finalising boxity for let-bound Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let x = e in body +where the demand on 'x' is 1!P(blah). We want to unbox x according to +Note [Thunk splitting] in GHC.Core.Opt.WorkWrap. We must do this because +worker/wrapper ignores strictness and looks only at boxity flags; so if +x's demand is L!P(blah) we might still split it (wrongly). We want to +switch to Boxed on any lazy demand. + +That is what finaliseLetBoxity does. It has no worker-arg budget, so it +is much simpler than finaliseArgBoxities. + +Note [No nested Unboxed inside Boxed in demand signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider +``` +f p@(x,y) + | even (x+y) = [] + | otherwise = [p] +``` +Demand analysis will infer that the function body puts a demand of `1P(1!L,1!L)` +on 'p', e.g., Boxed on the outside but Unboxed on the inside. But worker/wrapper +can't unbox the pair components without unboxing the pair! So we better say +`1P(1L,1L)` in the demand signature in order not to spread wrong Boxity info. +That happens via the call to trimBoxity in 'finaliseArgBoxities'/'finaliseLetBoxity'. + +Note [No lazy, Unboxed demands in demand signature] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider T19407: + + data Huge = Huge Bool () ... () -- think: DynFlags + data T = T { h :: Huge, n :: Int } + f t@(T h _) = g h t + g (H b _ ... _) t = if b then 1 else n t + +The body of `g` puts (approx.) demand `L!P(A,1)` on `t`. But we better +not put that demand in `g`'s demand signature, because worker/wrapper will not +in general unbox a lazy-and-unboxed demand like `L!P(..)`. +(The exception are known-to-be-evaluated arguments like strict fields, +see Note [Unboxing evaluated arguments].) + +The program above is an example where spreading misinformed boxity through the +signature is particularly egregious. If we give `g` that signature, then `f` +puts demand `S!P(1!P(1L,A,..),ML)` on `t`. Now we will unbox `t` in `f` it and +we get + + f (T (H b _ ... _) n) = $wf b n + $wf b n = $wg b (T (H b x ... x) n) + $wg = ... + +Massive reboxing in `$wf`! Solution: Trim boxity on lazy demands in +'trimBoxity', modulo Note [Unboxing evaluated arguments]. + +Note [Unboxing evaluated arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this program (due to Roman): + + data X a = X !a + + foo :: X Int -> Int -> Int + foo x@(X a) n = go 0 + where + go i | i < n = a + go (i+1) + | otherwise = 0 + +We want the worker for 'foo' to look like this: + + $wfoo :: Int# -> Int# -> Int# + +with the first argument unboxed, so that it is not eval'd each time around the +'go' loop (which would otherwise happen, since 'foo' is not strict in 'a'). It +is sound for the wrapper to pass an unboxed arg because X is strict +(see Note [Strictness and Unboxing] in "GHC.Core.Opt.DmdAnal"), so its argument +must be evaluated. And if we *don't* pass an unboxed argument, we can't even +repair it by adding a `seq` thus: + + foo (X a) n = a `seq` go 0 + +because the seq is discarded (very early) since X is strict! + +So here's what we do + +* Since this has nothing to do with how 'foo' uses 'a', we leave demand + analysis alone, but account for the additional evaluatedness when + annotating the binder 'finaliseArgBoxities', which will retain the Unboxed + boxity on 'a' in the definition of 'foo' in the demand 'L!P(L)'; meaning + it's used lazily but unboxed nonetheless. This seems to contradict Note + [No lazy, Unboxed demands in demand signature], but we know that 'a' is + evaluated and thus can be unboxed. + +* When 'finaliseArgBoxities' decides to unbox a record, it will zip the field demands + together with the respective 'StrictnessMark'. In case of 'x', it will pair + up the lazy field demand 'L!P(L)' on 'a' with 'MarkedStrict' to account for + the strict field. + +* Said 'StrictnessMark' is passed to the recursive invocation of 'go_args' in + 'finaliseArgBoxities' when deciding whether to unbox 'a'. 'a' was used lazily, but + since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'. + +* Worker/wrapper will consult 'canUnboxArg' for its unboxing decision. It will + /not/ look at the strictness bits of the demand, only at Boxity flags. As such, + it will happily unbox 'a' despite the lazy demand on it. + +The net effect is that boxity analysis and the w/w transformation are more +aggressive about unboxing the strict arguments of a data constructor than when +looking at strictness info exclusively. It is very much like (Nested) CPR, which +needs its nested fields to be evaluated in order for it to unbox nestedly. + +There is the usual danger of reboxing, which as usual we ignore. But +if X is monomorphic, and has an UNPACK pragma, then this optimisation +is even more important. We don't want the wrapper to rebox an unboxed +argument, and pass an Int to $wfoo! + +This works in nested situations like T10482 + + data family Bar a + data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) + newtype instance Bar Int = Bar Int + + foo :: Bar ((Int, Int), Int) -> Int -> Int + foo f k = case f of BarPair x y -> + case burble of + True -> case x of + BarPair p q -> ... + False -> ... + +The extra eagerness lets us produce a worker of type: + $wfoo :: Int# -> Int# -> Int# -> Int -> Int + $wfoo p# q# y# = ... + +even though the `case x` is only lazily evaluated. + +--------- Historical note ------------ +We used to add data-con strictness demands when demand analysing case +expression. However, it was noticed in #15696 that this misses some cases. For +instance, consider the program (from T10482) + + data family Bar a + data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) + newtype instance Bar Int = Bar Int + + foo :: Bar ((Int, Int), Int) -> Int -> Int + foo f k = + case f of + BarPair x y -> case burble of + True -> case x of + BarPair p q -> ... + False -> ... + +We really should be able to assume that `p` is already evaluated since it came +from a strict field of BarPair. This strictness would allow us to produce a +worker of type: + + $wfoo :: Int# -> Int# -> Int# -> Int -> Int + $wfoo p# q# y# = ... + +even though the `case x` is only lazily evaluated + +Indeed before we fixed #15696 this would happen since we would float the inner +`case x` through the `case burble` to get: + + foo f k = + case f of + BarPair x y -> case x of + BarPair p q -> case burble of + True -> ... + False -> ... + +However, after fixing #15696 this could no longer happen (for the reasons +discussed in ticket:15696#comment:76). This means that the demand placed on `f` +would then be significantly weaker (since the False branch of the case on +`burble` is not strict in `p` or `q`). + +Consequently, we now instead account for data-con strictness in mkWWstr_one, +applying the strictness demands to the final result of DmdAnal. The result is +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 +argument when, say given a strict record with zillions of fields. So we +limit the maximum number of worker args ('max_wkr_args') to the maximum of + - -fmax-worker-args=N + - The number of args in the original function; if it already has has + zillions of arguments we don't want to seek /fewer/ args in the worker. +(Maybe we should /add/ them instead of maxing?) + +We pursue a "layered" strategy for unboxing: we unbox the top level of the +argument(s), subject to budget; if there are any arguments left we unbox the +next layer, using that depleted budget. +Unboxing an argument *increases* the budget for the inner layer roughly +according to how many registers that argument takes (unboxed tuples take +multiple registers, see below), as determined by 'unariseArity'. +Budget is spent when we have to pass a non-absent field as a parameter. + +To achieve this, we use the classic almost-circular programming technique in +which we we write one pass that takes a lazy list of the Budgets for every +layer. The effect is that of a breadth-first search (over argument type and +demand structure) to compute Budgets followed by a depth-first search to +construct the product demands, but laziness allows us to do it all in one +pass and without intermediate data structures. + +Suppose we have -fmax-worker-args=4 for the remainder of this Note. +Then consider this example function: + + boxed :: (Int, Int) -> (Int, (Int, Int, Int)) -> Int + boxed (a,b) (c, (d,e,f)) = a + b + c + d + e + f + +With a budget of 4 args to spend (number of args is only 2), we'd be served well +to unbox both pairs, but not the triple. Indeed, that is what the algorithm +computes, and the following pictogram shows how the budget layers are computed. +Each layer is started with `n ~>`, where `n` is the budget at the start of the +layer. We write -n~> when we spend budget (and n is the remaining budget) and ++n~> when we earn budget. We separate unboxed args with ][ and indicate +inner budget threads becoming negative in braces {{}}, so that we see which +unboxing decision we do *not* commit to. Without further ado: + + 4 ~> ][ (a,b) -3~> ][ (c, ...) -2~> + ][ | | ][ | | + ][ | +-------------+ ][ | +-----------------+ + ][ | | ][ | | + ][ v v ][ v v + 2 ~> ][ +3~> a -2~> ][ b -1~> ][ +2~> c -1~> ][ (d, e, f) -0~> + ][ | ][ | ][ | ][ {{ | | | }} + ][ | ][ | ][ | ][ {{ | | +----------------+ }} + ][ v ][ v ][ v ][ {{ v +------v v }} + 0 ~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ {{ +1~> d -0~> ][ e -(-1)~> ][ f -(-2)~> }} + +Unboxing increments the budget we have on the next layer (because we don't need +to retain the boxed arg), but in turn the inner layer must afford to retain all +non-absent fields, each decrementing the budget. Note how the budget becomes +negative when trying to unbox the triple and the unboxing decision is "rolled +back". This is done by the 'positiveTopBudget' guard. + +There's a bit of complication as a result of handling unboxed tuples correctly; +specifically, handling nested unboxed tuples. Consider (#21737) + + unboxed :: (Int, Int) -> (# Int, (# Int, Int, Int #) #) -> Int + unboxed (a,b) (# c, (# d, e, f #) #) = a + b + c + d + e + f + +Recall that unboxed tuples will be flattened to individual arguments during +unarisation. Here, `unboxed` will have 5 arguments at runtime because of the +nested unboxed tuple, which will be flattened to 4 args. So it's best to leave +`(a,b)` boxed (because we already are above our arg threshold), but unbox `c` +through `f` because that doesn't increase the number of args post unarisation. + +Note that the challenge is that syntactically, `(# d, e, f #)` occurs in a +deeper layer than `(a, b)`. Treating unboxed tuples as a regular data type, we'd +make the same unboxing decisions as for `boxed` above; although our starting +budget is 5 (Here, the number of args is greater than -fmax-worker-args), it's +not enough to unbox the triple (we'd finish with budget -1). So we'd unbox `a` +through `c`, but not `d` through `f`, which is silly, because then we'd end up +having 6 arguments at runtime, of which `d` through `f` weren't unboxed. + +Hence we pretend that the fields of unboxed tuples appear in the same budget +layer as the tuple itself. For example at the top-level, `(# x,y #)` is to be +treated just like two arguments `x` and `y`. +Of course, for that to work, our budget calculations must initialise +'max_wkr_args' to 5, based on the 'unariseArity' of each Core arg: That would be +1 for the pair and 4 for the unboxed pair. Then when we decide whether to unbox +the unboxed pair, we *directly* recurse into the fields, spending our budget +on retaining `c` and (after recursing once more) `d` through `f` as arguments, +depleting our budget completely in the first layer. Pictorially: + + 5 ~> ][ (a,b) -4~> ][ (# c, ... #) + ][ {{ | | }} ][ c -3~> ][ (# d, e, f #) + ][ {{ | +-------+ }} ][ | ][ d -2~> ][ e -1~> ][ f -0~> + ][ {{ | | }} ][ | ][ | ][ | ][ | + ][ {{ v v }} ][ v ][ v ][ v ][ v + 0 ~> ][ {{ +1~> a -0~> ][ b -(-1)~> }} ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> + +As you can see, we have no budget left to justify unboxing `(a,b)` on the second +layer, which is good, because it would increase the number of args. Also note +that we can still unbox `c` through `f` in this layer, because doing so has a +net zero effect on budget. + +Note [The OPAQUE pragma and avoiding the reboxing of arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In https://gitlab.haskell.org/ghc/ghc/-/issues/13143 it was identified that when +a function 'f' with a NOINLINE pragma is W/W transformed, then the worker for +'f' should get the NOINLINE annotation, while the wrapper /should/ be inlined. + +That's because if the wrapper for 'f' had stayed NOINLINE, then any worker of a +W/W-transformed /caller of/ 'f' would immediately rebox any unboxed arguments +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 +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. +-} + +-- | How many registers does this type take after unarisation? +unariseArity :: Type -> Arity +unariseArity ty = length (typePrimRep ty) + +data Budgets = MkB !Arity Budgets -- An infinite list of arity budgets + +earnTopBudget :: Budgets -> Budgets +earnTopBudget (MkB n bg) = MkB (n+1) bg + +spendTopBudget :: Arity -> Budgets -> Budgets +spendTopBudget m (MkB n bg) = MkB (n-m) bg + +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 + + | otherwise -- NB: arity is the threshold_arity, which might be less than + -- manifest arity for join points + = -- pprTrace "finaliseArgBoxities" ( + -- vcat [text "function:" <+> ppr fn + -- , 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 + -- 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 + + 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 + + | is_bot_fn = unboxDeeplyDmd dmd + -- See Note [Boxity for bottoming functions], case (B) + + | is_opaque = trimBoxity dmd + -- See Note [OPAQUE pragma] + -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments] + + | otherwise = dmd + where + dmd = idDemandInfo bndr + is_opaque = isOpaquePragma (idInlinePragma fn) + + -- is_bot_fn: see Note [Boxity for bottoming functions] + is_bot_fn = div == botDiv + + go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand]) + go_args bg triples = mapAccumL go_arg bg triples + + go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand) + go_arg bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _)) + = case wantToUnboxArg env ty str_mark dmd of + DropAbsent -> (bg, dmd) + + DontUnbox | is_bot_fn, isTyVarTy ty -> (retain_budget, dmd) + | otherwise -> (retain_budget, trimBoxity dmd) + -- If bot: Keep deep boxity even though WW won't unbox + -- See Note [Boxity for bottoming functions] case (A) + -- trimBoxity: see Note [No lazy, Unboxed demands in demand signature] + where + retain_budget = spendTopBudget (unariseArity ty) bg + -- spendTopBudget: spend from our budget the cost of the + -- retaining the arg + -- The unboxed case does happen here, for example + -- app g x = g x :: (# Int, Int #) + -- here, `x` is used `L`azy and thus Boxed + + DoUnbox triples + | isUnboxedTupleType ty + , (bg', dmds') <- go_args bg triples + -> (bg', n :* (mkProd Unboxed $! dmds')) + -- See Note [Worker argument budget] + -- unboxed tuples are always unboxed, deeply + -- NB: Recurse with bg, *not* bg_inner! The unboxed fields + -- are at the same budget layer. + + | isUnboxedSumType ty + -> pprPanic "Unboxing through unboxed sum" (ppr fn <+> ppr ty) + -- We currently don't return DoUnbox for unboxed sums. + -- But hopefully we will at some point. When that happens, + -- it would still be impossible to predict the effect + -- of dropping absent fields and unboxing others on the + -- unariseArity of the sum without losing sanity. + -- We could overwrite bg_top with the one from + -- retain_budget while still unboxing inside the alts as in + -- the tuple case for a conservative solution, though. + + | otherwise + -> (spendTopBudget 1 (MkB bg_top final_bg_inner), final_dmd) + where + (bg_inner', dmds') = go_args (earnTopBudget bg_inner) triples + -- earnTopBudget: give back the cost of retaining the + -- arg we are insted unboxing. + dmd' = n :* (mkProd Unboxed $! dmds') + ~(final_bg_inner, final_dmd) -- "~": This match *must* be lazy! + | positiveTopBudget bg_inner' = (bg_inner', dmd') + | otherwise = (bg_inner, trimBoxity dmd) + + add_demands :: [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) + +finaliseLetBoxity + :: AnalEnv + -> Type -- ^ Type of the let-bound Id + -> Demand -- ^ How the Id is used + -> Demand +-- See Note [Finalising boxity for let-bound Ids] +-- This function is like finaliseArgBoxities, but much simpler because +-- it has no "budget". It simply unboxes strict demands, and stops +-- when it reaches a lazy one. +finaliseLetBoxity env ty dmd + = go (ty, NotMarkedStrict, dmd) + where + go :: (Type,StrictnessMark,Demand) -> Demand + go (ty, str, dmd@(n :* _)) = + case wantToUnboxArg env ty str dmd of + DropAbsent -> dmd + DontUnbox -> trimBoxity dmd + DoUnbox triples -> n :* (mkProd Unboxed $! map go triples) + +wantToUnboxArg :: AnalEnv -> Type -> StrictnessMark -> Demand + -> UnboxingDecision [(Type, StrictnessMark, Demand)] +wantToUnboxArg env ty str_mark dmd@(n :* _) + = case canUnboxArg (ae_fam_envs env) ty dmd of + DropAbsent -> DropAbsent + DontUnbox -> DontUnbox + + DoUnbox (DataConPatContext{ dcpc_dc = dc + , dcpc_tc_args = tc_args + , dcpc_args = dmds }) + -- OK, so we /can/ unbox it; but do we /want/ to? + | not (isStrict n || isMarkedStrict str_mark) -- Don't unbox a lazy field + -- isMarkedStrict: see Note [Unboxing evaluated arguments] in DmdAnal + -> DontUnbox + + | DefinitelyRecursive <- ae_rec_dc env dc + -- See Note [Which types are unboxed?] + -- and Note [Demand analysis for recursive data constructors] + -> DontUnbox + + | otherwise -- Bad cases dealt with: we want to unbox! + -> DoUnbox (zip3 (dubiousDataConInstArgTys dc tc_args) + (dataConRepStrictness dc) + dmds) + +{- ********************************************************************* +* * + Fixpoints +* * +********************************************************************* -} + +-- Recursive bindings +dmdFix :: TopLevelFlag + -> AnalEnv -- Does not include bindings for this binding + -> SubDemand + -> [(Id,CoreExpr)] + -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info + +dmdFix top_lvl env let_dmd orig_pairs + = loop 1 initial_pairs + where + opts = ae_opts env + -- See Note [Initialising strictness] + initial_pairs | ae_virgin env = [(setIdDmdAndBoxSig opts id botSig, rhs) | (id, rhs) <- orig_pairs ] + | otherwise = orig_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, DmdEnv, [(Id,CoreExpr)]) + abort = (env, lazy_fv', zapped_pairs) + where (lazy_fv, pairs') = step True (zapIdDmdSig orig_pairs) + -- Note [Lazy and unleashable free variables] + non_lazy_fvs = plusVarEnvList $ map (dmdSigDmdEnv . idDmdSig . fst) pairs' + lazy_fv' = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs + zapped_pairs = zapIdDmdSig pairs' + + -- The fixed-point varies the idDmdSig field of the binders, and terminates if that + -- annotation does not change any more. + loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) + loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id) + -- | (id,_) <- pairs]) $ + loop' n pairs + + loop' n pairs + | found_fixpoint = (final_anal_env, lazy_fv, pairs') + | n == 10 = abort + | otherwise = loop (n+1) pairs' + where + found_fixpoint = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs + first_round = n == 1 + (lazy_fv, pairs') = step first_round pairs + final_anal_env = extendAnalEnvs top_lvl env (map fst pairs') + + step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)]) + step first_round pairs = (lazy_fv, pairs') + where + -- In all but the first iteration, delete the virgin flag + start_env | first_round = env + | otherwise = nonVirgin env + + start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) + + !((_,!lazy_fv), !pairs') = mapAccumL my_downRhs start pairs + -- mapAccumL: Use the new signature to do the next pair + -- The occurrence analyser has arranged them in a good order + -- so this can significantly reduce the number of iterations needed + + my_downRhs (env, lazy_fv) (id,rhs) + = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $ + ((env', lazy_fv'), (id', rhs')) + where + !(!env', !lazy_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs + !lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1 + + zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] + zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ] + +{- Note [Safe abortion in the fixed-point iteration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Fixed-point iteration may fail to terminate. But we cannot simply give up and +return the environment and code unchanged! We still need to do one additional +round, for two reasons: + + * To get information on used free variables (both lazy and strict!) + (see Note [Lazy and unleashable free variables]) + * To ensure that all expressions have been traversed at least once, and any left-over + strictness annotations have been updated. + +This final iteration does not add the variables to the strictness signature +environment, which effectively assigns them 'nopSig' (see "getStrictness") + +Note [Trimming a demand to a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are two reasons we sometimes trim a demand to match a type. + 1. GADTs + 2. Recursive products and widening + +More on both below. But the bottom line is: we really don't want to +have a binder whose demand is more deeply-nested than its type +"allows". So in findBndrDmd we call trimToType and findTypeShape to +trim the demand on the binder to a form that matches the type + +Now to the reasons. For (1) consider + f :: a -> Bool + f x = case ... of + A g1 -> case (x |> g1) of (p,q) -> ... + B -> error "urk" + +where A,B are the constructors of a GADT. We'll get a 1P(L,L) demand +on x from the A branch, but that's a stupid demand for x itself, which +has type 'a'. Indeed we get ASSERTs going off (notably in +splitUseProdDmd, #8569). + +For (2) consider + data T = MkT Int T -- A recursive product + f :: Int -> T -> Int + f 0 _ = 0 + f _ (MkT n t) = f n t + +Here f is lazy in T, but its *usage* is infinite: P(L,P(L,P(L, ...))). +Notice that this happens because T is a product type, and is recursive. +If we are not careful, we'll fail to iterate to a fixpoint in dmdFix, +and bale out entirely, which is inefficient and over-conservative. + +Worse, as we discovered in #18304, the size of the usages we compute +can grow /exponentially/, so even 10 iterations costs far too much. +Especially since we then discard the result. + +To avoid this we use the same findTypeShape function as for (1), but +arrange that it trims the demand if it encounters the same type constructor +twice (or three times, etc). We use our standard RecTcChecker mechanism +for this -- see GHC.Core.Opt.WorkWrap.Utils.findTypeShape. + +This is usually call "widening". We could do it just in dmdFix, but +since are doing this findTypeShape business /anyway/ because of (1), +and it has all the right information to hand, it's extremely +convenient to do it there. + +-} + +{- ********************************************************************* +* * + Strictness signatures and types +* * +********************************************************************* -} + +unitDmdType :: DmdEnv -> DmdType +unitDmdType dmd_env = DmdType dmd_env [] topDiv + +coercionDmdEnv :: Coercion -> DmdEnv +coercionDmdEnv co = coercionsDmdEnv [co] + +coercionsDmdEnv :: [Coercion] -> DmdEnv +coercionsDmdEnv cos = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCos cos) + -- The VarSet from coVarsOfCos is really a VarEnv Var + +addVarDmd :: DmdType -> Var -> Demand -> DmdType +addVarDmd (DmdType fv ds res) var dmd + = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res + +addLazyFVs :: DmdType -> DmdEnv -> DmdType +addLazyFVs dmd_ty lazy_fvs + = dmd_ty `plusDmdType` mkPlusDmdArg lazy_fvs + -- Using plusDmdType (rather than just plus'ing the envs) + -- is vital. Consider + -- let f = \x -> (x,y) + -- in error (f 3) + -- Here, y is treated as a lazy-fv of f, but we must `plusDmd` that L + -- demand with the bottom coming up from 'error' + -- + -- I got a loop in the fixpointer without this, due to an interaction + -- with the lazy_fv filtering in dmdAnalRhsSig. Roughly, it was + -- letrec f n x + -- = letrec g y = x `fatbar` + -- letrec h z = z + ...g... + -- in h (f (n-1) x) + -- in ... + -- In the initial iteration for f, f=Bot + -- Suppose h is found to be strict in z, but the occurrence of g in its RHS + -- is lazy. Now consider the fixpoint iteration for g, esp the demands it + -- places on its free variables. Suppose it places none. Then the + -- x `fatbar` ...call to h... + -- will give a x->V demand for x. That turns into a L demand for x, + -- which floats out of the defn for h. Without the modifyEnv, that + -- 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 (b:bs) ds + | isTyVar b = b : setBndrsDemandInfo bs ds +setBndrsDemandInfo (b:bs) (d:ds) = + let !new_info = setIdDemandInfo b d + !vars = setBndrsDemandInfo bs ds + in new_info : vars +setBndrsDemandInfo [] ds = assert (null ds) [] +setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) + +annotateLamIdBndr :: AnalEnv + -> DmdType -- Demand type of body + -> Id -- Lambda binder + -> WithDmdType Id -- Demand type of lambda + -- and binder annotated with demand + +annotateLamIdBndr env dmd_ty id +-- For lambdas we add the demand to the argument demands +-- Only called for Ids + = assert (isId id) $ + -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ + WithDmdType main_ty new_id + where + new_id = setIdDemandInfo id dmd + main_ty = addDemand dmd dmd_ty' + WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id + +{- Note [NOINLINE and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one point we disabled strictness for NOINLINE functions, on the +grounds that they should be entirely opaque. But that lost lots of +useful semantic strictness information, so now we analyse them like +any other function, and pin strictness information on them. + +That in turn forces us to worker/wrapper them; see +Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. + + +Note [Lazy and unleashable free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We put the strict and once-used FVs in the DmdType of the Id, so +that at its call sites we unleash demands on its strict fvs. +An example is 'roll' in imaginary/wheel-sieve2 +Something like this: + roll x = letrec + go y = if ... then roll (x-1) else x+1 + in + go ms +We want to see that roll is strict in x, which is because +go is called. So we put the DmdEnv for x in go's DmdType. + +Another example: + + f :: Int -> Int -> Int + f x y = let t = x+1 + h z = if z==0 then t else + if z==1 then x+1 else + x + h (z-1) + in h y + +Calling h does indeed evaluate x, but we can only see +that if we unleash a demand on x at the call site for t. + +Incidentally, here's a place where lambda-lifting h would +lose the cigar --- we couldn't see the joint strictness in t/x + + ON THE OTHER HAND + +We don't want to put *all* the fv's from the RHS into the +DmdType. Because + + * it makes the strictness signatures larger, and hence slows down fixpointing + +and + + * it is useless information at the call site anyways: + For lazy, used-many times fv's we will never get any better result than + that, no matter how good the actual demand on the function at the call site + is (unless it is always absent, but then the whole binder is useless). + +Therefore we exclude lazy multiple-used fv's from the environment in the +DmdType. + +But now the signature lies! (Missing variables are assumed to be absent.) To +make up for this, the code that analyses the binding keeps the demand on those +variable separate (usually called "lazy_fv") and adds it to the demand of the +whole binding later. + +What if we decide _not_ to store a strictness signature for a binding at all, as +we do when aborting a fixed-point iteration? The we risk losing the information +that the strict variables are being used. In that case, we take all free variables +mentioned in the (unsound) strictness signature, conservatively approximate the +demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix". + + +************************************************************************ +* * +\subsection{Strictness signatures} +* * +************************************************************************ +-} + + +data AnalEnv = AE + { ae_opts :: !DmdAnalOpts + -- ^ Analysis options + , ae_sigs :: !SigEnv + , ae_virgin :: !Bool + -- ^ True on first iteration only. See Note [Initialising strictness] + , ae_fam_envs :: !FamInstEnvs + , ae_rec_dc :: DataCon -> IsRecDataConResult + -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon' + } + + -- We use the se_env to tell us whether to + -- record info about a variable in the DmdEnv + -- We do so if it's a LocalId, but not top-level + -- + -- The DmdEnv gives the demand on the free vars of the function + -- when it is given enough args to satisfy the strictness signature + +type SigEnv = VarEnv (DmdSig, TopLevelFlag) + +instance Outputable AnalEnv where + ppr env = text "AE" <+> braces (vcat + [ text "ae_virgin =" <+> ppr (ae_virgin env) + , text "ae_sigs =" <+> ppr (ae_sigs env) + ]) + +emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv +emptyAnalEnv opts fam_envs + = AE { ae_opts = opts + , ae_sigs = emptySigEnv + , ae_virgin = True + , ae_fam_envs = fam_envs + , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs 3) + } + +-- | Unset the 'dmd_strict_dicts' flag if any of the given bindings is a DFun +-- binding. Part of the mechanism that detects +-- Note [Do not strictify a DFun's parameter dictionaries]. +enterDFun :: CoreBind -> AnalEnv -> AnalEnv +enterDFun bind env + | any isDFunId (bindersOf bind) + = env { ae_opts = (ae_opts env) { dmd_strict_dicts = False } } + | otherwise + = env + +emptySigEnv :: SigEnv +emptySigEnv = emptyVarEnv + +-- | Extend an environment with the strictness sigs attached to the Ids +extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv +extendAnalEnvs top_lvl env vars + = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars } + +extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv +extendSigEnvs top_lvl sigs vars + = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars] + +extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv +extendAnalEnv top_lvl env var sig + = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig } + +extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> DmdSig -> SigEnv +extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl) + +lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag) +lookupSigEnv env id = lookupVarEnv (ae_sigs env) id + +addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv +addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id } + +addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv +addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids } + +nonVirgin :: AnalEnv -> AnalEnv +nonVirgin env = env { ae_virgin = False } + +findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] +-- Return the demands on the Ids in the [Var] +findBndrsDmds env dmd_ty bndrs + = go dmd_ty bndrs + where + go dmd_ty [] = WithDmdType dmd_ty [] + go dmd_ty (b:bs) + | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs + WithDmdType dmd_ty2 dmd = findBndrDmd env dmd_ty1 b + in WithDmdType dmd_ty2 (dmd : dmds) + | otherwise = go dmd_ty bs + +findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand +-- See Note [Trimming a demand to a type] +findBndrDmd env dmd_ty id + = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $ + WithDmdType dmd_ty' dmd' + where + dmd' = strictify $ + trimToType starting_dmd (findTypeShape fam_envs id_ty) + + (dmd_ty', starting_dmd) = peelFV dmd_ty id + + id_ty = idType id + + strictify dmd + -- See Note [Making dictionary parameters strict] + -- and Note [Do not strictify a DFun's parameter dictionaries] + | dmd_strict_dicts (ae_opts env) + = strictifyDictDmd id_ty dmd + | otherwise + = dmd + + fam_envs = ae_fam_envs env + +{- Note [Bringing a new variable into scope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = blah + g = ...(\f. ...f...)... + +In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`, +not the top-level `f` (which will be in `ae_sigs`). So it's very important +to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`. +Otherwise chaos results (#22718). + +Note [Making dictionary parameters strict] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries. Why? + +* Generally CBV is more efficient. + +* A datatype dictionary is always non-bottom and never takes much work to + compute. E.g. a DFun from an instance decl always returns a dictionary + record immediately. See DFunUnfolding in CoreSyn. + See also Note [Recursive superclasses] in TcInstDcls. + +See #17758 for more background and perf numbers. + +Wrinkles: + +* A newtype dictionary is *not* always non-bottom. E.g. + class C a where op :: a -> a + instance C Int where op = error "urk" + Now a value of type (C Int) is just a newtype wrapper (a cast) around + the error thunk. Don't strictify these! + +* Strictifying DFuns risks destroying the invariant that DFuns never take much + work to compute, so we don't do it. + See Note [Do not strictify a DFun's parameter dictionaries] for details. + +* Although worker/wrapper *could* unbox strictly used dictionaries, we do not do + so; see Note [Do not unbox class dictionaries]. + +The implementation is extremely simple: just make the strictness +analyser strictify the demand on a dictionary binder in +'findBndrDmd' if the binder does not belong to a DFun. + +Note [Do not strictify a DFun's parameter dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The typechecker can tie recursive knots involving (non-recursive) DFuns, so +we must not strictify a DFun's parameter dictionaries (#22549). +T22549 has an example involving undecidable instances that <>s when we +strictify the DFun of, e.g., `$fEqSeqT`: + + Main.$fEqSeqT + = \@m @a ($dEq :: Eq (m (ViewT m a))) ($dMonad :: Monad m) -> + GHC.Classes.C:Eq @(SeqT m a) ($c== @m @a $dEq $dMonad) + ($c/= @m @a $dEq $dMonad) + + Rec { + $dEq_a = Main.$fEqSeqT @Identity @Int $dEq_b Main.$fMonadIdentity + $dEq_b = ... $dEq_a ... + } + +If we make `$fEqSeqT` strict in `$dEq`, we'll collapse the Rec group into a +giant, <>ing thunk. + +To prevent that, we never strictify dictionary params when inside a DFun. +That is implemented by unsetting 'dmd_strict_dicts' when entering a DFun. + +See also Note [Speculative evaluation] in GHC.CoreToStg.Prep which has a rather +similar example in #20836. We may never speculate *arguments* of (recursive) +DFun calls, likewise we should not mark *formal parameters* of recursive DFuns +as strict. + +Note [Initialising strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See section 9.2 (Finding fixpoints) of the paper. + +Our basic plan is to initialise the strictness of each Id in a +recursive group to "bottom", and find a fixpoint from there. However, +this group B might be inside an *enclosing* recursive group A, in +which case we'll do the entire fixpoint shebang on for each iteration +of A. This can be illustrated by the following example: + +Example: + + f [] = [] + f (x:xs) = let g [] = f xs + g (y:ys) = y+1 : g ys + in g (h x) + +At each iteration of the fixpoint for f, the analyser has to find a +fixpoint for the enclosed function g. In the meantime, the demand +values for g at each iteration for f are *greater* than those we +encountered in the previous iteration for f. Therefore, we can begin +the fixpoint for g not with the bottom value but rather with the +result of the previous analysis. I.e., when beginning the fixpoint +process for g, we can start from the demand signature computed for g +previously and attached to the binding occurrence of g. + +To speed things up, we initialise each iteration of A (the enclosing +one) from the result of the last one, which is neatly recorded in each +binder. That way we make use of earlier iterations of the fixpoint +algorithm. (Cunning plan.) + +But on the *first* iteration we want to *ignore* the current strictness +of the Id, and start from "bottom". Nowadays the Id can have a current +strictness, because interface files record strictness for nested bindings. +To know when we are in the first iteration, we look at the ae_virgin +field of the AnalEnv. + + +Note [Final Demand Analyser run] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some of the information that the demand analyser determines is not always +preserved by the simplifier. For example, the simplifier will happily rewrite + \y [Demand=MU] let x = y in x + x +to + \y [Demand=MU] y + y +which is quite a lie: Now y occurs more than just once. + +The once-used information is (currently) only used by the code +generator, though. So: + + * We zap the used-once info in the worker-wrapper; + see Note [Zapping Used Once info in WorkWrap] in + GHC.Core.Opt.WorkWrap. + If it's not reliable, it's better not to have it at all. + + * Just before TidyCore, we add a pass of the demand analyser, + but WITHOUT subsequent worker/wrapper and simplifier, + right before TidyCore. See SimplCore.getCoreToDo. + + This way, correct information finds its way into the module interface + (strictness signatures!) and the code generator (single-entry thunks!) + +Note that, in contrast, the single-call information (C(M,..)) /can/ be relied upon, as the simplifier tends to be very careful about not duplicating actual function calls. 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 @@ -62,7 +62,7 @@ goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs) -- Top-level bindings are never join points - in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds + in_scope_toplvl = emptyInScopeSet `extendInScopeSetBndrs` binds go :: InScopeSet -> CoreExpr -> CoreExpr go _ e@(Var{}) = e @@ -94,7 +94,7 @@ | otherwise = Let (Rec pairs') body' where is_join_rec = any (isJoinId . fst) pairs - in_scope' = in_scope `extendInScopeSetList` bindersOf (Rec pairs) + in_scope' = in_scope `extendInScopeSetBind` (Rec pairs) pairs' = mapSnd (go in_scope') pairs body' = go in_scope' body @@ -265,7 +265,7 @@ `extendInScopeSet` exit_id_tmpl -- just cosmetics return (uniqAway avoid exit_id_tmpl) where - exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique Many ty + exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty `asJoinId` join_arity addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId @@ -306,7 +306,7 @@ in … where the floated expression `x+x` is a bit more complicated, but still not -intersting. +interesting. Expressions are interesting when they move an occurrence of a variable outside the recursive `go` that can benefit from being obviously called once, for example: @@ -315,7 +315,7 @@ see that it is called at most once, and hence improve the function’s strictness signature -So we only hoist an exit expression out if it mentiones at least one free, +So we only hoist an exit expression out if it mentions at least one free, non-imported variable. Note [Jumps can be interesting] @@ -430,7 +430,7 @@ To prevent this, we need to recognize exit join points, and then disable inlining. -Exit join points, recognizeable using `isExitJoinId` are join points with an +Exit join points, recognizable using `isExitJoinId` are join points with an occurrence in a recursive group, and can be recognized (after the occurrence analyzer ran!) using `isExitJoinId`. This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`, 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 @@ -22,13 +22,14 @@ import GHC.Platform import GHC.Core +import GHC.Core.Opt.Arity( isOneShotBndr ) import GHC.Core.Make hiding ( wrapFloats ) import GHC.Core.Utils import GHC.Core.FVs import GHC.Core.Type import GHC.Types.Basic ( RecFlag(..), isRec, Levity(Unlifted) ) -import GHC.Types.Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) +import GHC.Types.Id ( idType, isJoinId, isJoinId_maybe ) import GHC.Types.Tickish import GHC.Types.Var import GHC.Types.Var.Set @@ -198,13 +199,10 @@ -- useless since the simplifier will immediately float it back out.) add_arg :: FreeVarSet -> CoreExprWithFVs -> (FreeVarSet,FreeVarSet) - add_arg here_fvs (arg_fvs, AnnType _) - = (here_fvs, arg_fvs) + -- We can't float into some arguments, so put them into the here_fvs add_arg here_fvs (arg_fvs, arg) - | noFloatIntoArg arg arg_ty = (here_fvs `unionDVarSet` arg_fvs, emptyDVarSet) + | noFloatIntoArg arg = (here_fvs `unionDVarSet` arg_fvs, emptyDVarSet) | otherwise = (here_fvs, arg_fvs) - where - arg_ty = exprType $ deAnnotate' arg {- Note [Dead bindings] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -215,15 +213,6 @@ But, while this may be unusual it is not actually wrong, and it did once happen (#15696). -Note [Do not destroy the let/app invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Watch out for - f (x +# y) -We don't want to float bindings into here - f (case ... of { x -> x +# y }) -because that might destroy the let/app invariant, which requires -unlifted function arguments to be ok-for-speculation. - Note [Join points] ~~~~~~~~~~~~~~~~~~ Generally, we don't need to worry about join points - there are places we're @@ -629,14 +618,14 @@ | isJoinId bndr = isRec is_rec -- Joins are one-shot iff non-recursive - | otherwise - = noFloatIntoArg rhs (idType bndr) + | Just Unlifted <- typeLevity_maybe (idType bndr) + = True -- Preserve let-can-float invariant, see Note [noFloatInto considerations] -noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool -noFloatIntoArg expr expr_ty - | Just Unlifted <- typeLevity_maybe expr_ty - = True -- See Note [Do not destroy the let/app invariant] + | otherwise + = noFloatIntoArg rhs +noFloatIntoArg :: CoreExprWithFVs' -> Bool +noFloatIntoArg expr | AnnLam bndr e <- expr , (bndrs, _) <- collectAnnBndrs e = noFloatIntoLam (bndr:bndrs) -- Wrinkle 1 (a) @@ -651,11 +640,11 @@ {- Note [noFloatInto considerations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When do we want to float bindings into - - noFloatIntoRHs: the RHS of a let-binding + - noFloatIntoRhs: the RHS of a let-binding - noFloatIntoArg: the argument of a function application -Definitely don't float in if it has unlifted type; that -would destroy the let/app invariant. +Definitely don't float into RHS if it has unlifted type; +that would destroy the let-can-float invariant. * Wrinkle 1: do not float in if (a) any non-one-shot value lambdas 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 @@ -15,12 +15,13 @@ import GHC.Core import GHC.Core.Utils import GHC.Core.Make -import GHC.Core.Opt.Arity ( exprArity, etaExpand ) +-- import GHC.Core.Opt.Arity ( exprArity, etaExpand ) import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) -import GHC.Driver.Session +import GHC.Driver.Flags ( DumpFlag (..) ) import GHC.Utils.Logger -import GHC.Types.Id ( Id, idArity, idType, isDeadEndId, +import GHC.Types.Id ( Id, idType, +-- idArity, isDeadEndId, isJoinId, isJoinId_maybe ) import GHC.Types.Tickish import GHC.Core.Opt.SetLevels @@ -218,14 +219,7 @@ -- See Note [Floating out of Rec rhss] for why things get arranged this way. floatBind (NonRec (TB var _) rhs) = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') -> - - -- A tiresome hack: - -- see Note [Bottoming floats: eta expansion] in GHC.Core.Opt.SetLevels - let rhs'' | isDeadEndId var - , exprArity rhs' < idArity var = etaExpand (idArity var) rhs' - | otherwise = rhs' - - in (fs, rhs_floats, [NonRec var rhs'']) } + (fs, rhs_floats, [NonRec var rhs']) } floatBind (Rec pairs) = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) -> @@ -349,7 +343,7 @@ We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... } The binding for bar will be in the "tops" part of the floating binds, -and thus not partioned by floatBody. +and thus not partitioned by floatBody. We could perhaps get rid of the 'tops' component of the floating binds, but this case works just as well. 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 @@ -5,11 +5,13 @@ -} -module GHC.Core.Opt.LiberateCase ( liberateCase ) where +module GHC.Core.Opt.LiberateCase + ( LibCaseOpts(..) + , liberateCase + ) where import GHC.Prelude -import GHC.Driver.Session import GHC.Core import GHC.Core.Unfold import GHC.Builtin.Types ( unitDataConId ) @@ -101,19 +103,17 @@ ************************************************************************ -} -liberateCase :: DynFlags -> CoreProgram -> CoreProgram -liberateCase dflags binds = do_prog (initLiberateCaseEnv dflags) binds +liberateCase :: LibCaseOpts -> CoreProgram -> CoreProgram +liberateCase opts binds = do_prog (initLiberateCaseEnv opts) binds where do_prog _ [] = [] do_prog env (bind:binds) = bind' : do_prog env' binds where (env', bind') = libCaseBind env bind - -initLiberateCaseEnv :: DynFlags -> LibCaseEnv -initLiberateCaseEnv dflags = LibCaseEnv - { lc_threshold = liberateCaseThreshold dflags - , lc_uf_opts = unfoldingOpts dflags +initLiberateCaseEnv :: LibCaseOpts -> LibCaseEnv +initLiberateCaseEnv opts = LibCaseEnv + { lc_opts = opts , lc_lvl = 0 , lc_lvl_env = emptyVarEnv , lc_rec_env = emptyVarEnv @@ -173,7 +173,7 @@ {- Note [Not bottoming Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do not specialise error-functions (this is unusual, but I once saw it, -(actually in Data.Typable.Internal) +(actually in Data.Typeable.Internal) Note [Only functions!] ~~~~~~~~~~~~~~~~~~~~~~ @@ -388,6 +388,22 @@ {- ************************************************************************ * * + Options +* * +************************************************************************ +-} + +-- | Options for the liberate case pass. +data LibCaseOpts = LibCaseOpts + { -- | Bomb-out size for deciding if potential liberatees are too big. + lco_threshold :: !(Maybe Int) + -- | Unfolding options + , lco_unfolding_opts :: !UnfoldingOpts + } + +{- +************************************************************************ +* * The environment * * ************************************************************************ @@ -398,14 +414,16 @@ topLevel :: LibCaseLevel topLevel = 0 +lc_threshold :: LibCaseEnv -> Maybe Int +lc_threshold = lco_threshold . lc_opts + +lc_uf_opts :: LibCaseEnv -> UnfoldingOpts +lc_uf_opts = lco_unfolding_opts . lc_opts + data LibCaseEnv = LibCaseEnv { - lc_threshold :: Maybe Int, - -- ^ Bomb-out size for deciding if potential liberatees are too - -- big. - - lc_uf_opts :: UnfoldingOpts, - -- ^ Unfolding options + lc_opts :: !LibCaseOpts, + -- ^ liberate case options lc_lvl :: LibCaseLevel, -- ^ Current level -- The level is incremented when (and only when) going 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 @@ -6,31 +6,22 @@ {-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Core.Opt.Monad ( - -- * Configuration of the core-to-core passes - CoreToDo(..), runWhen, runMaybe, - SimplMode(..), + -- * Types used in core-to-core passes FloatOutSwitches(..), - pprPassDetails, - -- * Plugins - CorePluginPass, bindsOnlyPass, - - -- * Counting - SimplCount, doSimplTick, doFreeSimplTick, simplCountN, - pprSimplCount, plusSimplCount, zeroSimplCount, - isZeroSimplCount, hasDetailedCounts, Tick(..), - -- * The monad CoreM, runCoreM, + mapDynFlagsCoreM, dropSimplCount, + -- ** Reading from the monad - getHscEnv, getRuleBase, getModule, + getHscEnv, getModule, + initRuleEnv, getExternalRuleBase, getDynFlags, getPackageFamInstEnv, - getVisibleOrphanMods, getUniqMask, - getPrintUnqualified, getSrcSpanM, + getInteractiveContext, + getUniqMask, + getNamePprCtx, getSrcSpanM, -- ** Writing to the monad addSimplCount, @@ -42,7 +33,7 @@ getAnnotations, getFirstAnnotations, -- ** Screen output - putMsg, putMsgS, errorMsg, errorMsgS, msg, + putMsg, putMsgS, errorMsg, msg, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, ) where @@ -52,12 +43,10 @@ import GHC.Driver.Session import GHC.Driver.Env -import GHC.Core -import GHC.Core.Unfold +import GHC.Core.Rules ( RuleBase, RuleEnv, mkRuleEnv ) +import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount ) -import GHC.Types.Basic ( CompilerPhase(..) ) import GHC.Types.Annotations -import GHC.Types.Var import GHC.Types.Unique.Supply import GHC.Types.Name.Env import GHC.Types.SrcLoc @@ -68,141 +57,22 @@ import GHC.Utils.Logger import GHC.Utils.Monad -import GHC.Data.FastString import GHC.Data.IOEnv hiding ( liftIO, failM, failWithM ) import qualified GHC.Data.IOEnv as IOEnv +import GHC.Runtime.Context ( InteractiveContext ) + import GHC.Unit.Module import GHC.Unit.Module.ModGuts import GHC.Unit.External import Data.Bifunctor ( bimap ) -import Data.List (intersperse, groupBy, sortBy) -import Data.Ord import Data.Dynamic -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.Map.Strict as MapStrict +import Data.Maybe (listToMaybe) import Data.Word import Control.Monad import Control.Applicative ( Alternative(..) ) -import GHC.Utils.Panic (throwGhcException, GhcException(..), panic) -{- -************************************************************************ -* * - The CoreToDo type and related types - Abstraction of core-to-core passes to run. -* * -************************************************************************ --} - -data CoreToDo -- These are diff core-to-core passes, - -- which may be invoked in any order, - -- as many times as you like. - - = CoreDoSimplify -- The core-to-core simplifier. - Int -- Max iterations - SimplMode - | CoreDoPluginPass String CorePluginPass - | CoreDoFloatInwards - | CoreDoFloatOutwards FloatOutSwitches - | CoreLiberateCase - | CoreDoPrintCore - | CoreDoStaticArgs - | CoreDoCallArity - | CoreDoExitify - | CoreDoDemand - | CoreDoCpr - | CoreDoWorkerWrapper - | CoreDoSpecialising - | CoreDoSpecConstr - | CoreCSE - | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules - -- matching this string - | CoreDoNothing -- Useful when building up - | CoreDoPasses [CoreToDo] -- lists of these things - - | CoreDesugar -- Right after desugaring, no simple optimisation yet! - | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces - -- Core output, and hence useful to pass to endPass - - | CoreTidy - | CorePrep - | CoreAddCallerCcs - | CoreAddLateCcs - | CoreOccurAnal - -instance Outputable CoreToDo where - ppr (CoreDoSimplify _ _) = text "Simplifier" - ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s - ppr CoreDoFloatInwards = text "Float inwards" - ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) - ppr CoreLiberateCase = text "Liberate case" - ppr CoreDoStaticArgs = text "Static argument" - ppr CoreDoCallArity = text "Called arity analysis" - ppr CoreDoExitify = text "Exitification transformation" - ppr CoreDoDemand = text "Demand analysis" - ppr CoreDoCpr = text "Constructed Product Result analysis" - ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" - ppr CoreDoSpecialising = text "Specialise" - ppr CoreDoSpecConstr = text "SpecConstr" - ppr CoreCSE = text "Common sub-expression" - ppr CoreDesugar = text "Desugar (before optimization)" - ppr CoreDesugarOpt = text "Desugar (after optimization)" - ppr CoreTidy = text "Tidy Core" - ppr CoreAddCallerCcs = text "Add caller cost-centres" - ppr CoreAddLateCcs = text "Add late core cost-centres" - ppr CorePrep = text "CorePrep" - ppr CoreOccurAnal = text "Occurrence analysis" - ppr CoreDoPrintCore = text "Print core" - ppr (CoreDoRuleCheck {}) = text "Rule check" - ppr CoreDoNothing = text "CoreDoNothing" - ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes - -pprPassDetails :: CoreToDo -> SDoc -pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n - , ppr md ] -pprPassDetails _ = Outputable.empty - -data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad - = SimplMode - { sm_names :: [String] -- ^ Name(s) of the phase - , sm_phase :: CompilerPhase - , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options - , sm_rules :: !Bool -- ^ Whether RULES are enabled - , sm_inline :: !Bool -- ^ Whether inlining is enabled - , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled - , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled - , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas? - , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled - , sm_logger :: !Logger - , sm_dflags :: DynFlags - -- Just for convenient non-monadic access; we don't override these. - -- - -- Used for: - -- - target platform (for `exprIsDupable` and `mkDupableAlt`) - -- - Opt_DictsCheap and Opt_PedanticBottoms general flags - -- - rules options (initRuleOpts) - -- - inlineCheck - } - -instance Outputable SimplMode where - ppr (SimplMode { sm_phase = p, sm_names = ss - , sm_rules = r, sm_inline = i - , sm_cast_swizzle = cs - , sm_eta_expand = eta, sm_case_case = cc }) - = text "SimplMode" <+> braces ( - sep [ text "Phase =" <+> ppr p <+> - brackets (text (concat $ intersperse "," ss)) <> comma - , pp_flag i (text "inline") <> comma - , pp_flag r (text "rules") <> comma - , pp_flag eta (text "eta-expand") <> comma - , pp_flag cs (text "cast-swizzle") <> comma - , pp_flag cc (text "case-of-case") ]) - where - pp_flag f s = ppUnless f (text "no") <+> s - data FloatOutSwitches = FloatOutSwitches { floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if -- doing so will abstract over n or fewer @@ -232,341 +102,9 @@ , text "Consts =" <+> ppr (floatOutConstants sw) , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) --- The core-to-core pass ordering is derived from the DynFlags: -runWhen :: Bool -> CoreToDo -> CoreToDo -runWhen True do_this = do_this -runWhen False _ = CoreDoNothing - -runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo -runMaybe (Just x) f = f x -runMaybe Nothing _ = CoreDoNothing - {- - ************************************************************************ * * - Types for Plugins -* * -************************************************************************ --} - --- | A description of the plugin pass itself -type CorePluginPass = ModGuts -> CoreM ModGuts - -bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts -bindsOnlyPass pass guts - = do { binds' <- pass (mg_binds guts) - ; return (guts { mg_binds = binds' }) } - -{- -************************************************************************ -* * - Counting and logging -* * -************************************************************************ --} - -getVerboseSimplStats :: (Bool -> SDoc) -> SDoc -getVerboseSimplStats = getPprDebug -- For now, anyway - -zeroSimplCount :: DynFlags -> SimplCount -isZeroSimplCount :: SimplCount -> Bool -hasDetailedCounts :: SimplCount -> Bool -pprSimplCount :: SimplCount -> SDoc -doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount -doFreeSimplTick :: Tick -> SimplCount -> SimplCount -plusSimplCount :: SimplCount -> SimplCount -> SimplCount - -data SimplCount - = VerySimplCount !Int -- Used when don't want detailed stats - - | SimplCount { - ticks :: !Int, -- Total ticks - details :: !TickCounts, -- How many of each type - - n_log :: !Int, -- N - log1 :: [Tick], -- Last N events; <= opt_HistorySize, - -- most recent first - log2 :: [Tick] -- Last opt_HistorySize events before that - -- Having log1, log2 lets us accumulate the - -- recent history reasonably efficiently - } - -type TickCounts = Map Tick Int - -simplCountN :: SimplCount -> Int -simplCountN (VerySimplCount n) = n -simplCountN (SimplCount { ticks = n }) = n - -zeroSimplCount dflags - -- This is where we decide whether to do - -- the VerySimpl version or the full-stats version - | dopt Opt_D_dump_simpl_stats dflags - = SimplCount {ticks = 0, details = Map.empty, - n_log = 0, log1 = [], log2 = []} - | otherwise - = VerySimplCount 0 - -isZeroSimplCount (VerySimplCount n) = n==0 -isZeroSimplCount (SimplCount { ticks = n }) = n==0 - -hasDetailedCounts (VerySimplCount {}) = False -hasDetailedCounts (SimplCount {}) = True - -doFreeSimplTick tick sc@SimplCount { details = dts } - = sc { details = dts `addTick` tick } -doFreeSimplTick _ sc = sc - -doSimplTick dflags tick - sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) - | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 } - | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } - where - sc1 = sc { ticks = tks+1, details = dts `addTick` tick } - -doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) - - -addTick :: TickCounts -> Tick -> TickCounts -addTick fm tick = MapStrict.insertWith (+) tick 1 fm - -plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) - sc2@(SimplCount { ticks = tks2, details = dts2 }) - = log_base { ticks = tks1 + tks2 - , details = MapStrict.unionWith (+) dts1 dts2 } - where - -- A hackish way of getting recent log info - log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 - | null (log2 sc2) = sc2 { log2 = log1 sc1 } - | otherwise = sc2 - -plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) -plusSimplCount lhs rhs = - throwGhcException . PprProgramError "plusSimplCount" $ vcat - [ text "lhs" - , pprSimplCount lhs - , text "rhs" - , pprSimplCount rhs - ] - -- We use one or the other consistently - -pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n -pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) - = vcat [text "Total ticks: " <+> int tks, - blankLine, - pprTickCounts dts, - getVerboseSimplStats $ \dbg -> if dbg - then - vcat [blankLine, - text "Log (most recent first)", - nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] - else Outputable.empty - ] - -{- Note [Which transformations are innocuous] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At one point (Jun 18) I wondered if some transformations (ticks) -might be "innocuous", in the sense that they do not unlock a later -transformation that does not occur in the same pass. If so, we could -refrain from bumping the overall tick-count for such innocuous -transformations, and perhaps terminate the simplifier one pass -earlier. - -But alas I found that virtually nothing was innocuous! This Note -just records what I learned, in case anyone wants to try again. - -These transformations are not innocuous: - -*** NB: I think these ones could be made innocuous - EtaExpansion - LetFloatFromLet - -LetFloatFromLet - x = K (let z = e2 in Just z) - prepareRhs transforms to - x2 = let z=e2 in Just z - x = K xs - And now more let-floating can happen in the - next pass, on x2 - -PreInlineUnconditionally - Example in spectral/cichelli/Auxil - hinsert = ...let lo = e in - let j = ...lo... in - case x of - False -> () - True -> case lo of I# lo' -> - ...j... - When we PreInlineUnconditionally j, lo's occ-info changes to once, - so it can be PreInlineUnconditionally in the next pass, and a - cascade of further things can happen. - -PostInlineUnconditionally - let x = e in - let y = ...x.. in - case .. of { A -> ...x...y... - B -> ...x...y... } - Current postinlineUnconditinaly will inline y, and then x; sigh. - - But PostInlineUnconditionally might also unlock subsequent - transformations for the same reason as PreInlineUnconditionally, - so it's probably not innocuous anyway. - -KnownBranch, BetaReduction: - May drop chunks of code, and thereby enable PreInlineUnconditionally - for some let-binding which now occurs once - -EtaExpansion: - Example in imaginary/digits-of-e1 - fail = \void. e where e :: IO () - --> etaExpandRhs - fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) - --> Next iteration of simplify - fail1 = \void. \s. (e |> g) s - fail = fail1 |> Void# -> sym g - And now inline 'fail' - -CaseMerge: - case x of y { - DEFAULT -> case y of z { pi -> ei } - alts2 } - ---> CaseMerge - case x of { pi -> let z = y in ei - ; alts2 } - The "let z=y" case-binder-swap gets dealt with in the next pass --} - -pprTickCounts :: Map Tick Int -> SDoc -pprTickCounts counts - = vcat (map pprTickGroup groups) - where - groups :: [[(Tick,Int)]] -- Each group shares a common tag - -- toList returns common tags adjacent - groups = groupBy same_tag (Map.toList counts) - same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2 - -pprTickGroup :: [(Tick, Int)] -> SDoc -pprTickGroup group@((tick1,_):_) - = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) - 2 (vcat [ int n <+> pprTickCts tick - -- flip as we want largest first - | (tick,n) <- sortBy (flip (comparing snd)) group]) -pprTickGroup [] = panic "pprTickGroup" - -data Tick -- See Note [Which transformations are innocuous] - = PreInlineUnconditionally Id - | PostInlineUnconditionally Id - - | UnfoldingDone Id - | RuleFired FastString -- Rule name - - | LetFloatFromLet - | EtaExpansion Id -- LHS binder - | EtaReduction Id -- Binder on outer lambda - | BetaReduction Id -- Lambda binder - - - | CaseOfCase Id -- Bndr on *inner* case - | KnownBranch Id -- Case binder - | CaseMerge Id -- Binder on outer case - | AltMerge Id -- Case binder - | CaseElim Id -- Case binder - | CaseIdentity Id -- Case binder - | FillInCaseDefault Id -- Case binder - - | SimplifierDone -- Ticked at each iteration of the simplifier - -instance Outputable Tick where - ppr tick = text (tickString tick) <+> pprTickCts tick - -instance Eq Tick where - a == b = case a `cmpTick` b of - EQ -> True - _ -> False - -instance Ord Tick where - compare = cmpTick - -tickToTag :: Tick -> Int -tickToTag (PreInlineUnconditionally _) = 0 -tickToTag (PostInlineUnconditionally _) = 1 -tickToTag (UnfoldingDone _) = 2 -tickToTag (RuleFired _) = 3 -tickToTag LetFloatFromLet = 4 -tickToTag (EtaExpansion _) = 5 -tickToTag (EtaReduction _) = 6 -tickToTag (BetaReduction _) = 7 -tickToTag (CaseOfCase _) = 8 -tickToTag (KnownBranch _) = 9 -tickToTag (CaseMerge _) = 10 -tickToTag (CaseElim _) = 11 -tickToTag (CaseIdentity _) = 12 -tickToTag (FillInCaseDefault _) = 13 -tickToTag SimplifierDone = 16 -tickToTag (AltMerge _) = 17 - -tickString :: Tick -> String -tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" -tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" -tickString (UnfoldingDone _) = "UnfoldingDone" -tickString (RuleFired _) = "RuleFired" -tickString LetFloatFromLet = "LetFloatFromLet" -tickString (EtaExpansion _) = "EtaExpansion" -tickString (EtaReduction _) = "EtaReduction" -tickString (BetaReduction _) = "BetaReduction" -tickString (CaseOfCase _) = "CaseOfCase" -tickString (KnownBranch _) = "KnownBranch" -tickString (CaseMerge _) = "CaseMerge" -tickString (AltMerge _) = "AltMerge" -tickString (CaseElim _) = "CaseElim" -tickString (CaseIdentity _) = "CaseIdentity" -tickString (FillInCaseDefault _) = "FillInCaseDefault" -tickString SimplifierDone = "SimplifierDone" - -pprTickCts :: Tick -> SDoc -pprTickCts (PreInlineUnconditionally v) = ppr v -pprTickCts (PostInlineUnconditionally v)= ppr v -pprTickCts (UnfoldingDone v) = ppr v -pprTickCts (RuleFired v) = ppr v -pprTickCts LetFloatFromLet = Outputable.empty -pprTickCts (EtaExpansion v) = ppr v -pprTickCts (EtaReduction v) = ppr v -pprTickCts (BetaReduction v) = ppr v -pprTickCts (CaseOfCase v) = ppr v -pprTickCts (KnownBranch v) = ppr v -pprTickCts (CaseMerge v) = ppr v -pprTickCts (AltMerge v) = ppr v -pprTickCts (CaseElim v) = ppr v -pprTickCts (CaseIdentity v) = ppr v -pprTickCts (FillInCaseDefault v) = ppr v -pprTickCts _ = Outputable.empty - -cmpTick :: Tick -> Tick -> Ordering -cmpTick a b = case (tickToTag a `compare` tickToTag b) of - GT -> GT - EQ -> cmpEqTick a b - LT -> LT - -cmpEqTick :: Tick -> Tick -> Ordering -cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b -cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b -cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b -cmpEqTick (RuleFired a) (RuleFired b) = a `uniqCompareFS` b -cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b -cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b -cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b -cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b -cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b -cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b -cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b -cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b -cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b -cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b -cmpEqTick _ _ = EQ - -{- -************************************************************************ -* * Monad and carried data structure definitions * * ************************************************************************ @@ -574,12 +112,11 @@ data CoreReader = CoreReader { cr_hsc_env :: HscEnv, - cr_rule_base :: RuleBase, + cr_rule_base :: RuleBase, -- Home package table rules cr_module :: Module, - cr_print_unqual :: PrintUnqualified, + cr_name_ppr_ctx :: NamePprCtx, cr_loc :: SrcSpan, -- Use this for log/error messages so they -- are at least tagged with the right source file - cr_visible_orphan_mods :: !ModuleSet, cr_uniq_mask :: !Char -- Mask for creating unique values } @@ -590,9 +127,10 @@ cw_simpl_count :: SimplCount } -emptyWriter :: DynFlags -> CoreWriter -emptyWriter dflags = CoreWriter { - cw_simpl_count = zeroSimplCount dflags +emptyWriter :: Bool -- ^ -ddump-simpl-stats + -> CoreWriter +emptyWriter dump_simpl_stats = CoreWriter { + cw_simpl_count = zeroSimplCount dump_simpl_stats } plusWriter :: CoreWriter -> CoreWriter -> CoreWriter @@ -640,20 +178,18 @@ -> RuleBase -> Char -- ^ Mask -> Module - -> ModuleSet - -> PrintUnqualified + -> NamePprCtx -> SrcSpan -> CoreM a -> IO (a, SimplCount) -runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m +runCoreM hsc_env rule_base mask mod name_ppr_ctx loc m = liftM extract $ runIOEnv reader $ unCoreM m where reader = CoreReader { cr_hsc_env = hsc_env, cr_rule_base = rule_base, cr_module = mod, - cr_visible_orphan_mods = orph_imps, - cr_print_unqual = print_unqual, + cr_name_ppr_ctx = name_ppr_ctx, cr_loc = loc, cr_uniq_mask = mask } @@ -671,8 +207,8 @@ nop :: a -> CoreIOEnv (a, CoreWriter) nop x = do - r <- getEnv - return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r) + logger <- hsc_logger . cr_hsc_env <$> getEnv + return (x, emptyWriter $ logHasDumpFlag logger Opt_D_dump_simpl_stats) read :: (CoreReader -> a) -> CoreM a read f = CoreM $ getEnv >>= (\r -> nop (f r)) @@ -704,15 +240,21 @@ getHscEnv :: CoreM HscEnv getHscEnv = read cr_hsc_env -getRuleBase :: CoreM RuleBase -getRuleBase = read cr_rule_base +getHomeRuleBase :: CoreM RuleBase +getHomeRuleBase = read cr_rule_base -getVisibleOrphanMods :: CoreM ModuleSet -getVisibleOrphanMods = read cr_visible_orphan_mods +initRuleEnv :: ModGuts -> CoreM RuleEnv +initRuleEnv guts + = do { hpt_rules <- getHomeRuleBase + ; eps_rules <- getExternalRuleBase + ; return (mkRuleEnv guts eps_rules hpt_rules) } -getPrintUnqualified :: CoreM PrintUnqualified -getPrintUnqualified = read cr_print_unqual +getExternalRuleBase :: CoreM RuleBase +getExternalRuleBase = eps_rule_base <$> get_eps +getNamePprCtx :: CoreM NamePprCtx +getNamePprCtx = read cr_name_ppr_ctx + getSrcSpanM :: CoreM SrcSpan getSrcSpanM = read cr_loc @@ -724,6 +266,20 @@ -- Convenience accessors for useful fields of HscEnv +-- | Adjust the dyn flags passed to the argument action +mapDynFlagsCoreM :: (DynFlags -> DynFlags) -> CoreM a -> CoreM a +mapDynFlagsCoreM f m = CoreM $ do + !e <- getEnv + let !e' = e { cr_hsc_env = hscUpdateFlags f $ cr_hsc_env e } + liftIO $ runIOEnv e' $! unCoreM m + +-- | Drop the single count of the argument action so it doesn't effect +-- the total. +dropSimplCount :: CoreM a -> CoreM a +dropSimplCount m = CoreM $ do + (a, _) <- unCoreM m + unCoreM $ pure a + instance HasDynFlags CoreM where getDynFlags = fmap hsc_dflags getHscEnv @@ -733,11 +289,16 @@ instance HasModule CoreM where getModule = read cr_module +getInteractiveContext :: CoreM InteractiveContext +getInteractiveContext = hsc_IC <$> getHscEnv + getPackageFamInstEnv :: CoreM PackageFamInstEnv -getPackageFamInstEnv = do +getPackageFamInstEnv = eps_fam_inst_env <$> get_eps + +get_eps :: CoreM ExternalPackageState +get_eps = do hsc_env <- getHscEnv - eps <- liftIO $ hscEPS hsc_env - return $ eps_fam_inst_env eps + liftIO $ hscEPS hsc_env {- ************************************************************************ @@ -766,8 +327,8 @@ getFirstAnnotations deserialize guts = bimap mod name <$> getAnnotations deserialize guts where - mod = mapModuleEnv head . filterModuleEnv (const $ not . null) - name = mapNameEnv head . filterNameEnv (not . null) + mod = mapMaybeModuleEnv (const listToMaybe) + name = mapMaybeNameEnv listToMaybe {- Note [Annotations] @@ -799,14 +360,14 @@ msg msg_class doc = do logger <- getLogger loc <- getSrcSpanM - unqual <- getPrintUnqualified + name_ppr_ctx <- getNamePprCtx let sty = case msg_class of - MCDiagnostic _ _ -> err_sty - MCDump -> dump_sty - _ -> user_sty - err_sty = mkErrStyle unqual - user_sty = mkUserStyle unqual AllTheWay - dump_sty = mkDumpStyle unqual + MCDiagnostic _ _ _ -> err_sty + MCDump -> dump_sty + _ -> user_sty + err_sty = mkErrStyle name_ppr_ctx + user_sty = mkUserStyle name_ppr_ctx AllTheWay + dump_sty = mkDumpStyle name_ppr_ctx liftIO $ logMsg logger msg_class loc (withPprStyle sty doc) -- | Output a String message to the screen @@ -816,10 +377,6 @@ -- | Output a message to the screen putMsg :: SDoc -> CoreM () putMsg = msg MCInfo - --- | Output an error to the screen. Does not cause the compiler to die. -errorMsgS :: String -> CoreM () -errorMsgS = errorMsg . text -- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM () diff --git a/GHC/Core/Opt/Monad.hs-boot b/GHC/Core/Opt/Monad.hs-boot deleted file mode 100644 --- a/GHC/Core/Opt/Monad.hs-boot +++ /dev/null @@ -1,30 +0,0 @@ --- Created this hs-boot file to remove circular dependencies from the use of --- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core --- transformations. --- However GHC.Core.Opt.Monad does much more than defining these, and because Plugins are --- activated in various modules, the imports become circular. To solve this I --- extracted CoreToDo and CoreM into this file. --- I needed to write the whole definition of these types, otherwise it created --- a data-newtype conflict. - -module GHC.Core.Opt.Monad ( CoreToDo, CoreM ) where - -import GHC.Prelude - -import GHC.Data.IOEnv ( IOEnv ) - -type CoreIOEnv = IOEnv CoreReader - -data CoreReader - -newtype CoreWriter = CoreWriter { - cw_simpl_count :: SimplCount -} - -data SimplCount - -newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) } - -instance Monad CoreM - -data CoreToDo 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 @@ -19,19 +19,20 @@ module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr, - zapLambdaBndrs + zapLambdaBndrs, scrutBinderSwap_maybe ) where -import GHC.Prelude +import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Core import GHC.Core.FVs import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, - stripTicksTopE, mkTicks ) -import GHC.Core.Opt.Arity ( joinRhsArity ) + 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.Core.TyCo.FVs ( tyCoVarsOfMCo ) import GHC.Data.Maybe( isJust, orElse ) import GHC.Data.Graph.Directed ( SCC(..), Node(..) @@ -53,12 +54,13 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Misc -import GHC.Utils.Trace 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 {- ************************************************************************ @@ -363,6 +365,12 @@ 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. -} {- @@ -613,7 +621,7 @@ 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. -Aame with rules. Suppose we have: +Same with rules. Suppose we have: let j :: Int -> Int j y = 2 * y @@ -625,7 +633,7 @@ 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-cal info from the RHS of the rule to +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 @@ -782,7 +790,7 @@ -- h = ... -- g = ... -- RULE map g = h - -- Then we want to ensure that h is in scope everwhere + -- 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. @@ -952,7 +960,7 @@ (which occurs just once), but because it is last we won't actually substitute in lvl2. Sigh. -To avoid this possiblity, we include edges from lvl2 to /both/ its +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. @@ -1216,7 +1224,7 @@ $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 breakders is +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] @@ -1749,7 +1757,7 @@ * 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 Note [Eta-expansion in stable unfoldings]). + 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 @@ -1851,7 +1859,8 @@ -- 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! + -- 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) @@ -1861,7 +1870,7 @@ {- 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 the Cast +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. @@ -2362,7 +2371,7 @@ f's strictness signature into e1 .. en, but /only/ if n is enough to saturate the strictness signature. A strictness signature like - f :: C1(C1(L))LS + 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 @@ -2398,10 +2407,10 @@ B: Let-bindings: eg let f = \c. let ... in \n -> blah in (build f, build f) - Propagate one-shot info from the demanand-info on 'f' to the + 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 demanand + 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 @@ -2456,9 +2465,9 @@ -- See Note [The binder-swap substitution] -- If x :-> (y, co) is in the env, - -- then please replace x by (y |> sym mco) - -- Invariant of course: idType x = exprType (y |> sym mco) - , occ_bs_env :: !(VarEnv (OutId, MCoercion)) + -- 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 @@ -2665,7 +2674,7 @@ There are two main pieces: * Given case x |> co of b { alts } - we add [x :-> (b, co)] to the occ_bs_env environment; this is + 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 @@ -2737,30 +2746,8 @@ (BS5) We have to apply the occ_bs_env substitution uniformly, including to (local) rules and unfoldings. -Historical note ---------------- -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. +(BS6) We must be very careful with dictionaries. + See Note [Care with binder-swap on dictionaries] Note [Case of cast] ~~~~~~~~~~~~~~~~~~~ @@ -2770,6 +2757,54 @@ 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 @@ -2784,8 +2819,87 @@ 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, @@ -2844,53 +2958,8 @@ 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. --} -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) <- get_scrut_var (stripTicksTopE (const True) 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 - get_scrut_var :: OutExpr -> Maybe (OutVar, MCoercion) - get_scrut_var (Var v) = Just (v, MRefl) - get_scrut_var (Cast (Var v) co) = Just (v, MCo co) -- See Note [Case of cast] - get_scrut_var _ = Nothing - - case_bndr' = zapIdOccInfo case_bndr - -- See Note [Zap case binders in proxy bindings] - -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) -> (add_cast fun mco, fun_id) } - - where - add_cast fun MRefl = fun - add_cast fun (MCo co) = Cast fun (mkSymCo co) - -- We must switch that 'co' to 'sym co'; - -- see the comment with occ_bs_env - -- No need to test for isReflCo, because 'co' came from - -- a (Cast e co) and hence is unlikely to be Refl - -{- ************************************************************************ * * \subsection[OccurAnal-types]{OccEnv} @@ -3129,7 +3198,7 @@ tagNonRecBinder lvl usage binder = let occ = lookupDetails usage binder - will_be_join = decideJoinPointHood lvl 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 @@ -3154,8 +3223,12 @@ -- 1. Determine join-point-hood of whole group, as determined by -- the *unadjusted* usage details unadj_uds = foldr andUDs body_uds rhs_udss - will_be_joins = decideJoinPointHood lvl unadj_uds bndrs + -- 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 @@ -3210,12 +3283,12 @@ -- -- See Note [Invariants on join points] in "GHC.Core". decideJoinPointHood :: TopLevelFlag -> UsageDetails - -> [CoreBndr] + -> NonEmpty CoreBndr -> Bool decideJoinPointHood TopLevel _ _ = False decideJoinPointHood NotTopLevel usage bndrs - | isJoinId (head bndrs) + | isJoinId (NE.head bndrs) = warnPprTrace (not all_ok) "OccurAnal failed to rediscover join point(s)" (ppr bndrs) all_ok 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 @@ -13,24 +13,24 @@ import GHC.Driver.Session import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Driver.Env +import GHC.Driver.Config.Core.Lint ( endPass ) +import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts ) +import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode, initGentleSimplMode ) +import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts ) +import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Platform.Ways ( hasWay, Way(WayProf) ) import GHC.Core import GHC.Core.Opt.CSE ( cseProgram ) -import GHC.Core.Rules ( mkRuleBase, - extendRuleBaseList, ruleCheckProgram, addRuleInfo, - getRules, initRuleOpts ) -import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) -import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) -import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) -import GHC.Core.Utils ( mkTicks, stripTicksTop, dumpIdInfoOfProgram ) -import GHC.Core.Lint ( endPass, lintPassResult, dumpPassResult, - lintAnnots ) -import GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplImpRules ) -import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding ) -import GHC.Core.Opt.Simplify.Env +import GHC.Core.Rules ( RuleBase, mkRuleBase, ruleCheckProgram, getRules ) +import GHC.Core.Ppr ( pprCoreBindings ) +import GHC.Core.Utils ( dumpIdInfoOfProgram ) +import GHC.Core.Lint ( lintAnnots ) +import GHC.Core.Lint.Interactive ( interactiveInScope ) +import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm ) import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Monad +import GHC.Core.Opt.Pipeline.Types import GHC.Core.Opt.FloatIn ( floatInwards ) import GHC.Core.Opt.FloatOut ( floatOutwards ) import GHC.Core.Opt.LiberateCase ( liberateCase ) @@ -51,29 +51,19 @@ import GHC.Utils.Logger as Logger import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Trace -import GHC.Unit.External -import GHC.Unit.Module.Env import GHC.Unit.Module.ModGuts -import GHC.Unit.Module.Deps -import GHC.Runtime.Context - -import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Basic import GHC.Types.Demand ( zapDmdEnvSig ) -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Types.Tickish -import GHC.Types.Unique.FM import GHC.Types.Name.Ppr +import GHC.Types.Var ( Var ) import Control.Monad import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Module + {- ************************************************************************ * * @@ -85,14 +75,12 @@ core2core :: HscEnv -> ModGuts -> IO ModGuts core2core hsc_env guts@(ModGuts { mg_module = mod , mg_loc = loc - , mg_deps = deps , mg_rdr_env = rdr_env }) - = do { let builtin_passes = getCoreToDo logger dflags - orph_mods = mkModuleSet (mod : dep_orphs deps) + = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars uniq_mask = 's' - ; + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod - orph_mods print_unqual loc $ + name_ppr_ctx loc $ do { hsc_env' <- getHscEnv ; all_passes <- withPlugins (hsc_plugins hsc_env') installCoreToDos @@ -106,12 +94,14 @@ ; return guts2 } where - logger = hsc_logger hsc_env dflags = hsc_dflags hsc_env + logger = hsc_logger 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 - print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env + name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_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 -- consume the ModGuts to find the module) but somewhat ugly because mg_module may @@ -126,8 +116,9 @@ ************************************************************************ -} -getCoreToDo :: Logger -> DynFlags -> [CoreToDo] -getCoreToDo logger dflags +getCoreToDo :: DynFlags -> RuleBase -> [Var] -> [CoreToDo] +-- This function builds the pipeline of optimisations +getCoreToDo dflags hpt_rule_base extra_vars = flatten_todos core_todo where phases = simplPhases dflags @@ -147,8 +138,6 @@ late_specialise = gopt Opt_LateSpecialise dflags static_args = gopt Opt_StaticArgumentTransformation dflags rules_on = gopt Opt_EnableRewriteRules dflags - eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags - pre_inline_on = gopt Opt_SimplPreInlining dflags ww_on = gopt Opt_WorkerWrapper dflags static_ptrs = xopt LangExt.StaticPointers dflags profiling = ways dflags `hasWay` WayProf @@ -159,30 +148,15 @@ maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) maybe_strictness_before (Phase phase) - | phase `elem` strictnessBefore dflags = CoreDoDemand + | phase `elem` strictnessBefore dflags = CoreDoDemand False maybe_strictness_before _ = CoreDoNothing - base_mode = SimplMode { sm_phase = panic "base_mode" - , sm_names = [] - , sm_dflags = dflags - , sm_logger = logger - , sm_uf_opts = unfoldingOpts dflags - , sm_rules = rules_on - , sm_eta_expand = eta_expand_on - , sm_cast_swizzle = True - , sm_inline = True - , sm_case_case = True - , sm_pre_inline = pre_inline_on - } - simpl_phase phase name iter = CoreDoPasses $ [ maybe_strictness_before phase - , CoreDoSimplify iter - (base_mode { sm_phase = phase - , sm_names = [name] }) - + , CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter + (initSimplMode dflags phase name) hpt_rule_base , maybe_rule_check phase ] -- Run GHC's internal simplification phase, after all rules have run. @@ -190,18 +164,13 @@ simplify name = simpl_phase FinalPhase name max_iter -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently = CoreDoSimplify max_iter - (base_mode { sm_phase = InitialPhase - , sm_names = ["Gentle"] - , sm_rules = rules_on -- Note [RULEs enabled in InitialPhase] - , sm_inline = True - -- See Note [Inline in InitialPhase] - , sm_case_case = False }) - -- Don't do case-of-case transformations. - -- This makes full laziness work better + -- See Note [Inline in InitialPhase] + -- See Note [RULEs enabled in InitialPhase] + simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter + (initGentleSimplMode dflags) hpt_rule_base - dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper] - else [CoreDoDemand,CoreDoCpr] + dmd_cpr_ww = if ww_on then [CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper] + else [CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper] demand_analyser = (CoreDoPasses ( @@ -273,7 +242,7 @@ -- GHC.Iface.Tidy.StaticPtrTable. static_ptrs_float_outwards, - -- Run the simplier phases 2,1,0 to allow rewrite rules to fire + -- Run the simplifier phases 2,1,0 to allow rewrite rules to fire runWhen do_simpl3 (CoreDoPasses $ [ simpl_phase (Phase phase) "main" max_iter | phase <- [phases, phases-1 .. 1] ] ++ @@ -369,7 +338,7 @@ -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution -- can become /exponentially/ more expensive. See #11731, #12996. - runWhen (strictness || late_dmd_anal) CoreDoDemand, + runWhen (strictness || late_dmd_anal) (CoreDoDemand False), maybe_rule_check FinalPhase, @@ -384,6 +353,15 @@ flatten_todos passes ++ flatten_todos rest flatten_todos (todo : rest) = todo : flatten_todos rest +-- The core-to-core pass ordering is derived from the DynFlags: +runWhen :: Bool -> CoreToDo -> CoreToDo +runWhen True do_this = do_this +runWhen False _ = CoreDoNothing + +runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo +runMaybe (Just x) f = f x +runMaybe Nothing _ = CoreDoNothing + {- Note [Inline in InitialPhase] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is @@ -437,7 +415,7 @@ with -O2 -flate-specialise 1. I found that running late-Specialise after SpecConstr, with no - simplification in between meant that the carefullly constructed + simplification in between meant that the carefully constructed SpecConstr rule never got to fire. (It was something like lvl = f a -- Arity 1 ....g lvl.... @@ -477,6 +455,7 @@ doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass pass guts = do logger <- getLogger + hsc_env <- getHscEnv dflags <- getDynFlags us <- getUniqueSupplyM p_fam_env <- getPackageFamInstEnv @@ -484,16 +463,21 @@ 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' } + let name_ppr_ctx = + mkNamePprCtx + (initPromotionTickContext dflags) + (hsc_unit_env hsc_env) + (mg_rdr_env guts) case pass of - CoreDoSimplify {} -> {-# SCC "Simplify" #-} - simplifyPgm pass guts + CoreDoSimplify opts -> {-# SCC "Simplify" #-} + liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) name_ppr_ctx opts guts CoreCSE -> {-# SCC "CommonSubExpr" #-} updateBinds cseProgram CoreLiberateCase -> {-# SCC "LiberateCase" #-} - updateBinds (liberateCase dflags) + updateBinds (liberateCase (initLiberateCaseOpts dflags)) CoreDoFloatInwards -> {-# SCC "FloatInwards" #-} updateBinds (floatInwards platform) @@ -510,14 +494,16 @@ CoreDoExitify -> {-# SCC "Exitify" #-} updateBinds exitifyProgram - CoreDoDemand -> {-# SCC "DmdAnal" #-} - updateBindsM (liftIO . dmdAnal logger dflags fam_envs (mg_rules guts)) + CoreDoDemand before_ww -> {-# SCC "DmdAnal" #-} + updateBindsM (liftIO . dmdAnal logger before_ww dflags fam_envs (mg_rules guts)) CoreDoCpr -> {-# SCC "CprAnal" #-} updateBindsM (liftIO . cprAnalProgram logger fam_envs) CoreDoWorkerWrapper -> {-# SCC "WorkWrap" #-} - updateBinds (wwTopBinds (mg_module guts) dflags fam_envs us) + updateBinds (wwTopBinds + (initWorkWrapOpts (mg_module guts) dflags fam_envs) + us) CoreDoSpecialising -> {-# SCC "Specialise" #-} specProgram guts @@ -545,7 +531,6 @@ CoreDesugarOpt -> pprPanic "doCorePass" (ppr pass) CoreTidy -> pprPanic "doCorePass" (ppr pass) CorePrep -> pprPanic "doCorePass" (ppr pass) - CoreOccurAnal -> pprPanic "doCorePass" (ppr pass) {- ************************************************************************ @@ -565,516 +550,19 @@ logger <- getLogger withTiming logger (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) (const ()) $ do - rb <- getRuleBase - vis_orphs <- getVisibleOrphanMods - let rule_fn fn = getRules (RuleEnv [rb] vis_orphs) fn - ++ (mg_rules guts) - let ropts = initRuleOpts dflags + rule_env <- initRuleEnv guts + let rule_fn fn = getRules rule_env fn + ropts = initRuleOpts dflags liftIO $ logDumpMsg logger "Rule check" (ruleCheckProgram ropts current_phase pat rule_fn (mg_binds guts)) return guts -{- -************************************************************************ -* * - Gentle simplification -* * -************************************************************************ --} - -simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do - -> CoreExpr - -> IO CoreExpr --- simplifyExpr is called by the driver to simplify an --- expression typed in at the interactive prompt -simplifyExpr hsc_env expr - = withTiming logger (text "Simplify [expr]") (const ()) $ - do { eps <- hscEPS hsc_env ; - ; let fi_env = ( eps_fam_inst_env eps - , extendFamInstEnvList emptyFamInstEnv $ - snd $ ic_instances $ hsc_IC hsc_env ) - simpl_env = simplEnvForGHCi logger dflags - - ; let sz = exprSize expr - - ; (expr', counts) <- initSmpl logger dflags (eps_rule_base <$> hscEPS hsc_env) emptyRuleEnv fi_env sz $ - simplExprGently simpl_env expr - - ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats - "Simplifier statistics" FormatText (pprSimplCount counts) - - ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression" - FormatCore - (pprCoreExpr expr') - - ; return expr' - } - where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - -simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr --- Simplifies an expression --- does occurrence analysis, then simplification --- and repeats (twice currently) because one pass --- alone leaves tons of crud. --- Used (a) for user expressions typed in at the interactive prompt --- (b) the LHS and RHS of a RULE --- (c) Template Haskell splices --- --- The name 'Gently' suggests that the SimplMode is InitialPhase, --- and in fact that is so.... but the 'Gently' in simplExprGently doesn't --- enforce that; it just simplifies the expression twice - --- It's important that simplExprGently does eta reduction; see --- Note [Simplify rule LHS] above. The --- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam) --- but only if -O is on. - -simplExprGently env expr = do - expr1 <- simplExpr env (occurAnalyseExpr expr) - simplExpr env (occurAnalyseExpr expr1) - -{- -************************************************************************ -* * -\subsection{The driver for the simplifier} -* * -************************************************************************ --} - -simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts -simplifyPgm pass guts - = do { hsc_env <- getHscEnv - ; rb <- getRuleBase - ; liftIOWithCount $ - simplifyPgmIO pass hsc_env rb guts } - -simplifyPgmIO :: CoreToDo - -> HscEnv - -> RuleBase - -> ModGuts - -> IO (SimplCount, ModGuts) -- New bindings - -simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) - hsc_env hpt_rule_base - guts@(ModGuts { mg_module = this_mod - , mg_rdr_env = rdr_env - , mg_deps = deps - , mg_binds = binds, mg_rules = rules - , mg_fam_inst_env = fam_inst_env }) - = do { (termination_msg, it_count, counts_out, guts') - <- do_iteration 1 [] binds rules - - ; when (logHasDumpFlag logger Opt_D_verbose_core2core - && logHasDumpFlag logger Opt_D_dump_simpl_stats) $ - logDumpMsg logger - "Simplifier statistics for following pass" - (vcat [text termination_msg <+> text "after" <+> ppr it_count - <+> text "iterations", - blankLine, - pprSimplCount counts_out]) - - ; return (counts_out, guts') - } - where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env - simpl_env = mkSimplEnv mode - active_rule = activeRule mode - active_unf = activeUnfolding mode - - do_iteration :: Int --UniqSupply - -- -> Int -- Counts iterations - -> [SimplCount] -- Counts from earlier iterations, reversed - -> CoreProgram -- Bindings in - -> [CoreRule] -- and orphan rules - -> IO (String, Int, SimplCount, ModGuts) - - do_iteration iteration_no counts_so_far binds rules - -- iteration_no is the number of the iteration we are - -- about to begin, with '1' for the first - | iteration_no > max_iterations -- Stop if we've run out of iterations - = warnPprTrace (debugIsOn && (max_iterations > 2)) - "Simplifier bailing out" - ( hang (ppr this_mod <> text ", after" - <+> int max_iterations <+> text "iterations" - <+> (brackets $ hsep $ punctuate comma $ - map (int . simplCountN) (reverse counts_so_far))) - 2 (text "Size =" <+> ppr (coreBindsStats binds))) $ - - -- Subtract 1 from iteration_no to get the - -- number of iterations we actually completed - return ( "Simplifier baled out", iteration_no - 1 - , totalise counts_so_far - , guts { mg_binds = binds, mg_rules = rules } ) - - -- Try and force thunks off the binds; significantly reduces - -- space usage, especially with -O. JRS, 000620. - | let sz = coreBindsSize binds - , () <- sz `seq` () -- Force it - = do { - -- Occurrence analysis - let { tagged_binds = {-# SCC "OccAnal" #-} - occurAnalysePgm this_mod active_unf active_rule rules - binds - } ; - Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" - FormatCore - (pprCoreBindings tagged_binds); - - -- read_eps_rules: - -- We need to read rules from the EPS regularly because simplification can - -- poke on IdInfo thunks, which in turn brings in new rules - -- behind the scenes. Otherwise there's a danger we'll simply - -- miss the rules for Ids hidden inside imported inlinings - -- Hence just before attempting to match rules we read on the EPS - -- value and then combine it when the existing rule base. - -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`. - eps <- hscEPS hsc_env ; - let { read_eps_rules = eps_rule_base <$> hscEPS hsc_env - ; rule_base = extendRuleBaseList hpt_rule_base rules - ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) - ; vis_orphs = this_mod : dep_orphs deps } ; - - -- Simplify the program - ((binds1, rules1), counts1) <- - initSmpl logger dflags read_eps_rules (mkRuleEnv rule_base vis_orphs) fam_envs sz $ - do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} - simplTopBinds simpl_env tagged_binds - - -- Apply the substitution to rules defined in this module - -- for imported Ids. Eg RULE map my_f = blah - -- If we have a substitution my_f :-> other_f, we'd better - -- apply it to the rule to, or it'll never match - ; rules1 <- simplImpRules env1 rules - - ; return (getTopFloatBinds floats, rules1) } ; - - -- Stop if nothing happened; don't dump output - -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Monad - if isZeroSimplCount counts1 then - return ( "Simplifier reached fixed point", iteration_no - , totalise (counts1 : counts_so_far) -- Include "free" ticks - , guts { mg_binds = binds1, mg_rules = rules1 } ) - else do { - -- Short out indirections - -- We do this *after* at least one run of the simplifier - -- because indirection-shorting uses the export flag on *occurrences* - -- and that isn't guaranteed to be ok until after the first run propagates - -- stuff from the binding site to its occurrences - -- - -- ToDo: alas, this means that indirection-shorting does not happen at all - -- if the simplifier does nothing (not common, I know, but unsavoury) - let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; - - -- Dump the result of this iteration - let { dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags) } ; - dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts1 binds2 rules1 ; - lintPassResult hsc_env pass binds2 ; - - -- 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 - totalise = foldr (\c acc -> acc `plusSimplCount` c) - (zeroSimplCount dflags) - -simplifyPgmIO _ _ _ _ = panic "simplifyPgmIO" - -------------------- -dump_end_iteration :: Logger -> Bool -> PrintUnqualified -> Int - -> SimplCount -> CoreProgram -> [CoreRule] -> IO () -dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts binds rules - = dumpPassResult logger dump_core_sizes print_unqual mb_flag hdr pp_counts binds rules - where - mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations - | otherwise = Nothing - -- Show details if Opt_D_dump_simpl_iterations is on - - hdr = "Simplifier iteration=" ++ show iteration_no - pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr - , pprSimplCount counts - , text "---- End of simplifier counts for" <+> text hdr ] - -{- -************************************************************************ -* * - Shorting out indirections -* * -************************************************************************ - -If we have this: - - x_local = - ...bindings... - x_exported = x_local - -where x_exported is exported, and x_local is not, then we replace it with this: - - x_exported = - x_local = x_exported - ...bindings... - -Without this we never get rid of the x_exported = x_local thing. This -save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and -makes strictness information propagate better. This used to happen in -the final phase, but it's tidier to do it here. - -Note [Messing up the exported Id's RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must be careful about discarding (obviously) or even merging the -RULES on the exported Id. The example that went bad on me at one stage -was this one: - - iterate :: (a -> a) -> a -> [a] - [Exported] - iterate = iterateList - - iterateFB c f x = x `c` iterateFB c f (f x) - iterateList f x = x : iterateList f (f x) - [Not exported] - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterateList - #-} - -This got shorted out to: - - iterateList :: (a -> a) -> a -> [a] - iterateList = iterate - - iterateFB c f x = x `c` iterateFB c f (f x) - iterate f x = x : iterate f (f x) - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterate - #-} - -And now we get an infinite loop in the rule system - iterate f x -> build (\cn -> iterateFB c f x) - -> iterateFB (:) f x - -> iterate f x - -Old "solution": - use rule switching-off pragmas to get rid - of iterateList in the first place - -But in principle the user *might* want rules that only apply to the Id -they say. And inline pragmas are similar - {-# NOINLINE f #-} - f = local - local = -Then we do not want to get rid of the NOINLINE. - -Hence hasShortableIdinfo. - - -Note [Rules and indirection-zapping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Problem: what if x_exported has a RULE that mentions something in ...bindings...? -Then the things mentioned can be out of scope! Solution - a) Make sure that in this pass the usage-info from x_exported is - available for ...bindings... - b) If there are any such RULES, rec-ify the entire top-level. - It'll get sorted out next time round - -Other remarks -~~~~~~~~~~~~~ -If more than one exported thing is equal to a local thing (i.e., the -local thing really is shared), then we do one only: -\begin{verbatim} - x_local = .... - x_exported1 = x_local - x_exported2 = x_local -==> - x_exported1 = .... - - x_exported2 = x_exported1 -\end{verbatim} - -We rely on prior eta reduction to simplify things like -\begin{verbatim} - x_exported = /\ tyvars -> x_local tyvars -==> - x_exported = x_local -\end{verbatim} -Hence,there's a possibility of leaving unchanged something like this: -\begin{verbatim} - x_local = .... - x_exported1 = x_local Int -\end{verbatim} -By the time we've thrown away the types in STG land this -could be eliminated. But I don't think it's very common -and it's dangerous to do this fiddling in STG land -because we might eliminate a binding that's mentioned in the -unfolding for something. - -Note [Indirection zapping and ticks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Unfortunately this is another place where we need a special case for -ticks. The following happens quite regularly: - - x_local = - x_exported = tick x_local - -Which we want to become: - - x_exported = tick - -As it makes no sense to keep the tick and the expression on separate -bindings. Note however that this might increase the ticks scoping -over the execution of x_local, so we can only do this for floatable -ticks. More often than not, other references will be unfoldings of -x_exported, and therefore carry the tick anyway. --} - -type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks - -shortOutIndirections :: CoreProgram -> CoreProgram -shortOutIndirections binds - | isEmptyVarEnv ind_env = binds - | no_need_to_flatten = binds' -- See Note [Rules and indirection-zapping] - | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff - where - ind_env = makeIndEnv binds - -- These exported Ids are the subjects of the indirection-elimination - exp_ids = map fst $ nonDetEltsUFM ind_env - -- It's OK to use nonDetEltsUFM here because we forget the ordering - -- by immediately converting to a set or check if all the elements - -- satisfy a predicate. - exp_id_set = mkVarSet exp_ids - no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids - binds' = concatMap zap binds - - zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] - zap (Rec pairs) = [Rec (concatMap zapPair pairs)] - - zapPair (bndr, rhs) - | bndr `elemVarSet` exp_id_set - = [] -- Kill the exported-id binding - - | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr - , (exp_id', lcl_id') <- transferIdInfo exp_id bndr - = -- Turn a local-id binding into two bindings - -- exp_id = rhs; lcl_id = exp_id - [ (exp_id', mkTicks ticks rhs), - (lcl_id', Var exp_id') ] - - | otherwise - = [(bndr,rhs)] - -makeIndEnv :: [CoreBind] -> IndEnv -makeIndEnv binds - = foldl' add_bind emptyVarEnv binds - where - add_bind :: IndEnv -> CoreBind -> IndEnv - add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs) - add_bind env (Rec pairs) = foldl' add_pair env pairs - - add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv - add_pair env (exported_id, exported) - | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported - , shortMeOut env exported_id local_id - = extendVarEnv env local_id (exported_id, ticks) - add_pair env _ = env - ------------------ -shortMeOut :: IndEnv -> Id -> Id -> Bool -shortMeOut ind_env exported_id local_id --- The if-then-else stuff is just so I can get a pprTrace to see --- how often I don't get shorting out because of IdInfo stuff - = if isExportedId exported_id && -- Only if this is exported - - isLocalId local_id && -- Only if this one is defined in this - -- module, so that we *can* change its - -- binding to be the exported thing! - - not (isExportedId local_id) && -- Only if this one is not itself exported, - -- since the transformation will nuke it - - not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for - then - if hasShortableIdInfo exported_id - then True -- See Note [Messing up the exported Id's RULES] - else warnPprTrace True "Not shorting out" (ppr exported_id) False - else - False - ------------------ -hasShortableIdInfo :: Id -> Bool --- True if there is no user-attached IdInfo on exported_id, --- so we can safely discard it --- See Note [Messing up the exported Id's RULES] -hasShortableIdInfo id - = isEmptyRuleInfo (ruleInfo info) - && isDefaultInlinePragma (inlinePragInfo info) - && not (isStableUnfolding (realUnfoldingInfo info)) - where - info = idInfo id - ------------------ -{- Note [Transferring IdInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have - lcl_id = e; exp_id = lcl_id - -and lcl_id has useful IdInfo, we don't want to discard it by going - gbl_id = e; lcl_id = gbl_id - -Instead, transfer IdInfo from lcl_id to exp_id, specifically -* (Stable) unfolding -* Strictness -* Rules -* Inline pragma - -Overwriting, rather than merging, seems to work ok. - -For the lcl_id we - -* Zap the InlinePragma. It might originally have had a NOINLINE, which - we have now transferred; and we really want the lcl_id to inline now - that its RHS is trivial! - -* Zap any Stable unfolding. agian, we want lcl_id = gbl_id to inline, - replacing lcl_id by gbl_id. That won't happen if lcl_id has its original - great big Stable unfolding --} - -transferIdInfo :: Id -> Id -> (Id, Id) --- See Note [Transferring IdInfo] -transferIdInfo exported_id local_id - = ( modifyIdInfo transfer exported_id - , modifyIdInfo zap_info local_id ) - where - local_info = idInfo local_id - transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info - `setCprSigInfo` cprSigInfo local_info - `setUnfoldingInfo` realUnfoldingInfo local_info - `setInlinePragInfo` inlinePragInfo local_info - `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info - new_info = setRuleInfoHead (idName exported_id) - (ruleInfo local_info) - -- Remember to set the function-name field of the - -- rules as we transfer them from one function to another - - zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma - `setUnfoldingInfo` noUnfolding - - -dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram -dmdAnal logger dflags fam_envs rules binds = do +dmdAnal :: Logger -> Bool -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram +dmdAnal logger before_ww dflags fam_envs rules binds = do let !opts = DmdAnalOpts { dmd_strict_dicts = gopt Opt_DictsStrict dflags + , dmd_do_boxity = before_ww -- only run Boxity Analysis immediately preceding WW , dmd_unbox_width = dmdUnboxWidth dflags , dmd_max_worker_args = maxWorkerArgs dflags } diff --git a/GHC/Core/Opt/Pipeline/Types.hs b/GHC/Core/Opt/Pipeline/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Pipeline/Types.hs @@ -0,0 +1,103 @@ +module GHC.Core.Opt.Pipeline.Types ( + -- * Configuration of the core-to-core passes + CorePluginPass, CoreToDo(..), + bindsOnlyPass, pprPassDetails, + ) where + +import GHC.Prelude + +import GHC.Core ( CoreProgram ) +import GHC.Core.Opt.Monad ( CoreM, FloatOutSwitches ) +import GHC.Core.Opt.Simplify ( SimplifyOpts(..) ) + +import GHC.Types.Basic ( CompilerPhase(..) ) +import GHC.Unit.Module.ModGuts +import GHC.Utils.Outputable as Outputable + +{- +************************************************************************ +* * + The CoreToDo type and related types + Abstraction of core-to-core passes to run. +* * +************************************************************************ +-} + +-- | A description of the plugin pass itself +type CorePluginPass = ModGuts -> CoreM ModGuts + +bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts +bindsOnlyPass pass guts + = do { binds' <- pass (mg_binds guts) + ; return (guts { mg_binds = binds' }) } + +data CoreToDo -- These are diff core-to-core passes, + -- which may be invoked in any order, + -- as many times as you like. + + = CoreDoSimplify !SimplifyOpts + -- ^ The core-to-core simplifier. + | CoreDoPluginPass String CorePluginPass + | CoreDoFloatInwards + | CoreDoFloatOutwards FloatOutSwitches + | CoreLiberateCase + | CoreDoPrintCore + | CoreDoStaticArgs + | CoreDoCallArity + | CoreDoExitify + | CoreDoDemand Bool -- Bool: Do worker/wrapper afterwards? + -- See Note [Don't change boxity without worker/wrapper] + | CoreDoCpr + | CoreDoWorkerWrapper + | CoreDoSpecialising + | CoreDoSpecConstr + | CoreCSE + | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules + -- matching this string + | CoreDoNothing -- Useful when building up + | CoreDoPasses [CoreToDo] -- lists of these things + + | CoreDesugar -- Right after desugaring, no simple optimisation yet! + | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces + -- Core output, and hence useful to pass to endPass + + | CoreTidy + | CorePrep + | CoreAddCallerCcs + | CoreAddLateCcs + +instance Outputable CoreToDo where + ppr (CoreDoSimplify _) = text "Simplifier" + ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s + ppr CoreDoFloatInwards = text "Float inwards" + ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) + ppr CoreLiberateCase = text "Liberate case" + ppr CoreDoStaticArgs = text "Static argument" + ppr CoreDoCallArity = text "Called arity analysis" + ppr CoreDoExitify = text "Exitification transformation" + ppr (CoreDoDemand True) = text "Demand analysis (including Boxity)" + ppr (CoreDoDemand False) = text "Demand analysis" + ppr CoreDoCpr = text "Constructed Product Result analysis" + ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" + ppr CoreDoSpecialising = text "Specialise" + ppr CoreDoSpecConstr = text "SpecConstr" + ppr CoreCSE = text "Common sub-expression" + ppr CoreDesugar = text "Desugar (before optimization)" + ppr CoreDesugarOpt = text "Desugar (after optimization)" + ppr CoreTidy = text "Tidy Core" + ppr CoreAddCallerCcs = text "Add caller cost-centres" + ppr CoreAddLateCcs = text "Add late core cost-centres" + ppr CorePrep = text "CorePrep" + ppr CoreDoPrintCore = text "Print core" + ppr (CoreDoRuleCheck {}) = text "Rule check" + ppr CoreDoNothing = text "CoreDoNothing" + ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes + +pprPassDetails :: CoreToDo -> SDoc +pprPassDetails (CoreDoSimplify cfg) = vcat [ text "Max iterations =" <+> int n + , ppr md ] + where + n = so_iterations cfg + md = so_mode cfg + +pprPassDetails _ = Outputable.empty 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 @@ -1,4 +1,3 @@ - {-# LANGUAGE PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -52,17 +51,6 @@ 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. - - This can only work if @wild@ is an unrestricted binder. Indeed, even with the - extended typing rule (in the linter) for case expressions, if - case x of wild % 1 { p -> e} - is well-typed, then - case x of wild % 1 { p -> e[wild\x] } - is only well-typed if @e[wild\x] = e@ (that is, if @wild@ is not used in @e@ - at all). In which case, it is, of course, pointless to do the substitution - anyway. So for a linear binder (and really anything which isn't unrestricted), - doing this substitution would either produce ill-typed terms or be the - identity. -} module GHC.Core.Opt.SetLevels ( @@ -83,18 +71,17 @@ , exprOkForSpeculation , exprIsTopLevelBindable , collectMakeStaticArgs - , mkLamTypes + , mkLamTypes, extendInScopeSetBndrs ) -import GHC.Core.Opt.Arity ( exprBotStrictness_maybe ) +import GHC.Core.Opt.Arity ( exprBotStrictness_maybe, isOneShotBndr ) import GHC.Core.FVs -- all of it import GHC.Core.Subst import GHC.Core.Make ( sortQuantVars ) -import GHC.Core.Type ( Type, splitTyConApp_maybe, tyCoVarsOfType +import GHC.Core.Type ( Type, tyCoVarsOfType , mightBeUnliftedType, closeOverKindsDSet , typeHasFixedRuntimeRep ) -import GHC.Core.Multiplicity ( pattern Many ) -import GHC.Core.DataCon ( dataConOrigResTy ) +import GHC.Core.Multiplicity ( pattern ManyTy ) import GHC.Types.Id import GHC.Types.Id.Info @@ -104,10 +91,10 @@ import GHC.Types.Unique.DSet ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal ( litIsTrivial ) -import GHC.Types.Demand ( DmdSig, Demand, isStrUsedDmd, splitDmdSig, prependArgsDmdSig ) -import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Types.Demand ( DmdSig, prependArgsDmdSig ) +import GHC.Types.Cpr ( CprSig, prependArgsCprSig ) import GHC.Types.Name ( getOccName, mkSystemVarName ) -import GHC.Types.Name.Occurrence ( occNameString ) +import GHC.Types.Name.Occurrence ( occNameFS ) import GHC.Types.Unique ( hasKey ) import GHC.Types.Tickish ( tickishIsCode ) import GHC.Types.Unique.Supply @@ -120,12 +107,10 @@ import GHC.Data.FastString import GHC.Utils.FV -import GHC.Utils.Monad ( mapAccumLM ) import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Trace import Data.Maybe @@ -364,7 +349,7 @@ If there were another lambda in @r@'s rhs, it would get level-2 as well. -} -lvlExpr env (_, AnnType ty) = return (Type (GHC.Core.Subst.substTy (le_subst env) ty)) +lvlExpr env (_, AnnType ty) = return (Type (substTyUnchecked (le_subst env) ty)) lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co)) lvlExpr env (_, AnnVar v) = return (lookupVar env v) lvlExpr _ (_, AnnLit lit) = return (Lit lit) @@ -440,21 +425,13 @@ ; return (foldl' App lapp' rargs') } | otherwise - = do { (_, args') <- mapAccumLM lvl_arg stricts args - -- Take account of argument strictness; see - -- Note [Floating to the top] + = do { args' <- mapM (lvlMFE env False) args + -- False: see "Arguments" in Note [Floating to the top] ; return (foldl' App (lookupVar env fn) args') } where n_val_args = count (isValArg . deAnnotate) args arity = idArity fn - stricts :: [Demand] -- True for strict /value/ arguments - stricts = case splitDmdSig (idDmdSig fn) of - (arg_ds, _) | arg_ds `lengthExceeds` n_val_args - -> [] - | otherwise - -> arg_ds - -- Separate out the PAP that we are floating from the extra -- arguments, by traversing the spine until we have collected -- (n_val_args - arity) value arguments. @@ -466,19 +443,6 @@ | otherwise = left n f (a:rargs) left _ _ _ = panic "GHC.Core.Opt.SetLevels.lvlExpr.left" - is_val_arg :: CoreExprWithFVs -> Bool - is_val_arg (_, AnnType {}) = False - is_val_arg _ = True - - lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr) - lvl_arg strs arg | (str1 : strs') <- strs - , is_val_arg arg - = do { arg' <- lvlMFE env (isStrUsedDmd str1) arg - ; return (strs', arg') } - | otherwise - = do { arg' <- lvlMFE env False arg - ; return (strs, arg') } - lvlApp env _ (fun, args) = -- No PAPs that we can float: just carry on with the -- arguments and the function. @@ -499,7 +463,7 @@ , exprIsHNF (deTagExpr scrut') -- See Note [Check the output scrutinee for exprIsHNF] , not (isTopLvl dest_lvl) -- Can't have top-level cases , not (floatTopLvlOnly env) -- Can float anywhere - , Many <- idMult case_bndr -- See Note [Floating linear case] + , ManyTy <- idMult case_bndr -- See Note [Floating linear case] = -- Always float the case if possible -- Unlike lets we don't insist that it escapes a value lambda do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs) @@ -514,7 +478,7 @@ ; alts' <- mapM (lvl_alt alts_env) alts ; return (Case scrut' case_bndr' ty' alts') } where - ty' = substTy (le_subst env) ty + ty' = substTyUnchecked (le_subst env) ty incd_lvl = incMinorLvl (le_ctxt_lvl env) dest_lvl = maxFvLevel (const True) env scrut_fvs @@ -645,7 +609,7 @@ -- the expression, so that it can itself be floated. lvlMFE env _ (_, AnnType ty) - = return (Type (GHC.Core.Subst.substTy (le_subst env) ty)) + = return (Type (substTyUnchecked (le_subst env) ty)) -- No point in floating out an expression wrapped in a coercion or note -- If we do we'll transform lvl = e |> co @@ -682,9 +646,7 @@ -- 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 - (isJust mb_bot_str) - join_arity_maybe - ann_expr + is_bot_lam join_arity_maybe ann_expr -- Treat the expr just like a right-hand side ; var <- newLvlVar expr1 join_arity_maybe is_mk_static ; let var2 = annotateBotStr var float_n_lams mb_bot_str @@ -698,21 +660,20 @@ | escapes_value_lam , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions -- See Note [Test cheapness with exprOkForSpeculation] - , Just (tc, _) <- splitTyConApp_maybe expr_ty - , Just dc <- boxingDataCon_maybe tc - , let dc_res_ty = dataConOrigResTy dc -- No free type variables - [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty] + , BI_Box { bi_data_con = box_dc, bi_inst_con = boxing_expr + , bi_boxed_type = box_ty } <- boxingDataCon expr_ty + , let [bx_bndr, ubx_bndr] = mkTemplateLocals [box_ty, expr_ty] = do { expr1 <- lvlExpr rhs_env ann_expr ; let l1r = incMinorLvlFrom rhs_env float_rhs = mkLams abs_vars_w_lvls $ - Case expr1 (stayPut l1r ubx_bndr) dc_res_ty - [Alt DEFAULT [] (mkConApp dc [Var ubx_bndr])] + Case expr1 (stayPut l1r ubx_bndr) box_ty + [Alt DEFAULT [] (App boxing_expr (Var ubx_bndr))] ; var <- newLvlVar float_rhs Nothing is_mk_static ; let l1u = incMinorLvlFrom env use_expr = Case (mkVarApps (Var var) abs_vars) (stayPut l1u bx_bndr) expr_ty - [Alt (DataAlt dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)] + [Alt (DataAlt box_dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)] ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs) use_expr) } @@ -724,14 +685,16 @@ expr_ty = exprType expr fvs = freeVarsOf ann_expr fvs_ty = tyCoVarsOfType expr_ty - is_bot = isBottomThunk mb_bot_str + is_bot_lam = isJust mb_bot_str -- True of bottoming thunks too! is_function = isFunction ann_expr mb_bot_str = exprBotStrictness_maybe expr -- See Note [Bottoming floats] -- esp Bottoming floats (2) expr_ok_for_spec = exprOkForSpeculation expr - dest_lvl = destLevel env fvs fvs_ty is_function is_bot False - abs_vars = abstractVars dest_lvl env fvs + abs_vars = abstractVars dest_lvl env fvs + dest_lvl = destLevel env fvs fvs_ty is_function is_bot_lam False + -- NB: is_bot_lam not is_bot; see (3) in + -- Note [Bottoming floats] -- float_is_new_lam: the floated thing will be a new value lambda -- replacing, say (g (x+4)) by (lvl x). No work is saved, nor is @@ -763,7 +726,9 @@ -- See Note [Floating to the top] saves_alloc = isTopLvl dest_lvl && floatConsts env - && (not strict_ctxt || is_bot || exprIsHNF expr) + && ( not strict_ctxt -- (a) + || exprIsHNF expr -- (b) + || (is_bot_lam && escapes_value_lam)) -- (c) hasFreeJoin :: LevelEnv -> DVarSet -> Bool -- Has a free join point which is not being floated to top level. @@ -773,61 +738,72 @@ hasFreeJoin env fvs = not (maxFvLevel isJoinId env fvs == tOP_LEVEL) -isBottomThunk :: Maybe (Arity, s) -> Bool --- See Note [Bottoming floats] (2) -isBottomThunk (Just (0, _)) = True -- Zero arity -isBottomThunk _ = False - {- Note [Floating to the top] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are keen to float something to the top level, even if it does not -escape a value lambda (and hence save work), for two reasons: - - * 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. - - * (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. +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: -But do not so if: - - the context is a strict, and - - the expression is not a HNF, and - - the expression is not bottoming + (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. -Exammples: + (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. -* Bottoming - f x = case x of - 0 -> error - _ -> x+1 - Here we want to float (error ) to top level, abstracting - over 'x', so as to make f's RHS smaller. +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) -* HNF - f = case y of - True -> p:q - False -> blah - We may as well float the (p:q) so it becomes a static data structure. +Examples: -* Case scrutinee +* (a) Strict. Case scrutinee f = case g True of .... Don't float (g True) to top level; then we have the admin of a top-level thunk to worry about, with zero gain. -* Case alternative +* (a) Strict. Case alternative h = case y of True -> g True False -> False Don't float (g True) to the top level +* (b) HNF + f = case y of + True -> p:q + False -> blah + We may as well float the (p:q) so it becomes a static data structure. + +* (c) Bottoming expressions; see also Note [Bottoming floats] + f x = case x of + 0 -> error + _ -> x+1 + Here we want to float (error ) to top level, abstracting + over 'x', so as to make f's RHS smaller. + + But (#22494) if it's more like + foo = case error of { ... } + then there is no point in floating; we are never going to inline + 'foo' anyway. So float bottoming things only if they escape + a lambda. + * Arguments t = f (g True) - If f is lazy, we /do/ float (g True) because then we can allocate - the thunk statically rather than dynamically. But if f is strict - we don't (see the use of idDmdSig in lvlApp). It's not clear - if this test is worth the bother: it's only about CAFs! + Prior to Apr 22 we didn't float (g True) to the top if f was strict. + But (a) this only affected CAFs, because if it escapes a value lambda + we'll definitely float it; so the complication of working out + argument strictness doesn't seem worth it. + (b) floating to the top helps SpecContr; see GHC.Core.Opt.SpecConstr + Note [Specialising on dictionaries]. + So now we don't use strictness to affect argument floating. It's controlled by a flag (floatConsts), because doing this too early loses opportunities for RULES which (needless to say) are @@ -912,15 +888,15 @@ We don't want to float very cheap expressions by boxing and unboxing. But we use exprOkForSpeculation for the test, not exprIsCheap. Why? Because it's important /not/ to transform - f (a /# 3) + let x = a /# 3 to - f (case bx of I# a -> a /# 3) -and float bx = I# (a /# 3), because the application of f no -longer obeys the let/app invariant. But (a /# 3) is ok-for-spec + let x = case bx of I# a -> a /# 3 +because the let binding no +longer obeys the let-can-float invariant. But (a /# 3) is ok-for-spec due to a special hack that says division operators can't fail when the denominator is definitely non-zero. And yet that same expression says False to exprIsCheap. Simplest way to -guarantee the let/app invariant is to use the same function! +guarantee the let-can-float invariant is to use the same function! If an expression is okay for speculation, we could also float it out *without* boxing and unboxing, since evaluating it early is okay. @@ -947,7 +923,7 @@ (1) We want to float a bottoming expression even if it has free variables: f = \x. g (let v = h x in error ("urk" ++ v)) - Then we'd like to abstract over 'x' can float the whole arg of g: + Then we'd like to abstract over 'x', and float the whole arg of g: lvl = \x. let v = h x in error ("urk" ++ v) f = \x. g (lvl x) To achieve this we pass is_bot to destLevel @@ -956,6 +932,12 @@ bottom. Instead we treat the /body/ of such a function specially, via point (1). For example: f = \x. ....(\y z. if x then error y else error z).... + If we float the whole lambda thus + lvl = \x. \y z. if x then error y else error z + f = \x. ...(lvl x)... + we may well end up eta-expanding that PAP to + f = \x. ...(\y z. lvl x y z)... + ===> lvl = \x z y. if b then error y else error z f = \x. ...(\y z. lvl x z y)... @@ -966,7 +948,7 @@ Example: ... let { v = \y. error (show x ++ show y) } in ... We want to abstract over x and float the whole thing to top: - lvl = \xy. errror (show x ++ show y) + lvl = \xy. error (show x ++ show y) ...let {v = lvl x} in ... Then of course we don't want to separately float the body (error ...) @@ -997,16 +979,6 @@ thing is based on the cheap-and-cheerful exprIsDeadEnd, I'm not sure that it'll nail all such cases. -Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tiresomely, though, the simplifier has an invariant that the manifest -arity of the RHS should be the same as the arity; but we can't call -etaExpand during GHC.Core.Opt.SetLevels because it works over a decorated form of -CoreExpr. So we do the eta expansion later, in GHC.Core.Opt.FloatOut. -But we should only eta-expand if the RHS doesn't already have the right -exprArity, otherwise we get unnecessary top-level bindings if the RHS was -trivial after the next run of the Simplifier. - Note [Case MFEs] ~~~~~~~~~~~~~~~~ We don't float a case expression as an MFE from a strict context. Why not? @@ -1028,17 +1000,18 @@ -} -annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig) -> Id +annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig, CprSig) -> Id -- See Note [Bottoming floats] for why we want to add -- bottoming information right now -- -- n_extra are the number of extra value arguments added during floating -annotateBotStr id n_extra mb_str - = case mb_str of - Nothing -> id - Just (arity, sig) -> id `setIdArity` (arity + n_extra) - `setIdDmdSig` (prependArgsDmdSig n_extra sig) - `setIdCprSig` mkCprSig (arity + n_extra) botCpr +annotateBotStr id n_extra mb_bot_str + | Just (arity, str_sig, cpr_sig) <- mb_bot_str + = id `setIdArity` (arity + n_extra) + `setIdDmdSig` prependArgsDmdSig n_extra str_sig + `setIdCprSig` prependArgsCprSig n_extra cpr_sig + | otherwise + = id notWorthFloating :: CoreExpr -> [Var] -> Bool -- Returns True if the expression would be replaced by @@ -1147,7 +1120,7 @@ -- bit brutal, but unlifted bindings aren't expensive either = -- No float - do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs + do { rhs' <- lvlRhs env NonRecursive is_bot_lam mb_join_arity rhs ; let bind_lvl = incMinorLvl (le_ctxt_lvl env) (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr] ; return (NonRec bndr' rhs', env') } @@ -1156,7 +1129,7 @@ | null abs_vars = do { -- No type abstraction; clone existing binder rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive - is_bot mb_join_arity rhs + is_bot_lam mb_join_arity 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') } @@ -1164,7 +1137,7 @@ | otherwise = do { -- Yes, type abstraction; create a new binder, extend substitution, etc rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive - is_bot mb_join_arity rhs + is_bot_lam mb_join_arity 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') } @@ -1175,11 +1148,12 @@ 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 is_join + dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot_lam is_join deann_rhs = deAnnotate rhs mb_bot_str = exprBotStrictness_maybe deann_rhs - is_bot = isJust mb_bot_str + is_bot_lam = isJust mb_bot_str + -- is_bot_lam: looks like (\xy. bot), maybe zero lams -- NB: not isBottomThunk! See Note [Bottoming floats] point (3) n_extra = count isId abs_vars @@ -1281,7 +1255,7 @@ profitableFloat :: LevelEnv -> Level -> Bool profitableFloat env dest_lvl = (dest_lvl `ltMajLvl` le_ctxt_lvl env) -- Escapes a value lambda - || isTopLvl dest_lvl -- Going all the way to top level + || (isTopLvl dest_lvl && floatConsts env) -- Going all the way to top level ---------------------------------------------------- @@ -1403,9 +1377,11 @@ new_lvl | any is_major bndrs = incMajorLvl lvl | otherwise = incMinorLvl lvl - is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr) - -- The "probably" part says "don't float things out of a - -- probable one-shot lambda" + is_major bndr = not (isOneShotBndr bndr) + -- Only non-one-shot lambdas bump a major level, which in + -- turn triggers floating. NB: isOneShotBndr is always + -- true of a type variable -- there is no point in floating + -- out of a big lambda. -- See Note [Computing one-shot info] in GHC.Types.Demand lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar] @@ -1443,7 +1419,7 @@ -> TyCoVarSet -- Free in the /type/ of the term -- (a subset of the previous argument) -> Bool -- True <=> is function - -> Bool -- True <=> is bottom + -> 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 @@ -1460,7 +1436,7 @@ | is_bot -- Send bottoming bindings to the top = as_far_as_poss -- regardless; see Note [Bottoming floats] - -- Esp Bottoming floats (1) + -- Esp Bottoming floats (1) and (3) | Just n_args <- floatLams env , n_args > 0 -- n=0 case handled uniformly by the 'otherwise' case @@ -1593,7 +1569,7 @@ , le_subst = mkEmptySubst in_scope_toplvl , le_env = emptyVarEnv } where - in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds + in_scope_toplvl = emptyInScopeSet `extendInScopeSetBndrs` binds -- The Simplifier (see Note [Glomming] in GHC.Core.Opt.OccurAnal) and -- the specialiser (see Note [Top level scope] in GHC.Core.Opt.Specialise) -- may both produce top-level bindings where an early binding refers @@ -1629,7 +1605,9 @@ -> LevelEnv extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env }) case_bndr (Var scrut_var) - | Many <- varMult case_bndr + -- We could use OccurAnal. scrutBinderSwap_maybe 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 @@ -1733,10 +1711,10 @@ mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id transfer_join_info bndr $ - mkSysLocal (mkFastString str) uniq (idMult bndr) poly_ty + mkSysLocal str uniq (idMult bndr) poly_ty where - str = "poly_" ++ occNameString (getOccName bndr) - poly_ty = mkLamTypes abs_vars (GHC.Core.Subst.substTy subst (idType bndr)) + str = fsLit "poly_" `appendFS` occNameFS (getOccName bndr) + poly_ty = mkLamTypes abs_vars (substTyUnchecked subst (idType bndr)) -- If we are floating a join point to top level, it stops being -- a join point. Otherwise it continues to be a join point, @@ -1768,7 +1746,7 @@ = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr")) rhs_ty | otherwise - = mkSysLocal (mkFastString "lvl") uniq Many rhs_ty + = mkSysLocal (mkFastString "lvl") uniq ManyTy rhs_ty -- | Clone the binders bound by a single-alternative case. cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var]) 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 @@ -1,4317 +1,572 @@ -{- -(c) The AQUA Project, Glasgow University, 1993-1998 - -\section[Simplify]{The main module of the simplifier} --} - - -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-} -module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplImpRules ) where - -import GHC.Prelude - -import GHC.Platform - -import GHC.Driver.Session - -import GHC.Core -import GHC.Core.Opt.Simplify.Monad -import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) -import GHC.Core.Opt.Simplify.Env -import GHC.Core.Opt.Simplify.Utils -import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs ) -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.Monad ( Tick(..), SimplMode(..) ) -import GHC.Core.Ppr ( pprCoreExpr ) -import GHC.Core.Unfold -import GHC.Core.Unfold.Make -import GHC.Core.Utils -import GHC.Core.Opt.Arity ( ArityType(..) - , pushCoTyArg, pushCoValArg - , etaExpandAT ) -import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) -import GHC.Core.FVs ( mkRuleInfo ) -import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts ) -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.Cpr ( mkCprSig, botCpr ) -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, pprModuleName ) -import GHC.Utils.Misc -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Trace -import GHC.Utils.Monad ( mapAccumLM, liftIO ) -import GHC.Utils.Logger - -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 (which includes DynFlags for convenience) - - 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 env "SimplBindr:inline-uncond" (ppr old_bndr) $ - do { tick (PreInlineUnconditionally old_bndr) - ; return ( emptyFloats env, env' ) } - - | otherwise - = case bind_cxt of - BC_Join cont -> simplTrace env "SimplBind:join" (ppr old_bndr) $ - simplJoinBind env cont old_bndr new_bndr rhs env - - BC_Let top_lvl is_rec -> simplTrace env "SimplBind:normal" (ppr old_bndr) $ - simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env - -simplTrace :: SimplEnv -> String -> SDoc -> a -> a -simplTrace env herald doc thing_inside - | not (logHasDumpFlag logger Opt_D_verbose_core2core) - = thing_inside - | otherwise - = logTraceMsg logger herald doc thing_inside - where - logger = seLogger env - --------------------------- -simplLazyBind :: SimplEnv - -> TopLevelFlag -> RecFlag - -> InId -> OutId -- Binder, both pre-and post simpl - -- Not a JoinId - -- The OutId has IdInfo, 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/app invariant --- NOT used for JoinIds -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)) - ; (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 floats = foldl' extendFloats (emptyFloats env) poly_binds - ; return (floats, body3) } - - ; let env' = env `setInScopeFromF` rhs_floats - ; rhs' <- mkLam 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 - -> 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 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 cont) old_bndr new_bndr rhs' } - --------------------------- -simplNonRecX :: SimplEnv - -> InId -- Old binder; not a JoinId - -> OutExpr -- Simplified RHS - -> SimplM (SimplFloats, SimplEnv) --- A specialised variant of simplNonRec used when the RHS is already --- simplified, notably in knownCon. It uses case-binding where necessary. --- --- Precondition: rhs satisfies the let/app invariant - -simplNonRecX env bndr new_rhs - | assertPpr (not (isJoinId bndr)) (ppr bndr) $ - isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } - = return (emptyFloats env, env) -- Here c is dead, and we avoid - -- creating the binding c = (a,b) - - | Coercion co <- new_rhs - = return (emptyFloats env, extendCvSubst env bndr co) - - | exprIsTrivial new_rhs -- Short-cut for let x = y in ... - -- This case would ultimately land in postInlineUnconditionally - -- but it seems not uncommon, and avoids a lot of faff to do it here - = return (emptyFloats env - , extendIdSubst env bndr (DoneEx new_rhs Nothing)) - - | otherwise - = do { (env1, new_bndr) <- simplBinder env bndr - ; let is_strict = isStrictId new_bndr - -- isStrictId: use new_bndr 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 - new_bndr (emptyFloats env) new_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 (env1 `setInScopeFromF` rhs_floats) - (BC_Let NotTopLevel NonRecursive) - bndr new_bndr rhs1 - -- Must pass env1 to completeBind in case simplBinder had to clone, - -- and extended the substitution with [bndr :-> new_bndr] - - ; 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 rhs_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 Many rhs_ty worker_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 (sm_uf_opts mode) top_lvl InlineRhs 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 - mode = getMode env - occ_fs = getOccFS bndr - rhs_ty = coercionLKind co - info = idInfo bndr - - worker_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info - `setCprSigInfo` cprSigInfo info - `setDemandInfo` demandInfo info - `setInlinePragInfo` inlinePragInfo info - `setArityInfo` arityInfo info - -- 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 (sm_uf_opts mode) top_lvl InlineRhs work_id work_rhs - -tryCastWorkerWrapper env _ _ _ bndr rhs -- All other bindings - = return (mkFloatBind env (NonRec bndr rhs)) - -mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma --- See Note [Cast worker/wrapper] -mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) - = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag] - , 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 act = activateDuringFinal - | otherwise = 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 -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 - - -- Now ANF-ise the remaining rhs - ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl (getOccFS bndr) rhs1 - - -- Finally, decide whether or not to float - ; let all_floats = rhs_floats1 `addLetFloats` anf_floats - ; if doFloatFromRhs 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 :: 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 - = do { (_is_exp, floats, rhs1) <- go 0 rhs0 - ; return (floats, rhs1) } - where - go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr) - go n_val_args (Cast rhs co) - = do { (is_exp, floats, rhs') <- go n_val_args rhs - ; return (is_exp, floats, Cast rhs' co) } - go n_val_args (App fun (Type ty)) - = do { (is_exp, floats, rhs') <- go n_val_args fun - ; return (is_exp, floats, App rhs' (Type ty)) } - go n_val_args (App fun arg) - = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun - ; case is_exp of - False -> return (False, emptyLetFloats, App fun arg) - True -> do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg - ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } } - go n_val_args (Var fun) - = return (is_exp, emptyLetFloats, Var fun) - where - is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP - -- See Note [CONLIKE pragma] in GHC.Types.Basic - -- The definition of is_exp should match that in - -- 'GHC.Core.Opt.OccurAnal.occAnalApp' - - go n_val_args (Tick t rhs) - -- We want to be able to float bindings past this - -- tick. Non-scoping ticks don't care. - | tickishScoped t == NoScope - = do { (is_exp, floats, rhs') <- go n_val_args rhs - ; return (is_exp, 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 { (is_exp, floats, rhs') <- go n_val_args rhs - ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) - floats' = mapLetFloats floats tickIt - ; return (is_exp, floats', Tick t rhs') } - - go _ other - = return (False, emptyLetFloats, other) - -makeTrivialArg :: 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 :: SimplEnv -> TopLevelFlag -> Demand - -> FastString -- ^ A "friendly name" to build the new binder from - -> OutExpr -- ^ This expression satisfies the let/app invariant - -> 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 - = do { (floats, new_id) <- makeTrivialBinding env top_lvl occ_fs - id_info expr expr_ty - ; return (floats, Var new_id) } - where - id_info = vanillaIdInfo `setDemandInfo` dmd - expr_ty = exprType expr - -makeTrivialBinding :: SimplEnv -> TopLevelFlag - -> FastString -- ^ a "friendly name" to build the new binder from - -> IdInfo - -> OutExpr -- ^ This expression satisfies the let/app invariant - -> OutType -- Type of the expression - -> SimplM (LetFloats, OutId) -makeTrivialBinding env top_lvl occ_fs info expr expr_ty - = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr - ; uniq <- getUniqueM - ; let name = mkSystemVarName uniq occ_fs - var = mkLocalIdWithInfo name Many expr_ty info - - -- Now something very like completeBind, - -- but without the postInlineUnconditionally part - ; (arity_type, expr2) <- tryEtaExpandRhs env 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 (sm_uf_opts mode) top_lvl InlineRhs var expr2 - - ; let final_id = addLetBndrInfo var arity_type unf - bind = NonRec final_id expr2 - - ; return ( floats `addLetFlts` unitLetFloat bind, final_id ) } - where - mode = getMode 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/app 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 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 env "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 - AT oss div = new_arity_type - new_arity = length oss - - 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 | isDeadEndDiv div = info3 `setDmdSigInfo` bot_sig - `setCprSigInfo` bot_cpr - | otherwise = info3 - - bot_sig = mkClosedDmdSig (replicate new_arity topDmd) div - bot_cpr = mkCprSig new_arity botCpr - - -- 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 = \x. error (x ++ "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 RHS is bottom to x'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. - -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 (bndr', rhs') <- joinPointBinding_maybe bndr rhs - = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont - - | otherwise - = {-#SCC "simplNonRecE" #-} simplNonRecE env 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 { opts <- getOptCoercionOpts - ; let opt_co = optCoercion opts (getTCvSubst env) co - ; seqCo opt_co `seq` return opt_co } - ------------------------------------ --- | 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 } - -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr - -- expr satisfies let/app since it started life - -- in a call to simplNonRecE - ; (floats2, expr') <- simplLam env' body cont - ; return (floats1 `addFloats` floats2, expr') } - - 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} - -- See Note [Avoid redundant simplification] - -> do { (_, _, arg') <- simplArg env dup_flag se arg - ; rebuild env (App expr arg') cont } - -{- -************************************************************************ -* * -\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 NthCo 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 }) - | 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 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 -> StaticEnv -> CoreExpr - -> SimplM (DupFlag, StaticEnv, OutExpr) -simplArg env dup_flag arg_env arg - | isSimplified dup_flag - = return (dup_flag, arg_env, arg) - | otherwise - = do { let arg_env' = arg_env `setInScopeFromE` env - ; arg' <- simplExpr arg_env' arg - ; 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} -* * -************************************************************************ --} - -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 }) - | isSimplified dup -- Don't re-simplify if we've simplified it once - -- See Note [Avoiding exponential behaviour] - = do { tick (BetaReduction bndr) - ; (floats1, env') <- simplNonRecX env bndr arg - ; (floats2, expr') <- simplLam env' body cont - ; return (floats1 `addFloats` floats2, expr') } - - | otherwise - = do { tick (BetaReduction bndr) - ; simplNonRecE env 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 <- mkLam 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 - -> 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 --- * non-top-level non-recursive non-join-point lets in expressions --- * beta reduction --- --- simplNonRec 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 --- --- Precondition: rhs satisfies the let/app invariant --- Note [Core let/app invariant] in GHC.Core - -simplNonRecE env bndr (rhs, rhs_se) body cont - | assert (isId bndr && not (isJoinId bndr) ) True - , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se - = do { tick (PreInlineUnconditionally bndr) - ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ - simplLam env' body cont } - - | otherwise - = do { (env1, bndr1) <- simplNonRecBndr env bndr - - -- Deal with strict bindings - -- See Note [Dark corner with representation polymorphism] - ; if isStrictId bndr1 && sm_case_case (getMode env) - then simplExprF (rhs_se `setInScopeFromE` env) rhs - (StrictBind { sc_bndr = bndr, sc_body = body - , sc_env = env, sc_cont = cont, sc_dup = NoDup }) - - -- Deal with lazy bindings - else do - { (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) - ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se - ; (floats2, expr') <- simplLam env3 body cont - ; return (floats1 `addFloats` floats2, expr') } } - ------------------- -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 `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 the re-simplify it -- and then this happens in a -deeply-nested way. So we must be jolly careful about re-simplifying -an expression. 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 ) True - , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env - = do { tick (PreInlineUnconditionally bndr) - ; simplExprF env' body cont } - - | otherwise - = 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 cont) - ; (floats1, env3) <- simplJoinBind env2 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 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 (sm_case_case (getMode 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 -> 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 -* * -************************************************************************ --} - -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 - = case substId env var of - ContEx tvs cvs ids e -> - let env' = setSubstEnv env tvs cvs ids - in simplExprF env' e cont - -- Don't trim; haven't already simplified e, - -- so the cont is not embodied in e - - DoneId var1 -> - let cont' = trimJoinCont var (isJoinId_maybe var1) cont - in completeCall env var1 cont' - - DoneEx e mb_join -> - let env' = zapSubstEnv env - cont' = trimJoinCont var mb_join cont - in simplExprF env' e cont' - -- Note [zapSubstEnv] - -- ~~~~~~~~~~~~~~~~~~ - -- The template is already simplified, so don't re-substitute. - -- 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!! - ---------------------------------------------------------- --- Dealing with a call site - -completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) -completeCall env var cont - | Just expr <- callSiteInline logger uf_opts case_depth var active_unf - lone_variable arg_infos interesting_cont - -- Inline the variable's RHS - = do { checkedTick (UnfoldingDone var) - ; dump_inline expr cont - ; let env1 = zapSubstEnv env - ; simplExprF env1 expr cont } - - | otherwise - -- Don't inline; instead rebuild the call - = do { rule_base <- getSimplRules - ; let rules = getRules rule_base var - info = mkArgInfo env var rules - n_val_args call_cont - ; rebuildCall env info cont } - - where - uf_opts = seUnfoldingOpts env - case_depth = seCaseDepth env - logger = seLogger env - (lone_variable, arg_infos, call_cont) = contArgs cont - n_val_args = length arg_infos - interesting_cont = interestingCallContext env call_cont - active_unf = activeUnfolding (getMode 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])] - -rebuildCall :: SimplEnv - -> ArgInfo - -> SimplCont - -> SimplM (SimplFloats, OutExpr) --- We decided not to inline, so --- - simplify the arguments --- - try rewrite rules --- - and rebuild - ----------- 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 rewrite RULES -------------- --- See Note [Trying rewrite rules] -rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args - , ai_rules = Just (nr_wanted, rules) }) cont - | nr_wanted == 0 || no_more_args - , let info' = info { ai_rules = Nothing } - = -- 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' cont } - where - no_more_args = case cont of - ApplyToTy {} -> False - ApplyToVal {} -> False - _ -> True - - ----------- Simplify 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 {}, TyArg {} ] <- rev_args - -- Do this even if (contIsStop cont) - -- See Note [No eta-expansion in runRW#] - = do { let arg_env = arg_se `setInScopeFromE` env - ty' = contResultType cont - - -- 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. - ; arg' <- case arg of - Lam s body -> do { (env', s') <- simplBinder arg_env s - ; body' <- simplExprC env' body 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") Many 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 = cont - , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' } - -- cont' applies to s', then K - ; body' <- simplExprC env' arg cont' - ; return (Lam s' body') } - - ; let rr' = getRuntimeRep ty' - call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg'] - ; return (emptyFloats env, call') } - -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 - , sm_case_case (getMode env) - = -- 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 (lazyArgContext 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 - -{- 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 [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] - -> 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 dflags (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 (getMode env)) fn - (argInfoAppArgs args) rules - -- Fire a rule for the function - = do { 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 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 { nodump -- This ensures that an empty file is written - ; return Nothing } - - where - ropts = initRuleOpts dflags - dflags = seDynFlags env - logger = seLogger env - zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] - - printRuleModule rule - = parens (maybe (text "BUILTIN") - (pprModuleName . moduleName) - (ruleModule rule)) - - dump 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 - | 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 - = 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. - -Possible improvement: occ-anal the rules when putting them in the -database; and in the simplifier just occ-anal the OutExpr arguments. -But that's more complicated and the rule RHS is usually tiny; so I'm -just doing the simple thing. - -Historical note: previously we did occ-anal the rules in Rule.hs, -but failed to occ-anal the OutExpr arguments, which led to the -nasty performance problem described above. - - -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/app 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 of an eval'd function] 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') <- simplNonRecX env case_bndr case_bndr_rhs - -- scrut is a constructor application, - -- hence satisfies let/app 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') <- simplNonRecX 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 (idType case_bndr) - -- OK to call isUnliftedType: scrutinees always have a fixed RuntimeRep (see FRRCase) - = 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 (sm_case_case (getMode env)) - = 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 <- getFamEnvs - ; (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 (seDynFlags 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") Many 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 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 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 | Many <- idMult case_bndr = case scrut of - Just (Var v) -> addBinderUnfolding env1 v con_app_unf - Just (Cast (Var v) co) -> addBinderUnfolding env1 v $ - mk_simple_unf (Cast con_app (mkSymCo co)) - _ -> env1 - | otherwise = env1 - - ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr 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/app invariant. Example - case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in .... - ; K -> blah } - -The let/app 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. - -Exactly the same issue arises in GHC.Core.Opt.SpecConstr; -see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr - -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, the same caveat as in -Note [Suppressing binder-swaps on linear case] in OccurAnal apply. - - -************************************************************************ -* * -\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 - -- Note that the binder might be "dead", because it doesn't - -- occur in the RHS; and simplNonRecX may therefore discard - -- it via postInlineUnconditionally. - -- 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) <- simplNonRecX env' b' arg -- arg satisfies let/app 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 - ; simplNonRecX 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) - -{- -************************************************************************ -* * -\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_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) <- simplLam sb_env1 body cont - -- No need to use mkDupableCont before simplLam; 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 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 - - ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags 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 - | 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 - -- 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 = Nothing, 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) InlineRhs 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 {} -> -- Binder is not a join point - do { expr' <- simplExprC unf_env expr (mkBoringStop rhs_ty) - ; return (eta_expand expr') } - ; case guide of - UnfWhen { ug_arity = arity - , ug_unsat_ok = sat_ok - , ug_boring_ok = boring_ok - } - -- Happens for INLINE things - -- Really important to force new_boring_ok as otherwise - -- `ug_boring_ok` is a thunk chain of - -- inlineBoringExprOk expr0 - -- || inlineBoringExprOk expr1 || ... - -- See #20134 - -> let !new_boring_ok = boring_ok || inlineBoringOk expr' - guide' = - UnfWhen { ug_arity = arity - , ug_unsat_ok = sat_ok - , 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] - eta_expand expr - | not eta_on = expr - | exprIsTrivial expr = expr - | otherwise = etaExpandAT (getInScope env) id_arity expr - eta_on = sm_eta_expand (getMode env) - -{- 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 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 [Do not eta-expand trivial expressions] - 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] - 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) ] - - ; args' <- mapM (simplExpr lhs_env) args - ; rhs' <- simplExprC rhs_env rhs rhs_cont - ; return (rule { ru_bndrs = bndrs' - , ru_fn = fn_name' - , ru_args = args' - , ru_rhs = occurAnalyseExpr rhs' }) } - -- Remember to occ-analyse, to drop dead code. - -- See Note [OccInfo in unfoldings and rules] in GHC.Core - -{- Note [Simplifying the RHS of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We can simplify the RHS of a RULE much as we do the RHS of a stable -unfolding. We used to use the much more conservative updModeForRules -for the RHS as well as the LHS, but that seems more conservative -than necesary. Allowing some inlining might, for example, eliminate -a binding. --} - - +{-# LANGUAGE CPP #-} + +module GHC.Core.Opt.Simplify + ( SimplifyExprOpts(..), SimplifyOpts(..) + , simplifyExpr, simplifyPgm + ) where + +import GHC.Prelude + +import GHC.Driver.Flags + +import GHC.Core +import GHC.Core.Rules +import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) +import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) +import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) +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.Env +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Opt.Stats ( simplCountN ) +import GHC.Core.FamInstEnv + +import GHC.Utils.Error ( withTiming ) +import GHC.Utils.Logger as Logger +import GHC.Utils.Outputable +import GHC.Utils.Constants (debugIsOn) + +import GHC.Unit.Env ( UnitEnv, ueEPS ) +import GHC.Unit.External +import GHC.Unit.Module.ModGuts + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Basic +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Tickish +import GHC.Types.Unique.FM + +import Control.Monad +import Data.Foldable ( for_ ) + +#if __GLASGOW_HASKELL__ <= 810 +import GHC.Utils.Panic ( panic ) +#endif + +{- +************************************************************************ +* * + Gentle simplification +* * +************************************************************************ +-} + +-- | Configuration record for `simplifyExpr`. +-- The values of this datatype are /only/ driven by the demands of that function. +data SimplifyExprOpts = SimplifyExprOpts + { se_fam_inst :: ![FamInst] + , se_mode :: !SimplMode + , se_top_env_cfg :: !TopEnvConfig + } + +simplifyExpr :: Logger + -> ExternalUnitCache + -> SimplifyExprOpts + -> CoreExpr + -> IO CoreExpr +-- simplifyExpr is called by the driver to simplify an +-- expression typed in at the interactive prompt +simplifyExpr logger euc opts expr + = withTiming logger (text "Simplify [expr]") (const ()) $ + do { eps <- eucEPS euc ; + ; let fam_envs = ( eps_fam_inst_env eps + , extendFamInstEnvList emptyFamInstEnv $ se_fam_inst opts + ) + simpl_env = mkSimplEnv (se_mode opts) fam_envs + top_env_cfg = se_top_env_cfg opts + read_eps_rules = eps_rule_base <$> eucEPS euc + read_ruleenv = updExternalPackageRules emptyRuleEnv <$> read_eps_rules + + ; let sz = exprSize expr + + ; (expr', counts) <- initSmpl logger read_ruleenv top_env_cfg sz $ + simplExprGently simpl_env expr + + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats + "Simplifier statistics" FormatText (pprSimplCount counts) + + ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression" + FormatCore + (pprCoreExpr expr') + + ; return expr' + } + +simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr +-- Simplifies an expression +-- does occurrence analysis, then simplification +-- and repeats (twice currently) because one pass +-- alone leaves tons of crud. +-- Used (a) for user expressions typed in at the interactive prompt +-- (b) the LHS and RHS of a RULE +-- (c) Template Haskell splices +-- +-- The name 'Gently' suggests that the SimplMode is InitialPhase, +-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't +-- enforce that; it just simplifies the expression twice + +-- It's important that simplExprGently does eta reduction; see +-- Note [Simplify rule LHS] above. The +-- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam) +-- but only if -O is on. + +simplExprGently env expr = do + expr1 <- simplExpr env (occurAnalyseExpr expr) + simplExpr env (occurAnalyseExpr expr1) + +{- +************************************************************************ +* * +\subsection{The driver for the simplifier} +* * +************************************************************************ +-} + +-- | Configuration record for `simplifyPgm`. +-- The values of this datatype are /only/ driven by the demands of that function. +data SimplifyOpts = SimplifyOpts + { so_dump_core_sizes :: !Bool + , so_iterations :: !Int + , so_mode :: !SimplMode + + , so_pass_result_cfg :: !(Maybe LintPassResultConfig) + -- Nothing => Do not Lint + -- Just cfg => Lint like this + + , so_hpt_rules :: !RuleBase + , so_top_env_cfg :: !TopEnvConfig + } + +simplifyPgm :: Logger + -> UnitEnv + -> NamePprCtx -- For dumping + -> SimplifyOpts + -> ModGuts + -> IO (SimplCount, ModGuts) -- New bindings + +simplifyPgm logger unit_env name_ppr_ctx opts + guts@(ModGuts { mg_module = this_mod + , mg_binds = binds, mg_rules = local_rules + , mg_fam_inst_env = fam_inst_env }) + = do { (termination_msg, it_count, counts_out, guts') + <- do_iteration 1 [] binds local_rules + + ; when (logHasDumpFlag logger Opt_D_verbose_core2core + && logHasDumpFlag logger Opt_D_dump_simpl_stats) $ + logDumpMsg logger + "Simplifier statistics for following pass" + (vcat [text termination_msg <+> text "after" <+> ppr it_count + <+> text "iterations", + blankLine, + pprSimplCount counts_out]) + + ; return (counts_out, guts') + } + where + dump_core_sizes = so_dump_core_sizes opts + mode = so_mode opts + max_iterations = so_iterations opts + top_env_cfg = so_top_env_cfg opts + active_rule = activeRule mode + active_unf = activeUnfolding mode + -- Note the bang in !guts_no_binds. If you don't force `guts_no_binds` + -- the old bindings are retained until the end of all simplifier iterations + !guts_no_binds = guts { mg_binds = [], mg_rules = [] } + + hpt_rule_env :: RuleEnv + hpt_rule_env = mkRuleEnv guts emptyRuleBase (so_hpt_rules opts) + -- emptyRuleBase: no EPS rules yet; we will update + -- them on each iteration to pick up the most up to date set + + do_iteration :: Int -- Counts iterations + -> [SimplCount] -- Counts from earlier iterations, reversed + -> CoreProgram -- Bindings + -> [CoreRule] -- Local rules for imported Ids + -> IO (String, Int, SimplCount, ModGuts) + + do_iteration iteration_no counts_so_far binds local_rules + -- iteration_no is the number of the iteration we are + -- about to begin, with '1' for the first + | iteration_no > max_iterations -- Stop if we've run out of iterations + = warnPprTrace (debugIsOn && (max_iterations > 2)) + "Simplifier bailing out" + ( hang (ppr this_mod <> text ", after" + <+> int max_iterations <+> text "iterations" + <+> (brackets $ hsep $ punctuate comma $ + map (int . simplCountN) (reverse counts_so_far))) + 2 (text "Size =" <+> ppr (coreBindsStats binds))) $ + + -- Subtract 1 from iteration_no to get the + -- number of iterations we actually completed + return ( "Simplifier baled out", iteration_no - 1 + , totalise counts_so_far + , guts_no_binds { mg_binds = binds, mg_rules = local_rules } ) + + -- Try and force thunks off the binds; significantly reduces + -- space usage, especially with -O. JRS, 000620. + | let sz = coreBindsSize binds + , () <- sz `seq` () -- Force it + = do { + -- Occurrence analysis + let { tagged_binds = {-# SCC "OccAnal" #-} + occurAnalysePgm this_mod active_unf active_rule + local_rules binds + } ; + Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" + FormatCore + (pprCoreBindings tagged_binds); + + -- read_eps_rules: + -- We need to read rules from the EPS regularly because simplification can + -- poke on IdInfo thunks, which in turn brings in new rules + -- behind the scenes. Otherwise there's a danger we'll simply + -- miss the rules for Ids hidden inside imported inlinings + -- Hence just before attempting to match a rule we read the EPS + -- value (via read_rule_env) and then combine it with the existing rule base. + -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`. + eps <- ueEPS unit_env ; + let { -- base_rule_env contains + -- (a) home package rules, fixed across all iterations + -- (b) local rules (substituted) from `local_rules` arg to do_iteration + -- Forcing base_rule_env to avoid unnecessary allocations. + -- Not doing so results in +25.6% allocations of LargeRecord. + ; !base_rule_env = updLocalRules hpt_rule_env local_rules + + ; read_eps_rules :: IO PackageRuleBase + ; read_eps_rules = eps_rule_base <$> ueEPS unit_env + + ; read_rule_env :: IO RuleEnv + ; read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules + + ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) + ; simpl_env = mkSimplEnv mode fam_envs } ; + + -- Simplify the program + ((binds1, rules1), counts1) <- + initSmpl logger read_rule_env top_env_cfg sz $ + do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} + simplTopBinds simpl_env tagged_binds + + -- Apply the substitution to rules defined in this module + -- for imported Ids. Eg RULE map my_f = blah + -- If we have a substitution my_f :-> other_f, we'd better + -- apply it to the rule to, or it'll never match + ; rules1 <- simplImpRules env1 local_rules + + ; return (getTopFloatBinds floats, rules1) } ; + + -- Stop if nothing happened; don't dump output + -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Stats + if isZeroSimplCount counts1 then + return ( "Simplifier reached fixed point", iteration_no + , totalise (counts1 : counts_so_far) -- Include "free" ticks + , guts_no_binds { mg_binds = binds1, mg_rules = rules1 } ) + else do { + -- Short out indirections + -- We do this *after* at least one run of the simplifier + -- because indirection-shorting uses the export flag on *occurrences* + -- and that isn't guaranteed to be ok until after the first run propagates + -- stuff from the binding site to its occurrences + -- + -- ToDo: alas, this means that indirection-shorting does not happen at all + -- if the simplifier does nothing (not common, I know, but unsavoury) + let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; + + -- Dump the result of this iteration + dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts1 binds2 rules1 ; + + for_ (so_pass_result_cfg opts) $ \pass_result_cfg -> + lintPassResult logger pass_result_cfg binds2 ; + + -- 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 + totalise = foldr (\c acc -> acc `plusSimplCount` c) + (zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats) + +dump_end_iteration :: Logger -> Bool -> NamePprCtx -> Int + -> SimplCount -> CoreProgram -> [CoreRule] -> IO () +dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts binds rules + = dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr pp_counts binds rules + where + mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations + | otherwise = Nothing + -- Show details if Opt_D_dump_simpl_iterations is on + + hdr = "Simplifier iteration=" ++ show iteration_no + pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr + , pprSimplCount counts + , text "---- End of simplifier counts for" <+> text hdr ] + +{- +************************************************************************ +* * + Shorting out indirections +* * +************************************************************************ + +If we have this: + + x_local = + ...bindings... + x_exported = x_local + +where x_exported is exported, and x_local is not, then we replace it with this: + + x_exported = + x_local = x_exported + ...bindings... + +Without this we never get rid of the x_exported = x_local thing. This +save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and +makes strictness information propagate better. This used to happen in +the final phase, but it's tidier to do it here. + +Note [Messing up the exported Id's RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must be careful about discarding (obviously) or even merging the +RULES on the exported Id. The example that went bad on me at one stage +was this one: + + iterate :: (a -> a) -> a -> [a] + [Exported] + iterate = iterateList + + iterateFB c f x = x `c` iterateFB c f (f x) + iterateList f x = x : iterateList f (f x) + [Not exported] + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterateList + #-} + +This got shorted out to: + + iterateList :: (a -> a) -> a -> [a] + iterateList = iterate + + iterateFB c f x = x `c` iterateFB c f (f x) + iterate f x = x : iterate f (f x) + + {-# RULES + "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) + "iterateFB" iterateFB (:) = iterate + #-} + +And now we get an infinite loop in the rule system + iterate f x -> build (\cn -> iterateFB c f x) + -> iterateFB (:) f x + -> iterate f x + +Old "solution": + use rule switching-off pragmas to get rid + of iterateList in the first place + +But in principle the user *might* want rules that only apply to the Id +they say. And inline pragmas are similar + {-# NOINLINE f #-} + f = local + local = +Then we do not want to get rid of the NOINLINE. + +Hence hasShortableIdinfo. + + +Note [Rules and indirection-zapping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: what if x_exported has a RULE that mentions something in ...bindings...? +Then the things mentioned can be out of scope! Solution + a) Make sure that in this pass the usage-info from x_exported is + available for ...bindings... + b) If there are any such RULES, rec-ify the entire top-level. + It'll get sorted out next time round + +Other remarks +~~~~~~~~~~~~~ +If more than one exported thing is equal to a local thing (i.e., the +local thing really is shared), then we do one only: +\begin{verbatim} + x_local = .... + x_exported1 = x_local + x_exported2 = x_local +==> + x_exported1 = .... + + x_exported2 = x_exported1 +\end{verbatim} + +We rely on prior eta reduction to simplify things like +\begin{verbatim} + x_exported = /\ tyvars -> x_local tyvars +==> + x_exported = x_local +\end{verbatim} +Hence,there's a possibility of leaving unchanged something like this: +\begin{verbatim} + x_local = .... + x_exported1 = x_local Int +\end{verbatim} +By the time we've thrown away the types in STG land this +could be eliminated. But I don't think it's very common +and it's dangerous to do this fiddling in STG land +because we might eliminate a binding that's mentioned in the +unfolding for something. + +Note [Indirection zapping and ticks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unfortunately this is another place where we need a special case for +ticks. The following happens quite regularly: + + x_local = + x_exported = tick x_local + +Which we want to become: + + x_exported = tick + +As it makes no sense to keep the tick and the expression on separate +bindings. Note however that this might increase the ticks scoping +over the execution of x_local, so we can only do this for floatable +ticks. More often than not, other references will be unfoldings of +x_exported, and therefore carry the tick anyway. +-} + +type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks + +shortOutIndirections :: CoreProgram -> CoreProgram +shortOutIndirections binds + | isEmptyVarEnv ind_env = binds + | no_need_to_flatten = binds' -- See Note [Rules and indirection-zapping] + | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff + where + ind_env = makeIndEnv binds + -- These exported Ids are the subjects of the indirection-elimination + exp_ids = map fst $ nonDetEltsUFM ind_env + -- It's OK to use nonDetEltsUFM here because we forget the ordering + -- by immediately converting to a set or check if all the elements + -- satisfy a predicate. + exp_id_set = mkVarSet exp_ids + no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids + binds' = concatMap zap binds + + zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] + zap (Rec pairs) = [Rec (concatMap zapPair pairs)] + + zapPair (bndr, rhs) + | bndr `elemVarSet` exp_id_set + = [] -- Kill the exported-id binding + + | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr + , (exp_id', lcl_id') <- transferIdInfo exp_id bndr + = -- Turn a local-id binding into two bindings + -- exp_id = rhs; lcl_id = exp_id + [ (exp_id', mkTicks ticks rhs), + (lcl_id', Var exp_id') ] + + | otherwise + = [(bndr,rhs)] + +makeIndEnv :: [CoreBind] -> IndEnv +makeIndEnv binds + = foldl' add_bind emptyVarEnv binds + where + add_bind :: IndEnv -> CoreBind -> IndEnv + add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs) + add_bind env (Rec pairs) = foldl' add_pair env pairs + + add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv + add_pair env (exported_id, exported) + | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported + , shortMeOut env exported_id local_id + = extendVarEnv env local_id (exported_id, ticks) + add_pair env _ = env + +shortMeOut :: IndEnv -> Id -> Id -> Bool +shortMeOut ind_env exported_id local_id +-- The if-then-else stuff is just so I can get a pprTrace to see +-- how often I don't get shorting out because of IdInfo stuff + = if isExportedId exported_id && -- Only if this is exported + + isLocalId local_id && -- Only if this one is defined in this + -- module, so that we *can* change its + -- binding to be the exported thing! + + not (isExportedId local_id) && -- Only if this one is not itself exported, + -- since the transformation will nuke it + + not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for + then + if hasShortableIdInfo exported_id + then True -- See Note [Messing up the exported Id's RULES] + else warnPprTrace True "Not shorting out" (ppr exported_id) False + else + False + +hasShortableIdInfo :: Id -> Bool +-- True if there is no user-attached IdInfo on exported_id, +-- so we can safely discard it +-- See Note [Messing up the exported Id's RULES] +hasShortableIdInfo id + = isEmptyRuleInfo (ruleInfo info) + && isDefaultInlinePragma (inlinePragInfo info) + && not (isStableUnfolding (realUnfoldingInfo info)) + where + info = idInfo id + +{- Note [Transferring IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + lcl_id = e; exp_id = lcl_id + +and lcl_id has useful IdInfo, we don't want to discard it by going + gbl_id = e; lcl_id = gbl_id + +Instead, transfer IdInfo from lcl_id to exp_id, specifically +* (Stable) unfolding +* Strictness +* Rules +* Inline pragma + +Overwriting, rather than merging, seems to work ok. + +For the lcl_id we + +* Zap the InlinePragma. It might originally have had a NOINLINE, which + we have now transferred; and we really want the lcl_id to inline now + that its RHS is trivial! + +* Zap any Stable unfolding. agian, we want lcl_id = gbl_id to inline, + replacing lcl_id by gbl_id. That won't happen if lcl_id has its original + great big Stable unfolding +-} + +transferIdInfo :: Id -> Id -> (Id, Id) +-- See Note [Transferring IdInfo] +transferIdInfo exported_id local_id + = ( modifyIdInfo transfer exported_id + , modifyIdInfo zap_info local_id ) + where + local_info = idInfo local_id + transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info + `setCprSigInfo` cprSigInfo local_info + `setUnfoldingInfo` realUnfoldingInfo local_info + `setInlinePragInfo` inlinePragInfo local_info + `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info + new_info = setRuleInfoHead (idName exported_id) + (ruleInfo local_info) + -- Remember to set the function-name field of the + -- rules as we transfer them from one function to another + + zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma + `setUnfoldingInfo` noUnfolding 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,10 +8,15 @@ module GHC.Core.Opt.Simplify.Env ( -- * The simplifier mode - setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, seLogger, + SimplMode(..), updMode, + smPedanticBottoms, smPlatform, -- * Environments SimplEnv(..), pprSimplEnv, -- Temp not abstract + seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle, + seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames, + seOptCoercionOpts, sePedanticBottoms, sePhase, sePlatform, sePreInline, + seRuleOpts, seRules, seUnfoldingOpts, mkSimplEnv, extendIdSubst, extendTvSubst, extendCvSubst, zapSubstEnv, setSubstEnv, bumpCaseDepth, @@ -20,22 +25,23 @@ getSimplRules, enterRecGroupRHSs, -- * Substitution results - SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope, + SimplSR(..), mkContEx, substId, lookupRecBndr, -- * Simplifying 'Id' binders simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, simplBinder, simplBinders, - substTy, substTyVar, getTCvSubst, + substTy, substTyVar, getSubst, substCo, substCoVar, -- * Floats SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats, mkFloatBind, addLetFloats, addJoinFloats, addFloats, extendFloats, wrapFloats, + isEmptyJoinFloats, isEmptyLetFloats, doFloatFromRhs, getTopFloatBinds, -- * LetFloats - LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat, + LetFloats, FloatEnable(..), letFloatBinds, emptyLetFloats, unitLetFloat, addLetFlts, mapLetFloats, -- * JoinFloats @@ -45,36 +51,39 @@ import GHC.Prelude +import GHC.Core.Coercion.Opt ( OptCoercionOpts ) +import GHC.Core.FamInstEnv ( FamInstEnv ) +import GHC.Core.Opt.Arity ( ArityOpts(..) ) import GHC.Core.Opt.Simplify.Monad -import GHC.Core.Opt.Monad ( SimplMode(..) ) +import GHC.Core.Rules.Config ( RuleOpts(..) ) import GHC.Core import GHC.Core.Utils import GHC.Core.Multiplicity ( scaleScaled ) import GHC.Core.Unfold +import GHC.Core.TyCo.Subst (emptyIdSubstEnv) import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Data.OrdList import GHC.Data.Graph.UnVar import GHC.Types.Id as Id -import GHC.Core.Make ( mkWildValBinder ) -import GHC.Driver.Session ( DynFlags ) +import GHC.Core.Make ( mkWildValBinder, mkCoreLet ) import GHC.Builtin.Types -import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) import qualified GHC.Core.Type as Type -import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst ) +import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, substCo + , extendTvSubst, extendCvSubst ) import qualified GHC.Core.Coercion as Coercion import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) +import GHC.Platform ( Platform ) import GHC.Types.Basic import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Misc -import GHC.Utils.Logger import GHC.Types.Unique.FM ( pprUniqFM ) -import Data.List (mapAccumL) +import Data.List ( intersperse, mapAccumL ) {- ************************************************************************ @@ -84,13 +93,75 @@ ************************************************************************ -} +{- +Note [The environments of the Simplify pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions of the Simplify pass draw their contextual data from two +environments: `SimplEnv`, which is passed to the functions as an argument, and +`SimplTopEnv`, which is part of the `SimplM` monad. For both environments exist +corresponding configuration records `SimplMode` and `TopEnvConfig` respectively. +A configuration record denotes a unary datatype bundeling the various options +and switches we provide to control the behaviour of the respective part of the +Simplify pass. The value is provided by the driver using the functions found in +the GHC.Driver.Config.Core.Opt.Simplify module. + +These configuration records are part in the environment to avoid needless +copying of their values. This raises the question which data value goes in which +of the four datatypes. For each value needed by the pass we ask the following +two questions: + + * Does the value only make sense in a monadic environment? + + * Is it part of the configuration of the pass and provided by the user or is it + it an internal value? + +Examples of values that make only sense in conjunction with `SimplM` are the +logger and the values related to counting. As it does not make sense to use them +in a pure function (the logger needs IO and counting needs access to the +accumulated counts in the monad) we want these to live in `SimplTopEnv`. +Other values, like the switches controlling the behaviour of the pass (e.g. +whether to do case merging or not) are perfectly usable in a non-monadic setting. +Indeed many of those are used in guard expressions and it would be cumbersome to +query them from the monadic environment and feed them to the pure functions as +an argument. Hence we conveniently store them in the `SpecEnv` environment which +can be passed to pure functions as a whole. + +Now that we know in which of the two environments a particular value lives we +turn to the second question to determine if the value is part of the +configuration record embedded in the environment or if it is stored in an own +field in the environment type. Some values like the tick factor must be provided +from outside as we can neither derive it from other values provided to us nor +does a constant value make sense. Other values like the maximal number of ticks +are computed on environment initialization and we wish not to expose the field +to the "user" or the pass -- it is an internal value. Therefore the distinction +here is between "freely set by the caller" and "internally managed by the pass". + +Note that it doesn't matter for the decision procedure wheter a value is altered +throughout an iteration of the Simplify pass: The fields sm_phase, sm_inline, +sm_rules, sm_cast_swizzle and sm_eta_expand are updated locally (See the +definitions of `updModeForStableUnfoldings` and `updModeForRules` in +GHC.Core.Opt.Simplify.Utils) but they are still part of `SimplMode` as the +caller of the Simplify pass needs to provide the initial values for those fields. + +The decision which value goes into which datatype can be summarized by the +following table: + | Usable in a | + | pure setting | monadic setting | + |----------------------------|--------------|-----------------| + | Set by user | SimplMode | TopEnvConfig | + | Computed on initialization | SimplEnv | SimplTopEnv | + +-} + data SimplEnv = SimplEnv { ----------- Static part of the environment ----------- -- Static in the sense of lexically scoped, -- wrt the original expression + -- See Note [The environments of the Simplify pass] seMode :: !SimplMode + , seFamEnvs :: !(FamInstEnv, FamInstEnv) -- The current substitution , seTvSubst :: TvSubstEnv -- InTyVar |--> OutType @@ -112,6 +183,137 @@ , seCaseDepth :: !Int -- Depth of multi-branch case alternatives } +seArityOpts :: SimplEnv -> ArityOpts +seArityOpts env = sm_arity_opts (seMode env) + +seCaseCase :: SimplEnv -> Bool +seCaseCase env = sm_case_case (seMode env) + +seCaseFolding :: SimplEnv -> Bool +seCaseFolding env = sm_case_folding (seMode env) + +seCaseMerge :: SimplEnv -> Bool +seCaseMerge env = sm_case_merge (seMode env) + +seCastSwizzle :: SimplEnv -> Bool +seCastSwizzle env = sm_cast_swizzle (seMode env) + +seDoEtaReduction :: SimplEnv -> Bool +seDoEtaReduction env = sm_do_eta_reduction (seMode env) + +seEtaExpand :: SimplEnv -> Bool +seEtaExpand env = sm_eta_expand (seMode env) + +seFloatEnable :: SimplEnv -> FloatEnable +seFloatEnable env = sm_float_enable (seMode env) + +seInline :: SimplEnv -> Bool +seInline env = sm_inline (seMode env) + +seNames :: SimplEnv -> [String] +seNames env = sm_names (seMode env) + +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) + +sePlatform :: SimplEnv -> Platform +sePlatform env = smPlatform (seMode env) + +sePreInline :: SimplEnv -> Bool +sePreInline env = sm_pre_inline (seMode env) + +seRuleOpts :: SimplEnv -> RuleOpts +seRuleOpts env = sm_rule_opts (seMode env) + +seRules :: SimplEnv -> Bool +seRules env = sm_rules (seMode env) + +seUnfoldingOpts :: SimplEnv -> UnfoldingOpts +seUnfoldingOpts env = sm_uf_opts (seMode env) + +-- See Note [The environments of the Simplify pass] +data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad + { sm_phase :: !CompilerPhase + , sm_names :: ![String] -- ^ Name(s) of the phase + , sm_rules :: !Bool -- ^ Whether RULES are enabled + , sm_inline :: !Bool -- ^ Whether inlining is enabled + , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled + , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas? + , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options + , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled + , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled + , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out + , sm_do_eta_reduction :: !Bool + , sm_arity_opts :: !ArityOpts + , sm_rule_opts :: !RuleOpts + , sm_case_folding :: !Bool + , sm_case_merge :: !Bool + , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options + } + +instance Outputable SimplMode where + ppr (SimplMode { sm_phase = p , sm_names = ss + , sm_rules = r, sm_inline = i + , sm_cast_swizzle = cs + , sm_eta_expand = eta, sm_case_case = cc }) + = text "SimplMode" <+> braces ( + sep [ text "Phase =" <+> ppr p <+> + brackets (text (concat $ intersperse "," ss)) <> comma + , pp_flag i (text "inline") <> comma + , pp_flag r (text "rules") <> comma + , pp_flag eta (text "eta-expand") <> comma + , pp_flag cs (text "cast-swizzle") <> comma + , pp_flag cc (text "case-of-case") ]) + 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) + +data FloatEnable -- Controls local let-floating + = FloatDisabled -- Do no local let-floating + | FloatNestedOnly -- Local let-floating for nested (NotTopLevel) bindings only + | FloatEnabled -- Do local let-floating on all bindings + +{- +Note [Local floating] +~~~~~~~~~~~~~~~~~~~~~ +The Simplifier can perform local let-floating: it floats let-bindings +out of the RHS of let-bindings. See + Let-floating: moving bindings to give faster programs (ICFP'96) + https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/ + +Here's an example + x = let y = v+1 in (y,true) + +The RHS of x is a thunk. Much better to float that y-binding out to give + y = v+1 + x = (y,true) + +Not only have we avoided building a thunk, but any (case x of (p,q) -> ...) in +the scope of the x-binding can now be simplified. + +This local let-floating is done in GHC.Core.Opt.Simplify.prepareBinding, +controlled by the predicate GHC.Core.Opt.Simplify.Env.doFloatFromRhs. + +The `FloatEnable` data type controls where local let-floating takes place; +it allows you to specify that it should be done only for nested bindings; +or for top-level bindings as well; or not at all. + +Note that all of this is quite separate from the global FloatOut pass; +see GHC.Core.Opt.FloatOut. + +-} + data SimplFloats = SimplFloats { -- Ordinary let bindings @@ -167,7 +369,7 @@ | otherwise = ppr v type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr - -- See Note [Extending the Subst] in GHC.Core.Subst + -- See Note [Extending the IdSubstEnv] in GHC.Core.Subst -- | A substitution result. data SimplSR @@ -266,7 +468,7 @@ binding site. * The in-scope "set" usually maps x->x; we use it simply for its domain. - But sometimes we have two in-scope Ids that are synomyms, and should + But sometimes we have two in-scope Ids that are synonyms, and should map to the same target: x->x, y->x. Notably: case y of x { ... } That's why the "set" is actually a VarEnv Var @@ -284,9 +486,10 @@ so that we know to drop the context. Thus we remember which join points we're substituting. -} -mkSimplEnv :: SimplMode -> SimplEnv -mkSimplEnv mode +mkSimplEnv :: SimplMode -> (FamInstEnv, FamInstEnv) -> SimplEnv +mkSimplEnv mode fam_envs = SimplEnv { seMode = mode + , seFamEnvs = fam_envs , seInScope = init_in_scope , seTvSubst = emptyVarEnv , seCvSubst = emptyVarEnv @@ -296,7 +499,7 @@ -- The top level "enclosing CC" is "SUBSUMED". init_in_scope :: InScopeSet -init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder Many unitTy)) +init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder ManyTy unitTy)) -- See Note [WildCard binders] {- @@ -319,23 +522,6 @@ It's a very dark corner of GHC. Maybe it should be cleaned up. -} -getMode :: SimplEnv -> SimplMode -getMode env = seMode env - -seDynFlags :: SimplEnv -> DynFlags -seDynFlags env = sm_dflags (seMode env) - -seLogger :: SimplEnv -> Logger -seLogger env = sm_logger (seMode env) - - -seUnfoldingOpts :: SimplEnv -> UnfoldingOpts -seUnfoldingOpts env = sm_uf_opts (seMode env) - - -setMode :: SimplMode -> SimplEnv -> SimplEnv -setMode mode env = env { seMode = mode } - updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv updMode upd env = -- Avoid keeping env alive in case inlining fails. @@ -449,7 +635,8 @@ ~~~~~~~~~~~~~~~~ The LetFloats is a bunch of bindings, classified by a FloatFlag. -* All of them satisfy the let/app invariant +The `FloatFlag` contains summary information about the bindings, see the data +type declaration of `FloatFlag` Examples @@ -460,10 +647,8 @@ NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge - -Can't happen: - NonRec x# (a /# b) -- Might fail; does not satisfy let/app - NonRec x# (f y) -- Might diverge; does not satisfy let/app + NonRec x# (a /# b) FltCareful -- Might fail; does not satisfy let-can-float invariant + NonRec x# (f y) FltCareful -- Might diverge; does not satisfy let-can-float invariant -} data LetFloats = LetFloats (OrdList OutBind) FloatFlag @@ -475,19 +660,22 @@ data FloatFlag = FltLifted -- All bindings are lifted and lazy *or* -- consist of a single primitive string literal - -- Hence ok to float to top level, or recursive + -- Hence ok to float to top level, or recursive + -- NB: consequence: all bindings satisfy let-can-float invariant | FltOkSpec -- All bindings are FltLifted *or* -- strict (perhaps because unlifted, -- perhaps because of a strict binder), -- *and* ok-for-speculation - -- Hence ok to float out of the RHS - -- of a lazy non-recursive let binding - -- (but not to top level, or into a rec group) + -- Hence ok to float out of the RHS + -- of a lazy non-recursive let binding + -- (but not to top level, or into a rec group) + -- NB: consequence: all bindings satisfy let-can-float invariant | FltCareful -- At least one binding is strict (or unlifted) -- and not guaranteed cheap - -- Do not float these bindings out of a lazy let + -- Do not float these bindings out of a lazy let! + -- NB: some bindings may not satisfy let-can-float instance Outputable LetFloats where ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds) @@ -503,10 +691,14 @@ andFF FltOkSpec _ = FltOkSpec andFF FltLifted flt = flt -doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool --- If you change this function look also at FloatIn.noFloatFromRhs -doFloatFromRhs lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs - = not (isNilOL fs) && want_to_float && can_float + +doFloatFromRhs :: FloatEnable -> TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool +-- If you change this function look also at FloatIn.noFloatIntoRhs +doFloatFromRhs fe lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs + = floatEnabled lvl fe + && not (isNilOL fs) + && want_to_float + && can_float where want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs -- See Note [Float when cheap or expandable] @@ -515,6 +707,12 @@ FltOkSpec -> isNotTopLevel lvl && isNonRec rec FltCareful -> isNotTopLevel lvl && isNonRec rec && strict_bind + -- Whether any floating is allowed by flags. + floatEnabled :: TopLevelFlag -> FloatEnable -> Bool + floatEnabled _ FloatDisabled = False + floatEnabled lvl FloatNestedOnly = not (isTopLevel lvl) + floatEnabled _ FloatEnabled = True + {- Note [Float when cheap or expandable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -530,9 +728,15 @@ emptyLetFloats :: LetFloats emptyLetFloats = LetFloats nilOL FltLifted +isEmptyLetFloats :: LetFloats -> Bool +isEmptyLetFloats (LetFloats fs _) = isNilOL fs + emptyJoinFloats :: JoinFloats emptyJoinFloats = nilOL +isEmptyJoinFloats :: JoinFloats -> Bool +isEmptyJoinFloats = isNilOL + unitLetFloat :: OutBind -> LetFloats -- This key function constructs a singleton float with the right form unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $ @@ -545,11 +749,7 @@ -- String literals can be floated freely. -- See Note [Core top-level string literals] in GHC.Core. | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF) - | otherwise = assertPpr (not (isUnliftedType (idType bndr))) (ppr bndr) - -- NB: binders always have a fixed RuntimeRep, so calling - -- isUnliftedType is OK here - FltCareful - -- Unlifted binders can only be let-bound if exprOkForSpeculation holds + | otherwise = FltCareful unitJoinFloat :: OutBind -> JoinFloats unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $ @@ -612,10 +812,6 @@ , sfInScope = foldlOL extendInScopeSetBind (sfInScope floats) join_floats } -extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet -extendInScopeSetBind in_scope bind - = extendInScopeSetList in_scope (bindersOf bind) - addFloats :: SimplFloats -> SimplFloats -> SimplFloats -- Add both let-floats and join-floats for env2 to env1; -- *plus* the in-scope set for env2, which is bigger @@ -654,13 +850,15 @@ | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs))) wrapFloats :: SimplFloats -> OutExpr -> OutExpr --- Wrap the floats around the expression; they should all --- satisfy the let/app invariant, so mkLets should do the job just fine -wrapFloats (SimplFloats { sfLetFloats = LetFloats bs _ +-- Wrap the floats around the expression +wrapFloats (SimplFloats { sfLetFloats = LetFloats bs flag , sfJoinFloats = jbs }) body - = foldrOL Let (wrapJoinFloats jbs body) bs + = foldrOL mk_let (wrapJoinFloats jbs body) bs -- Note: Always safe to put the joins on the inside -- since the values can't refer to them + where + mk_let | FltCareful <- flag = mkCoreLet -- need to enforce let-can-float-invariant + | otherwise = Let -- let-can-float invariant hold wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr) -- Wrap the sfJoinFloats of the env around the expression, @@ -814,7 +1012,6 @@ do { let (!env1, ids1) = mapAccumL substIdBndr env ids ; seqIds ids1 `seq` return env1 } - --------------- substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr) -- Might be a coercion variable @@ -959,7 +1156,7 @@ adjustJoinPointType :: Mult -> Type -- New result type -> Id -- Old join-point Id - -> Id -- Adjusted jont-point Id + -> Id -- Adjusted join-point Id -- (adjustJoinPointType mult new_res_ty join_id) does two things: -- -- 1. Set the return type of the join_id to new_res_ty @@ -987,7 +1184,7 @@ = pprPanic "adjustJoinPointType" (ppr orig_ar <+> ppr orig_ty) -- See Note [Bangs in the Simplifier] - scale_bndr (Anon af t) = Anon af $! (scaleScaled mult t) + scale_bndr (Anon t af) = (Anon $! (scaleScaled mult t)) af scale_bndr b@(Named _) = b {- Note [Scaling join point arguments] @@ -1023,34 +1220,34 @@ ************************************************************************ -} -getTCvSubst :: SimplEnv -> TCvSubst -getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env +getSubst :: SimplEnv -> Subst +getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env , seCvSubst = cv_env }) - = mkTCvSubst in_scope (tv_env, cv_env) + = mkSubst in_scope tv_env cv_env emptyIdSubstEnv -substTy :: SimplEnv -> Type -> Type -substTy env ty = Type.substTy (getTCvSubst env) ty +substTy :: HasDebugCallStack => SimplEnv -> Type -> Type +substTy env ty = Type.substTy (getSubst env) ty substTyVar :: SimplEnv -> TyVar -> Type -substTyVar env tv = Type.substTyVar (getTCvSubst env) tv +substTyVar env tv = Type.substTyVar (getSubst env) tv substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) substTyVarBndr env tv - = case Type.substTyVarBndr (getTCvSubst env) tv of - (TCvSubst in_scope' tv_env' cv_env', tv') + = case Type.substTyVarBndr (getSubst 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 (getTCvSubst env) tv +substCoVar env tv = Coercion.substCoVar (getSubst env) tv substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) substCoVarBndr env cv - = case Coercion.substCoVarBndr (getTCvSubst env) cv of - (TCvSubst in_scope' tv_env' cv_env', cv') + = case Coercion.substCoVarBndr (getSubst 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 (getTCvSubst env) co +substCo env co = Coercion.substCo (getSubst env) co ------------------ substIdType :: SimplEnv -> Id -> Id @@ -1064,6 +1261,6 @@ -- in a Note in the id's type itself where no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w - subst = TCvSubst in_scope tv_env cv_env + subst = Subst in_scope emptyIdSubstEnv tv_env cv_env old_ty = idType id old_w = varMult id diff --git a/GHC/Core/Opt/Simplify/Iteration.hs b/GHC/Core/Opt/Simplify/Iteration.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Simplify/Iteration.hs @@ -0,0 +1,4443 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[Simplify]{The main module of the simplifier} +-} + + +{-# 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, 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 +-- NOT used for JoinIds +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' } + +-------------------------- +simplNonRecX :: SimplEnv + -> InId -- Old binder; not a JoinId + -> OutExpr -- Simplified RHS + -> SimplM (SimplFloats, SimplEnv) +-- A specialised variant of simplNonRec used when the RHS is already +-- simplified, notably in knownCon. It uses case-binding where necessary. +-- +-- Precondition: rhs satisfies the let-can-float invariant + +simplNonRecX env bndr new_rhs + | assertPpr (not (isJoinId bndr)) (ppr bndr) $ + isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } + = return (emptyFloats env, env) -- Here c is dead, and we avoid + -- creating the binding c = (a,b) + + | Coercion co <- new_rhs + = return (emptyFloats env, extendCvSubst env bndr co) + + | exprIsTrivial new_rhs -- Short-cut for let x = y in ... + -- This case would ultimately land in postInlineUnconditionally + -- but it seems not uncommon, and avoids a lot of faff to do it here + = return (emptyFloats env + , extendIdSubst env bndr (DoneEx new_rhs Nothing)) + + | otherwise + = do { (env1, new_bndr) <- simplBinder env bndr + ; let is_strict = isStrictId new_bndr + -- isStrictId: use new_bndr 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 + new_bndr (emptyFloats env) new_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 (env1 `setInScopeFromF` rhs_floats) + (BC_Let NotTopLevel NonRecursive) + bndr new_bndr rhs1 + -- Must pass env1 to completeBind in case simplBinder had to clone, + -- and extended the substitution with [bndr :-> new_bndr] + + ; 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 + = do { (_is_exp, floats, rhs1) <- go 0 rhs0 + ; return (floats, rhs1) } + where + go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr) + go n_val_args (Cast rhs co) + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; return (is_exp, floats, Cast rhs' co) } + go n_val_args (App fun (Type ty)) + = do { (is_exp, floats, rhs') <- go n_val_args fun + ; return (is_exp, floats, App rhs' (Type ty)) } + go n_val_args (App fun arg) + = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun + ; if is_exp + then do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg + ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } + else return (False, emptyLetFloats, App fun arg) + } + go n_val_args (Var fun) + = return (is_exp, emptyLetFloats, Var fun) + where + is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP + -- See Note [CONLIKE pragma] in GHC.Types.Basic + -- The definition of is_exp should match that in + -- 'GHC.Core.Opt.OccurAnal.occAnalApp' + + go n_val_args (Tick t rhs) + -- We want to be able to float bindings past this + -- tick. Non-scoping ticks don't care. + | tickishScoped t == NoScope + = do { (is_exp, floats, rhs') <- go n_val_args rhs + ; return (is_exp, 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 { (is_exp, floats, rhs') <- go n_val_args rhs + ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) + floats' = mapLetFloats floats tickIt + ; return (is_exp, floats', Tick t rhs') } + + go _ other + = return (False, 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 False 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 } + -> completeBindX (se `setInScopeFromE` env) 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 + -> InId -> OutExpr -- Bind this Id to this (simplified) expression + -- (the let-can-float invariant may not be satisfied) + -> InExpr -- In this lambda + -> SimplCont -- Consumed by this continuation + -> SimplM (SimplFloats, OutExpr) +completeBindX env bndr rhs body cont + | needsCaseBinding (idType bndr) rhs -- Enforcing the let-can-float-invariant + = do { (env1, bndr1) <- simplNonRecBndr env bndr + ; (floats, expr') <- simplLam env1 body cont + -- Do not float floats past the Case binder below + ; let expr'' = wrapFloats floats expr' + ; let case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr''] + ; return (emptyFloats env, case_expr) } + + | otherwise + = do { (floats1, env') <- simplNonRecX env bndr rhs + ; (floats2, expr') <- simplLam env' body cont + ; return (floats1 `addFloats` floats2, expr') } + + +{- +************************************************************************ +* * +\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} +* * +************************************************************************ +-} + +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 }) + | isSimplified dup -- Don't re-simplify if we've simplified it once + -- See Note [Avoiding exponential behaviour] + = do { tick (BetaReduction bndr) + ; completeBindX env bndr arg body cont } + + | otherwise -- See Note [Avoiding exponential behaviour] + = do { tick (BetaReduction bndr) + ; simplNonRecE env True 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 + -> Bool -- True <=> from a lambda + -- False <=> from a let + -> 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 +-- * non-top-level non-recursive non-join-point lets in expressions +-- * beta reduction +-- +-- simplNonRec 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_lam=False => the RHS satisfies the let-can-float invariant +-- Otherwise it may or may not satisfy it. + +simplNonRecE env from_lam bndr (rhs, rhs_se) body cont + = assert (isId bndr && not (isJoinId bndr) ) $ + do { (env1, bndr1) <- simplNonRecBndr env bndr + ; let needs_case_binding = needsCaseBinding (idType bndr1) rhs + -- See Note [Dark corner with representation polymorphism] + -- If from_lam=False then needs_case_binding is False, + -- because the binding started as a let, which must + -- satisfy let-can-float + + ; if | from_lam && not needs_case_binding + -- If not from_lam we are coming from a (NonRec bndr rhs) binding + -- and preInlineUnconditionally has been done already; + -- no need to repeat it. But for lambdas we must be careful about + -- preInlineUndonditionally: consider (\(x:Int#). 3) (error "urk") + -- We must not drop the (error "urk"). + , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se + -> do { tick (PreInlineUnconditionally bndr) + ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ + simplLam env' body cont } + + -- Deal with strict bindings + | isStrictId bndr1 && seCaseCase env + || from_lam && needs_case_binding + -- The important bit here is needs_case_binds; but no need to + -- test it if from_lam is False because then needs_case_binding is False too + -- NB: either way, the RHS may or may not satisfy let-can-float + -- but that's ok for StrictBind. + -> simplExprF (rhs_se `setInScopeFromE` env) rhs + (StrictBind { sc_bndr = bndr, sc_body = body + , sc_env = env, sc_cont = cont, sc_dup = NoDup }) + + -- Deal with lazy bindings + | otherwise + -> do { (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) + ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se + ; (floats2, expr') <- simplLam env3 body cont + ; return (floats1 `addFloats` floats2, expr') } } + +------------------ +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. 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 {}, TyArg {} ] <- rev_args + -- Do this even if (contIsStop cont) + -- See Note [No eta-expansion in runRW#] + = do { let arg_env = arg_se `setInScopeFromE` env + ty' = contResultType cont + + -- 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. + ; arg' <- case arg of + Lam s body -> do { (env', s') <- simplBinder arg_env s + ; body' <- simplExprC env' body 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 = cont + , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' } + -- cont' applies to s', then K + ; body' <- simplExprC env' arg cont' + ; return (Lam s' body') } + + ; let rr' = getRuntimeRep ty' + call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg'] + ; return (emptyFloats env, call') } + +---------- 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 + = -- 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. + +Possible improvement: occ-anal the rules when putting them in the +database; and in the simplifier just occ-anal the OutExpr arguments. +But that's more complicated and the rule RHS is usually tiny; so I'm +just doing the simple thing. + +Historical note: previously we did occ-anal the rules in Rule.hs, +but failed to occ-anal the OutExpr arguments, which led to the +nasty performance problem described above. + + +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') <- simplNonRecX 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') <- simplNonRecX 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) + = 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 + -- Note that the binder might be "dead", because it doesn't + -- occur in the RHS; and simplNonRecX may therefore discard + -- it via postInlineUnconditionally. + -- 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) <- simplNonRecX 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 + ; simplNonRecX 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_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) <- simplLam sb_env1 body cont + -- No need to use mkDupableCont before simplLam; 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 + -- 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) ] + + ; args' <- mapM (simplExpr lhs_env) args + ; rhs' <- simplExprC rhs_env rhs rhs_cont + ; return (rule { ru_bndrs = bndrs' + , ru_fn = fn_name' + , ru_args = args' + , ru_rhs = rhs' }) } + +{- Note [Simplifying the RHS of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can simplify the RHS of a RULE much as we do the RHS of a stable +unfolding. We used to use the much more conservative updModeForRules +for the RHS as well as the LHS, but that seems more conservative +than necesary. Allowing some inlining might, for example, eliminate +a binding. +-} 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 @@ -7,9 +7,9 @@ module GHC.Core.Opt.Simplify.Monad ( -- The monad - SimplM, + TopEnvConfig(..), SimplM, initSmpl, traceSmpl, - getSimplRules, getFamEnvs, getOptCoercionOpts, + getSimplRules, -- Unique supply MonadUnique(..), newId, newJoinId, @@ -24,18 +24,14 @@ import GHC.Types.Var ( Var, isId, mkLocalVar ) import GHC.Types.Name ( mkSystemVarName ) -import GHC.Types.Id ( Id, mkSysLocalOrCoVar ) +import GHC.Types.Id ( Id, mkSysLocalOrCoVarM ) import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo ) import GHC.Core.Type ( Type, Mult ) -import GHC.Core.FamInstEnv ( FamInstEnv ) -import GHC.Core ( RuleEnv(..), RuleBase) +import GHC.Core.Opt.Stats import GHC.Core.Rules import GHC.Core.Utils ( mkLamTypes ) -import GHC.Core.Coercion.Opt import GHC.Types.Unique.Supply -import GHC.Driver.Session -import GHC.Driver.Config -import GHC.Core.Opt.Monad +import GHC.Driver.Flags import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Monad @@ -44,7 +40,7 @@ import GHC.Utils.Panic (throwGhcExceptionIO, GhcException (..)) import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf ) import Control.Monad ( ap ) -import GHC.Core.Multiplicity ( pattern Many ) +import GHC.Core.Multiplicity ( pattern ManyTy ) import GHC.Exts( oneShot ) {- @@ -53,13 +49,10 @@ \subsection{Monad plumbing} * * ************************************************************************ - -For the simplifier monad, we want to {\em thread} a unique supply and a counter. -(Command-line switches move around through the explicitly-passed SimplEnv.) -} newtype SimplM result - = SM' { unSM :: SimplTopEnv -- Envt that does not change much + = SM' { unSM :: SimplTopEnv -> SimplCount -> IO (result, SimplCount)} -- We only need IO here for dump output, but since we already have it @@ -76,54 +69,53 @@ where SM m = SM' (oneShot $ \env -> oneShot $ \ct -> m env ct) +-- See Note [The environments of the Simplify pass] +data TopEnvConfig = TopEnvConfig + { te_history_size :: !Int + , te_tick_factor :: !Int + } + data SimplTopEnv - = STE { st_flags :: DynFlags + = STE { -- See Note [The environments of the Simplify pass] + st_config :: !TopEnvConfig , st_logger :: !Logger - , st_max_ticks :: IntWithInf -- ^ Max #ticks in this simplifier run - , st_query_rulebase :: IO RuleBase - -- ^ The action to retrieve an up-to-date EPS RuleBase + , st_max_ticks :: !IntWithInf -- ^ Max #ticks in this simplifier run + , st_read_ruleenv :: !(IO RuleEnv) + -- ^ The action to retrieve an up-to-date EPS RuleEnv -- See Note [Overall plumbing for rules] - , st_mod_rules :: RuleEnv - , st_fams :: (FamInstEnv, FamInstEnv) - - , st_co_opt_opts :: !OptCoercionOpts - -- ^ Coercion optimiser options } -initSmpl :: Logger -> DynFlags -> IO RuleBase -> RuleEnv -> (FamInstEnv, FamInstEnv) - -> Int -- Size of the bindings, used to limit - -- the number of ticks we allow +initSmpl :: Logger + -> IO RuleEnv + -> TopEnvConfig + -> Int -- ^ Size of the bindings, used to limit the number of ticks we allow -> SimplM a -> IO (a, SimplCount) -initSmpl logger dflags qrb rules fam_envs size m +initSmpl logger read_ruleenv cfg size m = do -- No init count; set to 0 - let simplCount = zeroSimplCount dflags - (result, count) <- unSM m env simplCount - return (result, count) + let simplCount = zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats + unSM m env simplCount where - env = STE { st_flags = dflags + env = STE { st_config = cfg , st_logger = logger - , st_query_rulebase = qrb - , st_mod_rules = rules - , st_max_ticks = computeMaxTicks dflags size - , st_fams = fam_envs - , st_co_opt_opts = initOptCoercionOpts dflags + , st_max_ticks = computeMaxTicks cfg size + , st_read_ruleenv = read_ruleenv } -computeMaxTicks :: DynFlags -> Int -> IntWithInf +computeMaxTicks :: TopEnvConfig -> Int -> IntWithInf -- Compute the max simplifier ticks as -- (base-size + pgm-size) * magic-multiplier * tick-factor/100 -- where -- magic-multiplier is a constant that gives reasonable results -- base-size is a constant to deal with size-zero programs -computeMaxTicks dflags size +computeMaxTicks cfg size = treatZeroAsInf $ fromInteger ((toInteger (size + base_size) * toInteger (tick_factor * magic_multiplier)) `div` 100) where - tick_factor = simplTickFactor dflags + tick_factor = te_tick_factor cfg base_size = 100 magic_multiplier = 40 -- MAGIC NUMBER, multiplies the simplTickFactor @@ -196,31 +188,25 @@ getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplMask getUniqueM = liftIO $ uniqFromMask simplMask -instance HasDynFlags SimplM where - getDynFlags = SM (\st_env sc -> return (st_flags st_env, sc)) - instance HasLogger SimplM where - getLogger = SM (\st_env sc -> return (st_logger st_env, sc)) + getLogger = gets st_logger instance MonadIO SimplM where - liftIO m = SM $ \_ sc -> do - x <- m - return (x, sc) + liftIO = liftIOWithEnv . const getSimplRules :: SimplM RuleEnv -getSimplRules = SM (\st_env sc -> do - eps_rules <- st_query_rulebase st_env - return (extendRuleEnv (st_mod_rules st_env) eps_rules, sc)) +getSimplRules = liftIOWithEnv st_read_ruleenv -getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) -getFamEnvs = SM (\st_env sc -> return (st_fams st_env, sc)) +liftIOWithEnv :: (SimplTopEnv -> IO a) -> SimplM a +liftIOWithEnv m = SM (\st_env sc -> do + x <- m st_env + return (x, sc)) -getOptCoercionOpts :: SimplM OptCoercionOpts -getOptCoercionOpts = SM (\st_env sc -> return (st_co_opt_opts st_env, sc)) +gets :: (SimplTopEnv -> a) -> SimplM a +gets f = liftIOWithEnv (return . f) newId :: FastString -> Mult -> Type -> SimplM Id -newId fs w ty = do uniq <- getUniqueM - return (mkSysLocalOrCoVar fs uniq w ty) +newId fs w ty = mkSysLocalOrCoVarM fs w ty -- | Make a join id with given type and arity but without call-by-value annotations. newJoinId :: [Var] -> Type -> SimplM Id @@ -235,7 +221,7 @@ id_info = vanillaIdInfo `setArityInfo` arity -- `setOccInfo` strongLoopBreaker - ; return (mkLocalVar details name Many join_id_ty id_info) } + ; return (mkLocalVar details name ManyTy join_id_ty id_info) } {- ************************************************************************ @@ -249,8 +235,10 @@ getSimplCount = SM (\_st_env sc -> return (sc, sc)) tick :: Tick -> SimplM () -tick t = SM (\st_env sc -> let sc' = doSimplTick (st_flags st_env) t sc - in sc' `seq` return ((), sc')) +tick t = SM (\st_env sc -> let + history_size = te_history_size (st_config st_env) + sc' = doSimplTick history_size t sc + in sc' `seq` return ((), sc')) checkedTick :: Tick -> SimplM () -- Try to take a tick, but fail if too many @@ -259,8 +247,10 @@ if st_max_ticks st_env <= mkIntWithInf (simplCountN sc) then throwGhcExceptionIO $ PprProgramError "Simplifier ticks exhausted" (msg sc) - else let sc' = doSimplTick (st_flags st_env) t sc - in sc' `seq` return ((), sc')) + else let + history_size = te_history_size (st_config st_env) + sc' = doSimplTick history_size t sc + in sc' `seq` return ((), sc')) where msg sc = vcat [ text "When trying" <+> ppr t 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 @@ -8,2516 +8,2699 @@ module GHC.Core.Opt.Simplify.Utils ( -- Rebuilding - mkLam, mkCase, prepareAlts, tryEtaExpandRhs, - - -- Inlining, - preInlineUnconditionally, postInlineUnconditionally, - activeUnfolding, activeRule, - getUnfoldingInRuleMatch, - simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules, - - -- The BindContext type - BindContext(..), bindContextLevel, - - -- The continuation type - SimplCont(..), DupFlag(..), StaticEnv, - isSimplified, contIsStop, - contIsDupable, contResultType, contHoleType, contHoleScaling, - contIsTrivial, contArgs, - countArgs, - mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg, - interestingCallContext, - - -- ArgInfo - ArgInfo(..), ArgSpec(..), mkArgInfo, - addValArgTo, addCastTo, addTyArgTo, - argInfoExpr, argInfoAppArgs, pushSimplifiedArgs, - isStrictArgInfo, lazyArgContext, - - abstractFloats, - - -- Utilities - isExitJoinId - ) where - -import GHC.Prelude - -import GHC.Driver.Session - -import GHC.Core -import GHC.Types.Literal ( isLitRubbish ) -import GHC.Core.Opt.Simplify.Env -import GHC.Core.Opt.Monad ( SimplMode(..), 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.Opt.Arity -import GHC.Core.Unfold -import GHC.Core.Unfold.Make -import GHC.Core.Opt.Simplify.Monad -import GHC.Core.Type hiding( substTy ) -import GHC.Core.Coercion hiding( substCo ) -import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) -import GHC.Core.Multiplicity -import GHC.Core.Opt.ConstantFold - -import GHC.Types.Name -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Tickish -import GHC.Types.Demand -import GHC.Types.Var.Set -import GHC.Types.Basic - -import GHC.Data.OrdList ( isNilOL ) -import GHC.Data.FastString ( fsLit ) - -import GHC.Utils.Misc -import GHC.Utils.Monad -import GHC.Utils.Outputable -import GHC.Utils.Logger -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Trace - -import Control.Monad ( when ) -import Data.List ( sortBy ) - -{- ********************************************************************* -* * - The BindContext type -* * -********************************************************************* -} - --- What sort of binding is this? A let-binding or a join-binding? -data BindContext - = BC_Let -- A regular let-binding - TopLevelFlag RecFlag - - | BC_Join -- A join point with continuation k - SimplCont -- See Note [Rules and unfolding for join points] - -- in GHC.Core.Opt.Simplify - -bindContextLevel :: BindContext -> TopLevelFlag -bindContextLevel (BC_Let top_lvl _) = top_lvl -bindContextLevel (BC_Join {}) = NotTopLevel - - -{- ********************************************************************* -* * - The SimplCont and DupFlag types -* * -************************************************************************ - -A SimplCont allows the simplifier to traverse the expression in a -zipper-like fashion. The SimplCont represents the rest of the expression, -"above" the point of interest. - -You can also think of a SimplCont as an "evaluation context", using -that term in the way it is used for operational semantics. This is the -way I usually think of it, For example you'll often see a syntax for -evaluation context looking like - C ::= [] | C e | case C of alts | C `cast` co -That's the kind of thing we are doing here, and I use that syntax in -the comments. - - -Key points: - * A SimplCont describes a *strict* context (just like - evaluation contexts do). E.g. Just [] is not a SimplCont - - * A SimplCont describes a context that *does not* bind - any variables. E.g. \x. [] is not a SimplCont --} - -data SimplCont - = Stop -- Stop[e] = e - OutType -- Type of the - CallCtxt -- Tells if there is something interesting about - -- the context, and hence the inliner - -- should be a bit keener (see interestingCallContext) - -- Specifically: - -- This is an argument of a function that has RULES - -- Inlining the call might allow the rule to fire - -- Never ValAppCxt (use ApplyToVal instead) - -- or CaseCtxt (use Select instead) - - | CastIt -- (CastIt co K)[e] = K[ e `cast` co ] - OutCoercion -- The coercion simplified - -- Invariant: never an identity coercion - SimplCont - - | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] - { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) - -- See Note [The hole type in ApplyToTy] - , sc_arg :: InExpr -- The argument, - , sc_env :: StaticEnv -- see Note [StaticEnv invariant] - , sc_cont :: SimplCont } - - | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] - { sc_arg_ty :: OutType -- Argument type - , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) - -- See Note [The hole type in ApplyToTy] - , sc_cont :: SimplCont } - - | Select -- (Select alts K)[e] = K[ case e of alts ] - { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_bndr :: InId -- case binder - , sc_alts :: [InAlt] -- Alternatives - , sc_env :: StaticEnv -- See Note [StaticEnv invariant] - , sc_cont :: SimplCont } - - -- The two strict forms have no DupFlag, because we never duplicate them - | 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_body :: InExpr - , sc_env :: StaticEnv -- See Note [StaticEnv invariant] - , sc_cont :: SimplCont } - - | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] - { sc_dup :: DupFlag -- Always Simplified or OkToDup - , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc - -- plus demands and discount flags for *this* arg - -- and further args - -- So ai_dmds and ai_discs are never empty - , sc_fun_ty :: OutType -- Type of the function (f e1 .. en), - -- presumably (arg_ty -> res_ty) - -- where res_ty is expected by sc_cont - , sc_cont :: SimplCont } - - | TickIt -- (TickIt t K)[e] = K[ tick t e ] - CoreTickish -- Tick tickish - SimplCont - -type StaticEnv = SimplEnv -- Just the static part is relevant - -data DupFlag = NoDup -- Unsimplified, might be big - | Simplified -- Simplified - | OkToDup -- Simplified and small - -isSimplified :: DupFlag -> Bool -isSimplified NoDup = False -isSimplified _ = True -- Invariant: the subst-env is empty - -perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type -perhapsSubstTy dup env ty - | isSimplified dup = ty - | otherwise = substTy env ty - -{- Note [StaticEnv invariant] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We pair up an InExpr or InAlts with a StaticEnv, which establishes the -lexical scope for that InExpr. When we simplify that InExpr/InAlts, we -use - - Its captured StaticEnv - - Overriding its InScopeSet with the larger one at the - simplification point. - -Why override the InScopeSet? Example: - (let y = ey in f) ex -By the time we simplify ex, 'y' will be in scope. - -However the InScopeSet in the StaticEnv is not irrelevant: it should -include all the free vars of applying the substitution to the InExpr. -Reason: contHoleType uses perhapsSubstTy to apply the substitution to -the expression, and that (rightly) gives ASSERT failures if the InScopeSet -isn't big enough. - -Note [DupFlag invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~ -In both (ApplyToVal dup _ env k) - and (Select dup _ _ env k) -the following invariants hold - - (a) if dup = OkToDup, then continuation k is also ok-to-dup - (b) if dup = OkToDup or Simplified, the subst-env is empty - (and hence no need to re-simplify) --} - -instance Outputable DupFlag where - ppr OkToDup = text "ok" - ppr NoDup = text "nodup" - ppr Simplified = text "simpl" - -instance Outputable SimplCont where - ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty - ppr (CastIt co 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) - 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 }) - = (text "Select" <+> ppr dup <+> ppr bndr) $$ - whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont - - -{- Note [The hole type in ApplyToTy] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The sc_hole_ty field of ApplyToTy records the type of the "hole" in the -continuation. It is absolutely necessary to compute contHoleType, but it is -not used for anything else (and hence may not be evaluated). - -Why is it necessary for contHoleType? Consider the continuation - ApplyToType Int (Stop Int) -corresponding to - ( @Int) :: Int -What is the type of ? It could be (forall a. Int) or (forall a. a), -and there is no way to know which, so we must record it. - -In a chain of applications (f @t1 @t2 @t3) we'll lazily compute exprType -for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably -doesn't matter because we'll never compute them all. - -************************************************************************ -* * - ArgInfo and ArgSpec -* * -************************************************************************ --} - -data ArgInfo - = ArgInfo { - ai_fun :: OutId, -- The function - ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order) - - ai_rules :: FunRules, -- 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 - - ai_dmds :: [Demand], -- Demands on remaining value arguments (beyond ai_args) - -- Usually infinite, but if it is finite it guarantees - -- that the function diverges after being given - -- that number of args - - ai_discs :: [Int] -- Discounts for remaining value arguments (beyong ai_args) - -- non-zero => be keener to inline - -- Always infinite - } - -data ArgSpec - = ValArg { as_dmd :: Demand -- Demand placed on this argument - , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal - , as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2) - - | 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 }) - = text "ArgInfo" <+> braces - (sep [ text "fun =" <+> ppr fun - , text "dmds =" <+> ppr dmds - , text "args =" <+> ppr args ]) - -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_rules = rules } <- 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_rules = decRules rules } - | 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_rules = decRules (ai_rules 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 :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont -pushSimplifiedArgs _env [] k = k -pushSimplifiedArgs env (arg : args) k - = case arg of - TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } - -> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest } - ValArg { as_arg = arg, as_hole_ty = hole_ty } - -> ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified - , sc_hole_ty = hole_ty, sc_cont = rest } - CastBy c -> CastIt c rest - where - rest = pushSimplifiedArgs env args k - -- The env has an empty SubstEnv - -argInfoExpr :: OutId -> [ArgSpec] -> OutExpr --- NB: the [ArgSpec] is reversed so that the first arg --- in the list is the last one in the application -argInfoExpr fun rev_args - = go rev_args - where - 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 - - -type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function - -- Nothing => No rules - -- Just (n, rules) => some rules, requiring at least n more type/value args - -decRules :: FunRules -> FunRules -decRules (Just (n, rules)) = Just (n-1, rules) -decRules Nothing = Nothing - -mkFunRules :: [CoreRule] -> FunRules -mkFunRules [] = Nothing -mkFunRules rs = Just (n_required, rs) - where - n_required = maximum (map ruleArity rs) - -{- -************************************************************************ -* * - Functions on SimplCont -* * -************************************************************************ --} - -mkBoringStop :: OutType -> SimplCont -mkBoringStop ty = Stop ty BoringCtxt - -mkRhsStop :: OutType -> SimplCont -- See Note [RHS of lets] in GHC.Core.Unfold -mkRhsStop ty = Stop ty RhsCtxt - -mkLazyArgStop :: OutType -> CallCtxt -> SimplCont -mkLazyArgStop ty cci = Stop ty cci - -------------------- -contIsRhsOrArg :: SimplCont -> Bool -contIsRhsOrArg (Stop {}) = True -contIsRhsOrArg (StrictBind {}) = True -contIsRhsOrArg (StrictArg {}) = True -contIsRhsOrArg _ = False - -contIsRhs :: SimplCont -> Bool -contIsRhs (Stop _ RhsCtxt) = True -contIsRhs (CastIt _ k) = contIsRhs k -- For f = e |> co, treat e as Rhs context -contIsRhs _ = False - -------------------- -contIsStop :: SimplCont -> Bool -contIsStop (Stop {}) = True -contIsStop _ = False - -contIsDupable :: SimplCont -> Bool -contIsDupable (Stop {}) = True -contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k -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 _ = False - -------------------- -contIsTrivial :: SimplCont -> Bool -contIsTrivial (Stop {}) = True -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 _ = False - -------------------- -contResultType :: SimplCont -> OutType -contResultType (Stop ty _) = ty -contResultType (CastIt _ k) = contResultType k -contResultType (StrictBind { sc_cont = k }) = contResultType k -contResultType (StrictArg { sc_cont = k }) = contResultType k -contResultType (Select { sc_cont = k }) = contResultType k -contResultType (ApplyToTy { sc_cont = k }) = contResultType k -contResultType (ApplyToVal { sc_cont = k }) = contResultType k -contResultType (TickIt _ k) = contResultType k - -contHoleType :: SimplCont -> OutType -contHoleType (Stop ty _) = ty -contHoleType (TickIt _ k) = contHoleType k -contHoleType (CastIt 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 -contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] -contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] -contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) - = perhapsSubstTy d se (idType b) - - --- Computes the multiplicity scaling factor at the hole. That is, in (case [] of --- x ::(p) _ { … }) (respectively for arguments of functions), the scaling --- factor is p. And in E[G[]], the scaling factor is the product of the scaling --- factor of E and that of G. --- --- The scaling factor at the hole of E[] is used to determine how a binder --- should be scaled if it commutes with E. This appears, in particular, in the --- case-of-case transformation. -contHoleScaling :: SimplCont -> Mult -contHoleScaling (Stop _ _) = One -contHoleScaling (CastIt _ k) = contHoleScaling k -contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) - = idMult id `mkMultMul` contHoleScaling k -contHoleScaling (Select { sc_bndr = id, sc_cont = k }) - = idMult id `mkMultMul` contHoleScaling k -contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k }) - = w `mkMultMul` contHoleScaling k - where - (w, _, _) = splitFunTy fun_ty -contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k -contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k -contHoleScaling (TickIt _ k) = contHoleScaling k -------------------- -countArgs :: SimplCont -> Int --- Count all arguments, including types, coercions, --- 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 _ = 0 - -contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) --- Summarises value args, discards type args and coercions --- The returned continuation of the call is only used to --- answer questions like "are you interesting?" -contArgs cont - | lone cont = (True, [], cont) - | otherwise = go [] cont - where - lone (ApplyToTy {}) = False -- See Note [Lone variables] in GHC.Core.Unfold - lone (ApplyToVal {}) = False -- NB: even a type application or cast - lone (CastIt {}) = False -- stops it being "lone" - lone _ = True - - 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 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 - - -------------------- -mkArgInfo :: SimplEnv - -> Id - -> [CoreRule] -- Rules for function - -> Int -- Number of value args - -> SimplCont -- Context of the call - -> ArgInfo - -mkArgInfo env fun rules n_val_args call_cont - | n_val_args < idArity fun -- Note [Unsaturated functions] - = ArgInfo { ai_fun = fun, ai_args = [] - , ai_rules = fun_rules - , ai_encl = False - , ai_dmds = vanilla_dmds - , ai_discs = vanilla_discounts } - | otherwise - = ArgInfo { ai_fun = fun - , ai_args = [] - , ai_rules = fun_rules - , ai_encl = interestingArgContext rules call_cont - , ai_dmds = add_type_strictness (idType fun) arg_dmds - , ai_discs = arg_discounts } - where - fun_rules = mkFunRules rules - - vanilla_discounts, arg_discounts :: [Int] - vanilla_discounts = repeat 0 - arg_discounts = case idUnfolding fun of - CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} - -> discounts ++ vanilla_discounts - _ -> vanilla_discounts - - vanilla_dmds, arg_dmds :: [Demand] - vanilla_dmds = repeat topDmd - - arg_dmds - | not (sm_inline (seMode env)) - = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False] - | otherwise - = -- add_type_str fun_ty $ - case splitDmdSig (idDmdSig fun) of - (demands, result_info) - | not (demands `lengthExceeds` n_val_args) - -> -- Enough args, use the strictness given. - -- For bottoming functions we used to pretend that the arg - -- is lazy, so that we don't treat the arg as an - -- interesting context. This avoids substituting - -- top-level bindings for (say) strings into - -- calls to error. But now we are more careful about - -- inlining lone variables, so its ok - -- (see GHC.Core.Op.Simplify.Utils.analyseCont) - if isDeadEndDiv result_info then - demands -- Finite => result is bottom - else - demands ++ vanilla_dmds - | otherwise - -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun) - <+> ppr n_val_args <+> ppr demands) $ - vanilla_dmds -- Not enough args, or no strictness - - add_type_strictness :: Type -> [Demand] -> [Demand] - -- If the function arg types are strict, record that in the 'strictness bits' - -- No need to instantiate because unboxed types (which dominate the strict - -- types) can't instantiate type variables. - -- add_type_strictness is done repeatedly (for each call); - -- might be better once-for-all in the function - -- But beware primops/datacons with no strictness - - add_type_strictness fun_ty dmds - | null dmds = [] - - | Just (_, fun_ty') <- splitForAllTyCoVar_maybe fun_ty - = add_type_strictness fun_ty' dmds -- Look through foralls - - | 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 - = strictifyDmd dmd - | otherwise - -- Something that's not definitely unlifted. - -- If the type is representation-polymorphic, we can't know whether - -- it's strict. - = dmd - = dmd' : add_type_strictness fun_ty' rest_dmds - - | otherwise - = dmds - -{- Note [Unsaturated functions] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (test eyeball/inline4) - x = a:as - y = f x -where f has arity 2. Then we do not want to inline 'x', because -it'll just be floated out again. Even if f has lots of discounts -on its first argument -- it must be saturated for these to kick in - -Note [Do not expose strictness if sm_inline=False] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -#15163 showed a case in which we had - - {-# INLINE [1] zip #-} - zip = undefined - - {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-} - -If we expose zip's bottoming nature when simplifying the LHS of the -RULE we get - {-# RULES "foo" forall as bs. - stream (case zip of {}) = ..blah... #-} -discarding the arguments to zip. Usually this is fine, but on the -LHS of a rule it's not, because 'as' and 'bs' are now not bound on -the LHS. - -This is a pretty pathological example, so I'm not losing sleep over -it, but the simplest solution was to check sm_inline; if it is False, -which it is on the LHS of a rule (see updModeForRules), then don't -make use of the strictness info for the function. --} - - -{- -************************************************************************ -* * - Interesting arguments -* * -************************************************************************ - -Note [Interesting call context] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to avoid inlining an expression where there can't possibly be -any gain, such as in an argument position. Hence, if the continuation -is interesting (eg. a case scrutinee, application etc.) then we -inline, otherwise we don't. - -Previously some_benefit used to return True only if the variable was -applied to some value arguments. This didn't work: - - let x = _coerce_ (T Int) Int (I# 3) in - case _coerce_ Int (T Int) x of - I# y -> .... - -we want to inline x, but can't see that it's a constructor in a case -scrutinee position, and some_benefit is False. - -Another example: - -dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) - -.... case dMonadST _@_ x0 of (a,b,c) -> .... - -we'd really like to inline dMonadST here, but we *don't* want to -inline if the case expression is just - - case x of y { DEFAULT -> ... } - -since we can just eliminate this case instead (x is in WHNF). Similar -applies when x is bound to a lambda expression. Hence -contIsInteresting looks for case expressions with just a single -default case. - -Note [No case of case is boring] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we see - case f x of - -we'd usually treat the context as interesting, to encourage 'f' to -inline. But if case-of-case is off, it's really not so interesting -after all, because we are unlikely to be able to push the case -expression into the branches of any case in f's unfolding. So, to -reduce unnecessary code expansion, we just make the context look boring. -This made a small compile-time perf improvement in perf/compiler/T6048, -and it looks plausible to me. --} - -lazyArgContext :: ArgInfo -> CallCtxt --- Use this for lazy arguments -lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) - | encl_rules = RuleArgCtxt - | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here - | otherwise = BoringCtxt -- Nothing interesting - -strictArgContext :: ArgInfo -> CallCtxt -strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) --- Use this for strict arguments - | encl_rules = RuleArgCtxt - | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here - | otherwise = RhsCtxt - -- Why RhsCtxt? if we see f (g x) (h x), and f is strict, we - -- want to be a bit more eager to inline g, because it may - -- expose an eval (on x perhaps) that can be eliminated or - -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1 - -- It's worth an 18% improvement in allocation for this - -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier' - -interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt --- See Note [Interesting call context] -interestingCallContext env cont - = interesting cont - where - interesting (Select {}) - | sm_case_case (getMode env) = CaseCtxt - | otherwise = BoringCtxt - -- See Note [No case of case is boring] - - interesting (ApplyToVal {}) = ValAppCtxt - -- Can happen if we have (f Int |> co) y - -- If f has an INLINE prag we need to give it some - -- motivation to inline. See Note [Cast then apply] - -- in GHC.Core.Unfold - - interesting (StrictArg { sc_fun = fun }) = strictArgContext fun - interesting (StrictBind {}) = BoringCtxt - interesting (Stop _ cci) = cci - interesting (TickIt _ k) = interesting k - interesting (ApplyToTy { sc_cont = k }) = interesting k - interesting (CastIt _ 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. - -- x + (y * z) - -- Here the contIsInteresting makes the '*' keener to inline, - -- which in turn exposes a constructor which makes the '+' inline. - -- Assuming that +,* aren't small enough to inline regardless. - -- - -- It's also very important to inline in a strict context for things - -- like - -- foldr k z (f x) - -- Here, the context of (f x) is strict, and if f's unfolding is - -- a build it's *great* to inline it here. So we must ensure that - -- the context for (f x) is not totally uninteresting. - -interestingArgContext :: [CoreRule] -> SimplCont -> Bool --- If the argument has form (f x y), where x,y are boring, --- and f is marked INLINE, then we don't want to inline f. --- But if the context of the argument is --- g (f x y) --- where g has rules, then we *do* want to inline f, in case it --- exposes a rule that might fire. Similarly, if the context is --- h (g (f x x)) --- where h has rules, then we do want to inline f; hence the --- call_cont argument to interestingArgContext --- --- The ai-rules flag makes this happen; if it's --- set, the inliner gets just enough keener to inline f --- regardless of how boring f's arguments are, if it's marked INLINE --- --- The alternative would be to *always* inline an INLINE function, --- regardless of how boring its context is; but that seems overkill --- For example, it'd mean that wrapper functions were always inlined --- --- The call_cont passed to interestingArgContext is the context of --- the call itself, e.g. g in the example above -interestingArgContext rules call_cont - = notNull rules || enclosing_fn_has_rules - where - enclosing_fn_has_rules = go call_cont - - go (Select {}) = False - go (ApplyToVal {}) = False -- Shouldn't really happen - go (ApplyToTy {}) = False -- Ditto - go (StrictArg { sc_fun = fun }) = ai_encl fun - go (StrictBind {}) = False -- ?? - go (CastIt _ c) = go c - go (Stop _ RuleArgCtxt) = True - go (Stop _ _) = False - go (TickIt _ c) = go c - -{- Note [Interesting arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An argument is interesting if it deserves a discount for unfoldings -with a discount in that argument position. The idea is to avoid -unfolding a function that is applied only to variables that have no -unfolding (i.e. they are probably lambda bound): f x y z There is -little point in inlining f here. - -Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But -we must look through lets, eg (let x = e in C a b), because the let will -float, exposing the value, if we inline. That makes it different to -exprIsHNF. - -Before 2009 we said it was interesting if the argument had *any* structure -at all; i.e. (hasSomeUnfolding v). But does too much inlining; see #3016. - -But we don't regard (f x y) as interesting, unless f is unsaturated. -If it's saturated and f hasn't inlined, then it's probably not going -to now! - -Note [Conlike is interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f d = ...((*) d x y)... - ... f (df d')... -where df is con-like. Then we'd really like to inline 'f' so that the -rule for (*) (df d) can fire. To do this - a) we give a discount for being an argument of a class-op (eg (*) d) - b) we say that a con-like argument (eg (df d)) is interesting --} - -interestingArg :: SimplEnv -> CoreExpr -> ArgSummary --- See Note [Interesting arguments] -interestingArg env e = go env 0 e - where - -- n is # value args to which the expression is applied - go env n (Var v) - = case substId env v of - DoneId v' -> go_var n v' - DoneEx e _ -> go (zapSubstEnv env) n e - ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e - - go _ _ (Lit l) - | isLitRubbish l = TrivArg -- Leads to unproductive inlining in WWRec, #20035 - | otherwise = ValueArg - go _ _ (Type _) = TrivArg - go _ _ (Coercion _) = TrivArg - go env n (App fn (Type _)) = go env n fn - go env n (App fn _) = go env (n+1) fn - go env n (Tick _ a) = go env n a - go env n (Cast e _) = go env n e - go env n (Lam v e) - | isTyVar v = go env n e - | n>0 = NonTrivArg -- (\x.b) e is NonTriv - | otherwise = ValueArg - go _ _ (Case {}) = NonTrivArg - go env n (Let b e) = case go env' n e of - ValueArg -> ValueArg - _ -> NonTrivArg - where - 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) - -{- -************************************************************************ -* * - SimplMode -* * -************************************************************************ - -The SimplMode controls several switches; see its definition in -GHC.Core.Opt.Monad - sm_rules :: Bool -- Whether RULES are enabled - sm_inline :: Bool -- Whether inlining is enabled - sm_case_case :: Bool -- Whether case-of-case is enabled - sm_eta_expand :: Bool -- Whether eta-expansion is enabled --} - -simplEnvForGHCi :: Logger -> DynFlags -> SimplEnv -simplEnvForGHCi logger dflags - = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] - , sm_phase = InitialPhase - , sm_logger = logger - , sm_dflags = dflags - , sm_uf_opts = uf_opts - , sm_rules = rules_on - , sm_inline = False - -- Do not do any inlining, in case we expose some - -- unboxed tuple stuff that confuses the bytecode - -- interpreter - , sm_eta_expand = eta_expand_on - , sm_cast_swizzle = True - , sm_case_case = True - , sm_pre_inline = pre_inline_on - } - where - rules_on = gopt Opt_EnableRewriteRules dflags - eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags - pre_inline_on = gopt Opt_SimplPreInlining dflags - uf_opts = unfoldingOpts dflags - -updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode -updModeForStableUnfoldings unf_act current_mode - = current_mode { sm_phase = phaseFromActivation unf_act - , sm_eta_expand = False - , sm_inline = True } - -- sm_phase: see Note [Simplifying inside stable unfoldings] - -- sm_eta_expand: see Note [Eta-expansion in stable unfoldings] - -- sm_rules: just inherit; sm_rules might be "off" - -- because of -fno-enable-rewrite-rules - where - phaseFromActivation (ActiveAfter _ n) = Phase n - phaseFromActivation _ = InitialPhase - -updModeForRules :: SimplMode -> SimplMode --- See Note [Simplifying rules] -updModeForRules current_mode - = current_mode { sm_phase = InitialPhase - , sm_inline = False - -- See Note [Do not expose strictness if sm_inline=False] - , sm_rules = False - , sm_cast_swizzle = False - -- See Note [Cast swizzling on rule LHSs] - , sm_eta_expand = False } - -{- Note [Simplifying rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When simplifying a rule LHS, refrain from /any/ inlining or applying -of other RULES. - -Doing anything to the LHS is plain confusing, because it means that what the -rule matches is not what the user wrote. c.f. #10595, and #10528. -Moreover, inlining (or applying rules) on rule LHSs risks introducing -Ticks into the LHS, which makes matching trickier. #10665, #10745. - -Doing this to either side confounds tools like HERMIT, which seek to reason -about and apply the RULES as originally written. See #10829. - -There is, however, one case where we are pretty much /forced/ to transform the -LHS of a rule: postInlineUnconditionally. For instance, in the case of - - let f = g @Int in f - -We very much want to inline f into the body of the let. However, to do so (and -be able to safely drop f's binding) we must inline into all occurrences of f, -including those in the LHS of rules. - -This can cause somewhat surprising results; for instance, in #18162 we found -that a rule template contained ticks in its arguments, because -postInlineUnconditionally substituted in a trivial expression that contains -ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for -details. - -Note [Cast swizzling on rule LHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In the LHS of a RULE we may have - (\x. blah |> CoVar cv) -where `cv` is a coercion variable. Critically, we really only want -coercion /variables/, not general coercions, on the LHS of a RULE. So -we don't want to swizzle this to - (\x. blah) |> (Refl xty `FunCo` CoVar cv) -So we switch off cast swizzling in updModeForRules. - -Note [Eta-expansion in stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't do eta-expansion inside stable unfoldings. It's extra work, -and can be expensive (the bizarre T18223 is a case in point). - -See Note [Occurrence analysis for lambda binders] in GHC.Core.Opt.OccurAnal. - -Historical note. There was /previously/ another reason not to do eta -expansion in stable unfoldings. If we have a stable unfolding - - f :: Ord a => a -> IO () - -- Unfolding template - -- = /\a \(d:Ord a) (x:a). bla - -we previously did not want to eta-expand to - - f :: Ord a => a -> IO () - -- Unfolding template - -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co - -because not specialisation of the overloading didn't work properly (#9509). -But now it does: see Note [Account for casts in binding] in GHC.Core.Opt.Specialise - - -Note [Inlining in gentle mode] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Something is inlined if - (i) the sm_inline flag is on, AND - (ii) the thing has an INLINE pragma, AND - (iii) the thing is inlinable in the earliest phase. - -Example of why (iii) is important: - {-# INLINE [~1] g #-} - g = ... - - {-# INLINE f #-} - f x = g (g x) - -If we were to inline g into f's inlining, then an importing module would -never be able to do - f e --> g (g e) ---> RULE fires -because the stable unfolding for f has had g inlined into it. - -On the other hand, it is bad not to do ANY inlining into an -stable unfolding, because then recursive knots in instance declarations -don't get unravelled. - -However, *sometimes* SimplGently must do no call-site inlining at all -(hence sm_inline = False). Before full laziness we must be careful -not to inline wrappers, because doing so inhibits floating - e.g. ...(case f x of ...)... - ==> ...(case (case x of I# x# -> fw x#) of ...)... - ==> ...(case x of I# x# -> case fw x# of ...)... -and now the redex (f x) isn't floatable any more. - -The no-inlining thing is also important for Template Haskell. You might be -compiling in one-shot mode with -O2; but when TH compiles a splice before -running it, we don't want to use -O2. Indeed, we don't want to inline -anything, because the byte-code interpreter might get confused about -unboxed tuples and suchlike. - -Note [Simplifying inside stable unfoldings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must take care with simplification inside stable unfoldings (which come from -INLINE pragmas). - -First, consider the following example - let f = \pq -> BIG - in - let g = \y -> f y y - {-# INLINE g #-} - in ...g...g...g...g...g... -Now, if that's the ONLY occurrence of f, it might be inlined inside g, -and thence copied multiple times when g is inlined. HENCE we treat -any occurrence in a stable unfolding as a multiple occurrence, not a single -one; see OccurAnal.addRuleUsage. - -Second, we do want *do* to some modest rules/inlining stuff in stable -unfoldings, partly to eliminate senseless crap, and partly to break -the recursive knots generated by instance declarations. - -However, suppose we have - {-# INLINE f #-} - f = -meaning "inline f in phases p where activation (p) holds". -Then what inlinings/rules can we apply to the copy of captured in -f's stable unfolding? Our model is that literally is substituted for -f when it is inlined. So our conservative plan (implemented by -updModeForStableUnfoldings) is this: - - ------------------------------------------------------------- - When simplifying the RHS of a stable unfolding, set the phase - to the phase in which the stable unfolding first becomes active - ------------------------------------------------------------- - -That ensures that - - a) Rules/inlinings that *cease* being active before p will - not apply to the stable unfolding, consistent with it being - inlined in its *original* form in phase p. - - b) Rules/inlinings that only become active *after* p will - not apply to the stable unfolding, again to be consistent with - inlining the *original* rhs in phase p. - -For example, - {-# INLINE f #-} - f x = ...g... - - {-# NOINLINE [1] g #-} - g y = ... - - {-# RULE h g = ... #-} -Here we must not inline g into f's RHS, even when we get to phase 0, -because when f is later inlined into some other module we want the -rule for h to fire. - -Similarly, consider - {-# INLINE f #-} - f x = ...g... - - g y = ... -and suppose that there are auto-generated specialisations and a strictness -wrapper for g. The specialisations get activation AlwaysActive, and the -strictness wrapper get activation (ActiveAfter 0). So the strictness -wrepper fails the test and won't be inlined into f's stable unfolding. That -means f can inline, expose the specialised call to g, so the specialisation -rules can fire. - -A note about wrappers -~~~~~~~~~~~~~~~~~~~~~ -It's also important not to inline a worker back into a wrapper. -A wrapper looks like - wraper = inline_me (\x -> ...worker... ) -Normally, the inline_me prevents the worker getting inlined into -the wrapper (initially, the worker's only call site!). But, -if the wrapper is sure to be called, the strictness analyser will -mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf -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* --- are not. A notable example is DFuns, which really we want to --- match in rules like (op dfun) in gentle mode. Another example --- is 'otherwise' which we want exprIsConApp_maybe to be able to --- see very early on -getUnfoldingInRuleMatch env - = (in_scope, id_unf) - where - in_scope = seInScope env - mode = getMode env - id_unf id | unf_is_active id = idUnfolding id - | otherwise = NoUnfolding - unf_is_active id = isActive (sm_phase mode) (idInlineActivation id) - -- When sm_rules was off we used to test for a /stable/ unfolding, - -- but that seems wrong (#20941) - ----------------------- -activeRule :: SimplMode -> Activation -> Bool --- Nothing => No rules at all -activeRule mode - | not (sm_rules mode) = \_ -> False -- Rewriting is off - | otherwise = isActive (sm_phase mode) - -{- -************************************************************************ -* * - preInlineUnconditionally -* * -************************************************************************ - -preInlineUnconditionally -~~~~~~~~~~~~~~~~~~~~~~~~ -@preInlineUnconditionally@ examines a bndr to see if it is used just -once in a completely safe way, so that it is safe to discard the -binding inline its RHS at the (unique) usage site, REGARDLESS of how -big the RHS might be. If this is the case we don't simplify the RHS -first, but just inline it un-simplified. - -This is much better than first simplifying a perhaps-huge RHS and then -inlining and re-simplifying it. Indeed, it can be at least quadratically -better. Consider - - x1 = e1 - x2 = e2[x1] - x3 = e3[x2] - ...etc... - xN = eN[xN-1] - -We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc. -This can happen with cascades of functions too: - - f1 = \x1.e1 - f2 = \xs.e2[f1] - f3 = \xs.e3[f3] - ...etc... - -THE MAIN INVARIANT is this: - - ---- preInlineUnconditionally invariant ----- - IF preInlineUnconditionally chooses to inline x = - THEN doing the inlining should not change the occurrence - info for the free vars of - ---------------------------------------------- - -For example, it's tempting to look at trivial binding like - x = y -and inline it unconditionally. But suppose x is used many times, -but this is the unique occurrence of y. Then inlining x would change -y's occurrence info, which breaks the invariant. It matters: y -might have a BIG rhs, which will now be dup'd at every occurrence of x. - - -Even RHSs labelled InlineMe aren't caught here, because there might be -no benefit from inlining at the call site. - -[Sept 01] Don't unconditionally inline a top-level thing, because that -can simply make a static thing into something built dynamically. E.g. - x = (a,b) - main = \s -> h x - -[Remember that we treat \s as a one-shot lambda.] No point in -inlining x unless there is something interesting about the call site. - -But watch out: if you aren't careful, some useful foldr/build fusion -can be lost (most notably in spectral/hartel/parstof) because the -foldr didn't see the build. Doing the dynamic allocation isn't a big -deal, in fact, but losing the fusion can be. But the right thing here -seems to be to do a callSiteInline based on the fact that there is -something interesting about the call site (it's strict). Hmm. That -seems a bit fragile. - -Conclusion: inline top level things gaily until FinalPhase (the last -phase), at which point don't. - -Note [pre/postInlineUnconditionally in gentle mode] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even in gentle mode we want to do preInlineUnconditionally. The -reason is that too little clean-up happens if you don't inline -use-once things. Also a bit of inlining is *good* for full laziness; -it can expose constant sub-expressions. Example in -spectral/mandel/Mandel.hs, where the mandelset function gets a useful -let-float if you inline windowToViewport - -However, as usual for Gentle mode, do not inline things that are -inactive in the initial stages. See Note [Gentle mode]. - -Note [Stable unfoldings and preInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas! -Example - - {-# INLINE f #-} - f :: Eq a => a -> a - f x = ... - - fInt :: Int -> Int - fInt = f Int dEqInt - - ...fInt...fInt...fInt... - -Here f occurs just once, in the RHS of fInt. But if we inline it there -it might make fInt look big, and we'll lose the opportunity to inline f -at each of fInt's call sites. The INLINE pragma will only inline when -the application is saturated for exactly this reason; and we don't -want PreInlineUnconditionally to second-guess it. A live example is #3736. - c.f. Note [Stable unfoldings and postInlineUnconditionally] - -NB: this only applies for INLINE things. Do /not/ switch off -preInlineUnconditionally for - -* INLINABLE. It just says to GHC "inline this if you like". If there - is a unique occurrence, we want to inline the stable unfolding, not - the RHS. - -* NONLINE[n] just switches off inlining until phase n. We should - respect that, but after phase n, just behave as usual. - -* NoUserInlinePrag. There is no pragma at all. This ends up on wrappers. - (See #18815.) - -Note [Top-level bottoming Ids] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Don't inline top-level Ids that are bottoming, even if they are used just -once, because FloatOut has gone to some trouble to extract them out. -Inlining them won't make the program run faster! - -Note [Do not inline CoVars unconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Coercion variables appear inside coercions, and the RHS of a let-binding -is a term (not a coercion) so we can't necessarily inline the latter in -the former. --} - -preInlineUnconditionally - :: SimplEnv -> TopLevelFlag -> InId - -> InExpr -> StaticEnv -- These two go together - -> Maybe SimplEnv -- Returned env has extended substitution --- Precondition: rhs satisfies the let/app invariant --- See Note [Core let/app invariant] in GHC.Core --- Reason: we don't want to inline single uses, or discard dead bindings, --- for unlifted, side-effect-ful bindings -preInlineUnconditionally env top_lvl bndr rhs rhs_env - | not pre_inline_unconditionally = Nothing - | not active = Nothing - | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids] - | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally] - | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points] - -- in module Exitify - | not (one_occ (idOccInfo bndr)) = Nothing - | not (isStableUnfolding unf) = Just $! (extend_subst_with rhs) - - -- See Note [Stable unfoldings and preInlineUnconditionally] - | not (isInlinePragma inline_prag) - , Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl) - | otherwise = Nothing - where - unf = idUnfolding bndr - extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs) - - one_occ IAmDead = True -- Happens in ((\x.1) v) - one_occ OneOcc{ occ_n_br = 1 - , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase - one_occ OneOcc{ occ_n_br = 1 - , occ_in_lam = IsInsideLam - , occ_int_cxt = IsInteresting } = canInlineInLam rhs - one_occ _ = False - - pre_inline_unconditionally = sm_pre_inline mode - mode = getMode env - active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag) - -- See Note [pre/postInlineUnconditionally in gentle mode] - inline_prag = idInlinePragma bndr - --- Be very careful before inlining inside a lambda, because (a) we must not --- invalidate occurrence information, and (b) we want to avoid pushing a --- single allocation (here) into multiple allocations (inside lambda). --- Inlining a *function* with a single *saturated* call would be ok, mind you. --- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok) --- where --- is_cheap = exprIsCheap rhs --- ok = is_cheap && int_cxt - - -- int_cxt The context isn't totally boring - -- E.g. let f = \ab.BIG in \y. map f xs - -- Don't want to substitute for f, because then we allocate - -- its closure every time the \y is called - -- But: let f = \ab.BIG in \y. map (f y) xs - -- Now we do want to substitute for f, even though it's not - -- saturated, because we're going to allocate a closure for - -- (f y) every time round the loop anyhow. - - -- canInlineInLam => free vars of rhs are (Once in_lam) or Many, - -- so substituting rhs inside a lambda doesn't change the occ info. - -- Sadly, not quite the same as exprIsHNF. - canInlineInLam (Lit _) = True - canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e - canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e - canInlineInLam _ = False - -- not ticks. Counting ticks cannot be duplicated, and non-counting - -- ticks around a Lam will disappear anyway. - - early_phase = sm_phase mode /= FinalPhase - -- If we don't have this early_phase test, consider - -- x = length [1,2,3] - -- The full laziness pass carefully floats all the cons cells to - -- top level, and preInlineUnconditionally floats them all back in. - -- Result is (a) static allocation replaced by dynamic allocation - -- (b) many simplifier iterations because this tickles - -- a related problem; only one inlining per pass - -- - -- On the other hand, I have seen cases where top-level fusion is - -- lost if we don't inline top level thing (e.g. string constants) - -- Hence the test for phase zero (which is the phase for all the final - -- simplifications). Until phase zero we take no special notice of - -- top level things, but then we become more leery about inlining - -- them. - -{- -************************************************************************ -* * - postInlineUnconditionally -* * -************************************************************************ - -postInlineUnconditionally -~~~~~~~~~~~~~~~~~~~~~~~~~ -@postInlineUnconditionally@ decides whether to unconditionally inline -a thing based on the form of its RHS; in particular if it has a -trivial RHS. If so, we can inline and discard the binding altogether. - -NB: a loop breaker has must_keep_binding = True and non-loop-breakers -only have *forward* references. Hence, it's safe to discard the binding - -NOTE: This isn't our last opportunity to inline. We're at the binding -site right now, and we'll get another opportunity when we get to the -occurrence(s) - -Note that we do this unconditional inlining only for trivial RHSs. -Don't inline even WHNFs inside lambdas; doing so may simply increase -allocation when the function is called. This isn't the last chance; see -NOTE above. - -NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why? -Because we don't even want to inline them into the RHS of constructor -arguments. See NOTE above - -NB: At one time even NOINLINE was ignored here: if the rhs is trivial -it's best to inline it anyway. We often get a=E; b=a from desugaring, -with both a and b marked NOINLINE. But that seems incompatible with -our new view that inlining is like a RULE, so I'm sticking to the 'active' -story for now. - -NB: unconditional inlining of this sort can introduce ticks in places that -may seem surprising; for instance, the LHS of rules. See Note [Simplifying -rules] for details. --} - -postInlineUnconditionally - :: SimplEnv -> BindContext - -> OutId -- The binder (*not* a CoVar), including its unfolding - -> OccInfo -- From the InId - -> OutExpr - -> Bool --- Precondition: rhs satisfies the let/app invariant --- See Note [Core let/app 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 - | 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" - | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally] - | 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 - | 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] - - && 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. - - && (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' - - (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 - - 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 - -- create the (dead) let-binding let x = (a,b) in ... - - _ -> 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 = sm_phase (getMode env) - active = isActive phase (idInlineActivation bndr) - -- See Note [pre/postInlineUnconditionally in gentle mode] - -{- Note [Inline small things to avoid creating a thunk] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The point of examining occ_info here is that for *non-values* that -occur outside a lambda, the call-site inliner won't have a chance -(because it doesn't know that the thing only occurs once). The -pre-inliner won't have gotten it either, if the thing occurs in more -than one branch So the main target is things like - - let x = f y in - case v of - True -> case x of ... - False -> case x of ... - -This is very important in practice; e.g. wheel-seive1 doubles -in allocation if you miss this out. And bits of GHC itself start -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 } - -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! - -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). - -So I just set an arbitrary, high limit of 100, to stop any -totally exponential behaviour. - -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). - -Note [Top level and postInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't do postInlineUnconditionally for top-level things (even for -ones that are trivial): - - * Doing so will inline top-level error expressions that have been - carefully floated out by FloatOut. More generally, it might - replace static allocation with dynamic. - - * Even for trivial expressions there's a problem. Consider - {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-} - blah xs = reverse xs - ruggle = sort - In one simplifier pass we might fire the rule, getting - blah xs = ruggle xs - but in *that* simplifier pass we must not do postInlineUnconditionally - on 'ruggle' because then we'll have an unbound occurrence of 'ruggle' - - If the rhs is trivial it'll be inlined by callSiteInline, and then - the binding will be dead and discarded by the next use of OccurAnal - - * There is less point, because the main goal is to get rid of local - bindings used in multiple case branches. - - * The inliner should inline trivial things at call sites anyway. - - * The Id might be exported. We could check for that separately, - but since we aren't going to postInlineUnconditionally /any/ - top-level bindings, we don't need to test. - -Note [Stable unfoldings and postInlineUnconditionally] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Do not do postInlineUnconditionally if the Id has a stable unfolding, -otherwise we lose the unfolding. Example - - -- f has stable unfolding with rhs (e |> co) - -- where 'e' is big - f = e |> co - -Then there's a danger we'll optimise to - - f' = e - f = f' |> co - -and now postInlineUnconditionally, losing the stable unfolding on f. Now f' -won't inline because 'e' is too big. - - c.f. Note [Stable unfoldings and preInlineUnconditionally] - - -************************************************************************ -* * - Rebuilding a lambda -* * -************************************************************************ --} - -mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr --- mkLam tries three things --- a) eta reduction, if that gives a trivial expression --- b) eta expansion [only if there are some value lambdas] --- --- NB: the SimplEnv already includes the [OutBndr] in its in-scope set -mkLam _env [] body _cont - = return body -mkLam env bndrs body cont - = {-#SCC "mkLam" #-} --- pprTrace "mkLam" (ppr bndrs $$ ppr body $$ ppr cont) $ - do { dflags <- getDynFlags - ; mkLam' dflags bndrs body } - where - mode = getMode env - rec_ids = seRecIds env - - mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr - mkLam' dflags bndrs body@(Lam {}) - = mkLam' dflags (bndrs ++ bndrs1) body1 - where - (bndrs1, body1) = collectBinders body - - mkLam' dflags bndrs (Tick t expr) - | tickishFloatable t - = mkTick t <$> mkLam' dflags bndrs expr - - mkLam' dflags bndrs (Cast body co) - | -- Note [Casts and lambdas] - sm_cast_swizzle mode - , not (any bad bndrs) - = do { lam <- mkLam' dflags bndrs body - ; return (mkCast lam (mkPiCos Representational bndrs co)) } - where - co_vars = tyCoVarsOfCo co - bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars - - mkLam' dflags bndrs body - | gopt Opt_DoEtaReduction dflags - , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce rec_ids bndrs body - = do { tick (EtaReduction (head bndrs)) - ; return etad_lam } - - | not (contIsRhs cont) -- See Note [Eta expanding lambdas] - , sm_eta_expand mode - , any isRuntimeVar bndrs - , let body_arity = {-# SCC "eta" #-} exprEtaExpandArity dflags body - , expandableArityType body_arity - = do { tick (EtaExpansion (head bndrs)) - ; let res = {-# SCC "eta3" #-} - mkLams bndrs $ - etaExpandAT in_scope body_arity body - ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body) - , text "after" <+> ppr res]) - ; return res } - - | otherwise - = return (mkLams bndrs body) - where - in_scope = getInScope env -- Includes 'bndrs' - -{- -Note [Eta expanding lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In general we *do* want to eta-expand lambdas. Consider - f (\x -> case x of (a,b) -> \s -> blah) -where 's' is a state token, and hence can be eta expanded. This -showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather -important function! - -The eta-expansion will never happen unless we do it now. (Well, it's -possible that CorePrep will do it, but CorePrep only has a half-baked -eta-expander that can't deal with casts. So it's much better to do it -here.) - -However, when the lambda is let-bound, as the RHS of a let, we have a -better eta-expander (in the form of tryEtaExpandRhs), so we don't -bother to try expansion in mkLam in that case; hence the contIsRhs -guard. - -NB: We check the SimplEnv (sm_eta_expand), not DynFlags. - See Note [Eta-expansion in stable unfoldings] - -Note [Casts and lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - (\x. (\y. e) `cast` g1) `cast` g2 -There is a danger here that the two lambdas look separated, and the -full laziness pass might float an expression to between the two. - -So this equation in mkLam' floats the g1 out, thus: - (\x. e `cast` g1) --> (\x.e) `cast` (tx -> g1) -where x:tx. - -In general, this floats casts outside lambdas, where (I hope) they -might meet and cancel with some other cast: - \x. e `cast` co ===> (\x. e) `cast` (tx -> co) - /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co) - /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co) - (if not (g `in` co)) - -We call this "cast swizzling". It is controlled by sm_cast_swizzle. -See also Note [Cast swizzling on rule LHSs] - -Wrinkles - -* Notice that it works regardless of 'e'. Originally it worked only - if 'e' was itself a lambda, but in some cases that resulted in - fruitless iteration in the simplifier. A good example was when - compiling Text.ParserCombinators.ReadPrec, where we had a definition - like (\x. Get `cast` g) - where Get is a constructor with nonzero arity. Then mkLam eta-expanded - the Get, and the next iteration eta-reduced it, and then eta-expanded - it again. - -* Note also the side condition for the case of coercion binders, namely - not (any bad bndrs). It does not make sense to transform - /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g) - because the latter is not well-kinded. - - -************************************************************************ -* * - Eta expansion -* * -************************************************************************ --} - -tryEtaExpandRhs :: SimplEnv -> OutId -> OutExpr - -> SimplM (ArityType, OutExpr) --- See Note [Eta-expanding at let bindings] --- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then --- (a) rhs' has manifest arity n --- (b) if is_bot is True then rhs' applied to n args is guaranteed bottom -tryEtaExpandRhs env bndr rhs - | Just join_arity <- isJoinId_maybe bndr - = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs - arity_type = mkManifestArityType join_bndrs join_body - ; return (arity_type, rhs) } - -- Note [Do not eta-expand join points] - -- But do return the correct arity and bottom-ness, because - -- these are used to set the bndr's IdInfo (#15517) - -- Note [Invariants on join points] invariant 2b, in GHC.Core - - | sm_eta_expand mode -- Provided eta-expansion is on - , new_arity > old_arity -- And the current manifest arity isn't enough - , want_eta rhs - = do { tick (EtaExpansion bndr) - ; return (arity_type, etaExpandAT in_scope arity_type rhs) } - - | otherwise - = return (arity_type, rhs) - - where - mode = getMode env - in_scope = getInScope env - dflags = sm_dflags mode - old_arity = exprArity rhs - - arity_type = findRhsArity dflags bndr rhs old_arity - `maxWithArity` idCallArity bndr - new_arity = arityTypeArity arity_type - - -- See Note [Which RHSs do we eta-expand?] - want_eta (Cast e _) = want_eta e - want_eta (Tick _ e) = want_eta e - want_eta (Lam b e) | isTyVar b = want_eta e - want_eta (App e a) | exprIsTrivial a = want_eta e - want_eta (Var {}) = False - want_eta (Lit {}) = False - want_eta _ = True -{- - want_eta _ = case arity_type of - ATop (os:_) -> isOneShotInfo os - ATop [] -> False - ABot {} -> True --} - -{- -Note [Eta-expanding at let bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We now eta expand at let-bindings, which is where the payoff comes. -The most significant thing is that we can do a simple arity analysis -(in GHC.Core.Opt.Arity.findRhsArity), which we can't do for free-floating lambdas - -One useful consequence of not eta-expanding lambdas is this example: - genMap :: C a => ... - {-# INLINE genMap #-} - genMap f xs = ... - - myMap :: D a => ... - {-# INLINE myMap #-} - myMap = genMap - -Notice that 'genMap' should only inline if applied to two arguments. -In the stable unfolding for myMap we'll have the unfolding - (\d -> genMap Int (..d..)) -We do not want to eta-expand to - (\d f xs -> genMap Int (..d..) f xs) -because then 'genMap' will inline, and it really shouldn't: at least -as far as the programmer is concerned, it's not applied to two -arguments! - -Note [Which RHSs do we eta-expand?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We don't eta-expand: - -* Trivial RHSs, e.g. f = g - If we eta expand do - f = \x. g x - we'll just eta-reduce again, and so on; so the - simplifier never terminates. - -* PAPs: see Note [Do not eta-expand PAPs] - -What about things like this? - f = case y of p -> \x -> blah - -Here we do eta-expand. This is a change (Jun 20), but if we have -really decided that f has arity 1, then putting that lambda at the top -seems like a Good idea. - -Note [Do not eta-expand PAPs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to have old_arity = manifestArity rhs, which meant that we -would eta-expand even PAPs. But this gives no particular advantage, -and can lead to a massive blow-up in code size, exhibited by #9020. -Suppose we have a PAP - foo :: IO () - foo = returnIO () -Then we can eta-expand to - foo = (\eta. (returnIO () |> sym g) eta) |> g -where - g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #) - -But there is really no point in doing this, and it generates masses of -coercions and whatnot that eventually disappear again. For T9020, GHC -allocated 6.6G before, and 0.8G afterwards; and residency dropped from -1.8G to 45M. - -Moreover, if we eta expand - f = g d ==> f = \x. g d x -that might in turn make g inline (if it has an inline pragma), which -we might not want. After all, INLINE pragmas say "inline only when -saturated" so we don't want to be too gung-ho about saturating! - -But note that this won't eta-expand, say - f = \g -> map g -Does it matter not eta-expanding such functions? I'm not sure. Perhaps -strictness analysis will have less to bite on? - -Note [Do not eta-expand join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Similarly to CPR (see Note [Don't w/w join points for CPR] in -GHC.Core.Opt.WorkWrap), a join point stands well to gain from its outer binding's -eta-expansion, and eta-expanding a join point is fraught with issues like how to -deal with a cast: - - let join $j1 :: IO () - $j1 = ... - $j2 :: Int -> IO () - $j2 n = if n > 0 then $j1 - else ... - - => - - let join $j1 :: IO () - $j1 = (\eta -> ...) - `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) - ~ IO () - $j2 :: Int -> IO () - $j2 n = (\eta -> if n > 0 then $j1 - else ...) - `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ()) - ~ IO () - -The cast here can't be pushed inside the lambda (since it's not casting to a -function type), so the lambda has to stay, but it can't because it contains a -reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather -than try and detect this situation (and whatever other situations crop up!), we -don't bother; again, any surrounding eta-expansion will improve these join -points anyway, since an outer cast can *always* be pushed inside. By the time -CorePrep comes around, the code is very likely to look more like this: - - let join $j1 :: State# RealWorld -> (# State# RealWorld, ()) - $j1 = (...) eta - $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ()) - $j2 = if n > 0 then $j1 - else (...) eta - - -************************************************************************ -* * -\subsection{Floating lets out of big lambdas} -* * -************************************************************************ - -Note [Floating and type abstraction] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this: - x = /\a. C e1 e2 -We'd like to float this to - y1 = /\a. e1 - y2 = /\a. e2 - x = /\a. C (y1 a) (y2 a) -for the usual reasons: we want to inline x rather vigorously. - -You may think that this kind of thing is rare. But in some programs it is -common. For example, if you do closure conversion you might get: - - data a :-> b = forall e. (e -> a -> b) :$ e - - f_cc :: forall a. a :-> a - f_cc = /\a. (\e. id a) :$ () - -Now we really want to inline that f_cc thing so that the -construction of the closure goes away. - -So I have elaborated simplLazyBind to understand right-hand sides that look -like - /\ a1..an. body - -and treat them specially. The real work is done in -GHC.Core.Opt.Simplify.Utils.abstractFloats, but there is quite a bit of plumbing -in simplLazyBind as well. - -The same transformation is good when there are lets in the body: - - /\abc -> let(rec) x = e in b - ==> - let(rec) x' = /\abc -> let x = x' a b c in e - in - /\abc -> let x = x' a b c in b - -This is good because it can turn things like: - - let f = /\a -> letrec g = ... g ... in g -into - letrec g' = /\a -> ... g' a ... - in - let f = /\ a -> g' a - -which is better. In effect, it means that big lambdas don't impede -let-floating. - -This optimisation is CRUCIAL in eliminating the junk introduced by -desugaring mutually recursive definitions. Don't eliminate it lightly! - -[May 1999] If we do this transformation *regardless* then we can -end up with some pretty silly stuff. For example, - - let - st = /\ s -> let { x1=r1 ; x2=r2 } in ... - in .. -becomes - let y1 = /\s -> r1 - y2 = /\s -> r2 - st = /\s -> ...[y1 s/x1, y2 s/x2] - in .. - -Unless the "..." is a WHNF there is really no point in doing this. -Indeed it can make things worse. Suppose x1 is used strictly, -and is of the form - - x1* = case f y of { (a,b) -> e } - -If we abstract this wrt the tyvar we then can't do the case inline -as we would normally do. - -That's why the whole transformation is part of the same process that -floats let-bindings and constructor arguments out of RHSs. In particular, -it is guarded by the doFloatFromRhs call in simplLazyBind. - -Note [Which type variables to abstract over] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Abstract only over the type variables free in the rhs wrt which the -new binding is abstracted. Note that - - * The naive approach of abstracting wrt the - tyvars free in the Id's /type/ fails. Consider: - /\ a b -> let t :: (a,b) = (e1, e2) - x :: a = fst t - in ... - Here, b isn't free in x's type, but we must nevertheless - abstract wrt b as well, because t's type mentions b. - Since t is floated too, we'd end up with the bogus: - poly_t = /\ a b -> (e1, e2) - poly_x = /\ a -> fst (poly_t a *b*) - - * We must do closeOverKinds. Example (#10934): - f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ... - Here we want to float 't', but we must remember to abstract over - 'k' as well, even though it is not explicitly mentioned in the RHS, - otherwise we get - t = /\ (f:k->*) (a:k). AccFailure @ (f a) - which is obviously bogus. - - * We get the variables to abstract over by filtering down the - the main_tvs for the original function, picking only ones - mentioned in the abstracted body. This means: - - they are automatically in dependency order, because main_tvs is - - there is no issue about non-determinism - - we don't gratuitiously change order, which may help (in a tiny - way) with CSE and/or the compiler-debugging experience --} - -abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats - -> OutExpr -> SimplM ([OutBind], OutExpr) -abstractFloats uf_opts top_lvl main_tvs floats body - = assert (notNull body_floats) $ - assert (isNilOL (sfJoinFloats floats)) $ - do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats - ; 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) - = 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 - ; return (subst', NonRec poly_id2 poly_rhs) } - where - rhs' = GHC.Core.Subst.substExpr subst rhs - - -- tvs_here: see Note [Which type variables to abstract over] - tvs_here = filter (`elemVarSet` free_tvs) main_tvs - free_tvs = closeOverKinds $ - exprSomeFreeVars isTyVar rhs' - - abstract subst (Rec prs) - = 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' - | (poly_id, rhs) <- poly_ids `zip` rhss - , let rhs' = GHC.Core.Subst.substExpr subst' rhs ] - ; return (subst', Rec poly_pairs) } - where - (ids,rhss) = unzip prs - -- For a recursive group, it's a bit of a pain to work out the minimal - -- set of tyvars over which to abstract: - -- /\ a b c. let x = ...a... in - -- letrec { p = ...x...q... - -- q = .....p...b... } in - -- ... - -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted - -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'. - -- Since it's a pain, we just use the whole set, which is always safe - -- - -- If you ever want to be more selective, remember this bizarre case too: - -- x::a = x - -- Here, we must abstract 'x' over 'a'. - tvs_here = scopedSort main_tvs - - mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr) - mk_poly1 tvs_here var - = do { uniq <- getUniqueM - ; let poly_name = setNameUnique (idName var) uniq -- Keep same name - poly_ty = mkInfForAllTys tvs_here (idType var) -- But new type of course - poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id - mkLocalId poly_name (idMult var) poly_ty - ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } - -- In the olden days, it was crucial to copy the occInfo of the original var, - -- because we were looking at occurrence-analysed but as yet unsimplified code! - -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking - -- at already simplified code, so it doesn't matter - -- - -- It's even right to retain single-occurrence or dead-var info: - -- Suppose we started with /\a -> let x = E in B - -- where x occurs once in B. Then we transform to: - -- let x' = /\a -> E in /\a -> let x* = x' a in B - -- where x* has an INLINE prag on it. Now, once x* is inlined, - -- the occurrences of x' will be just the occurrences originally - -- pinned on x. - - mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr) - mk_poly2 poly_id tvs_here rhs - = (poly_id `setIdUnfolding` unf, poly_rhs) - where - poly_rhs = mkLams tvs_here rhs - unf = mkUnfolding uf_opts InlineRhs is_top_lvl False poly_rhs Nothing - - -- We want the unfolding. Consider - -- let - -- x = /\a. let y = ... in Just y - -- in body - -- Then we float the y-binding out (via abstractFloats and addPolyBind) - -- but 'x' may well then be inlined in 'body' in which case we'd like the - -- opportunity to inline 'y' too. - -{- -Note [Abstract over coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the -type variable a. Rather than sort this mess out, we simply bale out and abstract -wrt all the type variables if any of them are coercion variables. - - -Historical note: if you use let-bindings instead of a substitution, beware of this: - - -- Suppose we start with: - -- - -- x = /\ a -> let g = G in E - -- - -- Then we'll float to get - -- - -- x = let poly_g = /\ a -> G - -- in /\ a -> let g = poly_g a in E - -- - -- But now the occurrence analyser will see just one occurrence - -- of poly_g, not inside a lambda, so the simplifier will - -- PreInlineUnconditionally poly_g back into g! Badk to square 1! - -- (I used to think that the "don't inline lone occurrences" stuff - -- would stop this happening, but since it's the *only* occurrence, - -- PreInlineUnconditionally kicks in first!) - -- - -- Solution: put an INLINE note on g's RHS, so that poly_g seems - -- to appear many times. (NB: mkInlineMe eliminates - -- such notes on trivial RHSs, so do it manually.) - -************************************************************************ -* * - prepareAlts -* * -************************************************************************ - -prepareAlts tries these things: - -1. filterAlts: eliminate alternatives that cannot match, including - the DEFAULT alternative. Here "cannot match" includes knowledge - from GADTs - -2. refineDefaultAlt: if the DEFAULT alternative can match only one - possible constructor, then make that constructor explicit. - e.g. - case e of x { DEFAULT -> rhs } - ===> - case e of x { (a,b) -> rhs } - where the type is a single constructor type. This gives better code - when rhs also scrutinises x or e. - See CoreUtils Note [Refine DEFAULT case alternatives] - -3. combineIdenticalAlts: combine identical alternatives into a DEFAULT. - See CoreUtils Note [Combine identical alternatives], which also - says why we do this on InAlts not on OutAlts - -4. Returns a list of the constructors that cannot holds in the - DEFAULT alternative (if there is one) - -It's a good idea to do this stuff before simplifying the alternatives, to -avoid simplifying alternatives we know can't happen, and to come up with -the list of constructors that are handled, to put into the IdInfo of the -case binder, for use when simplifying the alternatives. - -Eliminating the default alternative in (1) isn't so obvious, but it can -happen: - -data Colour = Red | Green | Blue - -f x = case x of - Red -> .. - Green -> .. - DEFAULT -> h x - -h y = case y of - Blue -> .. - DEFAULT -> [ case y of ... ] - -If we inline h into f, the default case of the inlined h can't happen. -If we don't notice this, we may end up filtering out *all* the cases -of the inner case y, which give us nowhere to go! - -Note [Shadowing in prepareAlts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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 -substitution twice: disaster (#23012). - -However this does mean that filling in the default alt might be -delayed by a simplifier cycle, because an InId has less info than an -OutId. Test simplCore/should_compile/simpl013 apparently shows this -up, although I'm not sure exactly how.. --} - -prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt]) --- The returned alternatives can be empty, none are possible --- --- Note that case_bndr is an InId; see Note [Shadowing in prepareAlts] -prepareAlts scrut case_bndr alts - | Just (tc, tys) <- splitTyConApp_maybe (idType case_bndr) - = do { us <- getUniquesM - ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts - (yes2, alts2) = refineDefaultAlt us (idMult case_bndr) tc tys idcs1 alts1 - -- The multiplicity on case_bndr's is the multiplicity of the - -- case expression The newly introduced patterns in - -- refineDefaultAlt must be scaled by this multiplicity - (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2 - -- "idcs" stands for "impossible default data constructors" - -- i.e. the constructors that can't match the default case - ; when yes2 $ tick (FillInCaseDefault case_bndr) - ; when yes3 $ tick (AltMerge case_bndr) - ; return (idcs3, alts3) } - - | otherwise -- Not a data type, so nothing interesting happens - = return ([], alts) - where - imposs_cons = case scrut of - Var v -> otherCons (idUnfolding v) - _ -> [] - - -{- -************************************************************************ -* * - mkCase -* * -************************************************************************ - -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 scrutises 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 - True -> True; - False -> False - -and similar friends. - -Note [Scrutinee Constant Folding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - case x op# k# of _ { ===> case x of _ { - a1# -> e1 (a1# inv_op# k#) -> e1 - a2# -> e2 (a2# inv_op# k#) -> e2 - ... ... - DEFAULT -> ed DEFAULT -> ed - - where (x op# k#) inv_op# k# == x - -And similarly for commuted arguments and for some unary operations. - -The purpose of this transformation is not only to avoid an arithmetic -operation at runtime but to allow other transformations to apply in cascade. - -Example with the "Merge Nested Cases" optimization (from #12877): - - main = case t of t0 - 0## -> ... - DEFAULT -> case t0 `minusWord#` 1## of t1 - 0## -> ... - DEFAULT -> case t1 `minusWord#` 1## of t2 - 0## -> ... - DEFAULT -> case t2 `minusWord#` 1## of _ - 0## -> ... - DEFAULT -> ... - - becomes: - - main = case t of _ - 0## -> ... - 1## -> ... - 2## -> ... - 3## -> ... - DEFAULT -> ... - -There are some wrinkles - -* Do not apply caseRules if there is just a single DEFAULT alternative - case e +# 3# of b { DEFAULT -> rhs } - If we applied the transformation here we would (stupidly) get - case a of b' { DEFAULT -> let b = e +# 3# in rhs } - and now the process may repeat, because that let will really - be a case. - -* The type of the scrutinee might change. E.g. - case tagToEnum (x :: Int#) of (b::Bool) - False -> e1 - True -> e2 - ==> - case x of (b'::Int#) - DEFAULT -> e1 - 1# -> e2 - -* The case binder may be used in the right hand sides, so we need - to make a local binding for it, if it is alive. e.g. - case e +# 10# of b - DEFAULT -> blah...b... - 44# -> blah2...b... - ===> - case e of b' - DEFAULT -> let b = b' +# 10# in blah...b... - 34# -> let b = 44# in blah2...b... - - Note that in the non-DEFAULT cases we know what to bind 'b' to, - whereas in the DEFAULT case we must reconstruct the original value. - But NB: we use b'; we do not duplicate 'e'. - -* In dataToTag we might need to make up some fake binders; - see Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold --} - -mkCase, mkCase1, mkCase2, mkCase3 - :: DynFlags - -> OutExpr -> OutId - -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order - -> SimplM OutExpr - --------------------------------------------------- --- 1. Merge Nested Cases --------------------------------------------------- - -mkCase dflags scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) - | gopt Opt_CaseMerge dflags - , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) - <- stripTicksTop tickishFloatable deflt_rhs - , inner_scrut_var == outer_bndr - = 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 dflags scrut outer_bndr alts_ty merged_alts - } - -- Warning: 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 dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts - --------------------------------------------------- --- 2. Eliminate Identity Case --------------------------------------------------- - -mkCase1 _dflags scrut case_bndr _ alts@(Alt _ _ rhs1 : _) -- Identity case - | all identity_alt alts - = do { tick (CaseIdentity case_bndr) - ; return (mkTicks ticks $ re_cast scrut rhs1) } - where - ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) (tail alts) - identity_alt (Alt con args rhs) = check_eq rhs con args - - check_eq (Cast rhs co) con args -- See Note [RHS casts] - = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args - check_eq (Tick t e) alt args - = tickishFloatable t && check_eq e alt args - - check_eq (Lit lit) (LitAlt lit') _ = lit == lit' - check_eq (Var v) _ _ | v == case_bndr = True - check_eq (Var v) (DataAlt con) args - | null arg_tys, null args = v == dataConWorkId con - -- Optimisation only - check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ - mkConApp2 con arg_tys args - check_eq _ _ _ = False - - arg_tys = tyConAppArgs (idType case_bndr) - - -- Note [RHS casts] - -- ~~~~~~~~~~~~~~~~ - -- We've seen this: - -- case e of x { _ -> x `cast` c } - -- And we definitely want to eliminate this case, to give - -- e `cast` c - -- So we throw away the cast from the RHS, and reconstruct - -- it at the other end. All the RHS casts must be the same - -- if (all identity_alt alts) holds. - -- - -- Don't worry about nested casts, because the simplifier combines them - - re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co - re_cast scrut _ = scrut - -mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts - --------------------------------------------------- --- 2. Scrutinee Constant Folding --------------------------------------------------- - -mkCase2 dflags scrut bndr alts_ty alts - | -- See Note [Scrutinee Constant Folding] - case alts of -- Not if there is just a DEFAULT alternative - [Alt DEFAULT _ _] -> False - _ -> True - , gopt Opt_CaseFolding dflags - , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut - = do { bndr' <- newId (fsLit "lwild") Many (exprType scrut') - - ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts - -- mapMaybeM: discard unreachable alternatives - -- See Note [Unreachable caseRules alternatives] - -- in GHC.Core.Opt.ConstantFold - - ; mkCase3 dflags scrut' bndr' alts_ty $ - add_default (re_sort alts') - } - - | otherwise - = mkCase3 dflags scrut bndr alts_ty alts - where - -- We need to keep the correct association between the scrutinee and its - -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with - -- "let bndr = ... in": - -- - -- case v + 10 of y =====> case v of y - -- 20 -> e1 10 -> let y = 20 in e1 - -- DEFAULT -> e2 DEFAULT -> let y = v + 10 in e2 - -- - -- Other transformations give: =====> case v of y' - -- 10 -> let y = 20 in e1 - -- DEFAULT -> let y = y' + 10 in e2 - -- - -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules, - -- to construct an expression equivalent to the original one, for use - -- in the DEFAULT case - - tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id - -> CoreAlt -> SimplM (Maybe CoreAlt) - tx_alt tx_con mk_orig new_bndr (Alt con bs rhs) - = case tx_con con of - Nothing -> return Nothing - Just con' -> do { bs' <- mk_new_bndrs new_bndr con' - ; return (Just (Alt con' bs' rhs')) } - where - rhs' | isDeadBinder bndr = rhs - | otherwise = bindNonRec bndr orig_val rhs - - orig_val = case con of - DEFAULT -> mk_orig new_bndr - LitAlt l -> Lit l - DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs - - mk_new_bndrs new_bndr (DataAlt dc) - | not (isNullaryRepDataCon dc) - = -- For non-nullary data cons we must invent some fake binders - -- See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold - do { us <- getUniquesM - ; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc - (tyConAppArgs (idType new_bndr)) - ; return (ex_tvs ++ arg_ids) } - mk_new_bndrs _ _ = return [] - - re_sort :: [CoreAlt] -> [CoreAlt] - -- Sort the alternatives to re-establish - -- GHC.Core Note [Case expression invariants] - re_sort alts = sortBy cmpAlt alts - - add_default :: [CoreAlt] -> [CoreAlt] - -- See Note [Literal cases] - add_default (Alt (LitAlt {}) bs rhs : alts) = Alt DEFAULT bs rhs : alts - add_default alts = alts - -{- Note [Literal cases] -~~~~~~~~~~~~~~~~~~~~~~~ -If we have - case tagToEnum (a ># b) of - False -> e1 - True -> e2 - -then caseRules for TagToEnum will turn it into - case tagToEnum (a ># b) of - 0# -> e1 - 1# -> e2 - -Since the case is exhaustive (all cases are) we can convert it to - case tagToEnum (a ># b) of - DEFAULT -> e1 - 1# -> e2 - -This may generate sligthtly better code (although it should not, since -all cases are exhaustive) and/or optimise better. I'm not certain that -it's necessary, but currently we do make this change. We do it here, -NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum] -in GHC.Core.Opt.ConstantFold) --} - --------------------------------------------------- --- Catch-all --------------------------------------------------- -mkCase3 _dflags scrut bndr alts_ty alts + rebuildLam, mkCase, prepareAlts, + tryEtaExpandRhs, wantEtaExpansion, + + -- Inlining, + preInlineUnconditionally, postInlineUnconditionally, + activeUnfolding, activeRule, + getUnfoldingInRuleMatch, + updModeForStableUnfoldings, updModeForRules, + + -- The BindContext type + BindContext(..), bindContextLevel, + + -- The continuation type + SimplCont(..), DupFlag(..), StaticEnv, + isSimplified, contIsStop, + contIsDupable, contResultType, contHoleType, contHoleScaling, + contIsTrivial, contArgs, contIsRhs, + countArgs, + mkBoringStop, mkRhsStop, mkLazyArgStop, + interestingCallContext, + + -- ArgInfo + ArgInfo(..), ArgSpec(..), RewriteCall(..), mkArgInfo, + addValArgTo, addCastTo, addTyArgTo, + argInfoExpr, argInfoAppArgs, + pushSimplifiedArgs, pushSimplifiedRevArgs, + isStrictArgInfo, lazyArgContext, + + abstractFloats, + + -- Utilities + isExitJoinId + ) where + +import GHC.Prelude hiding (head, init, last, tail) + +import GHC.Core +import GHC.Types.Literal ( isLitRubbish ) +import GHC.Core.Opt.Simplify.Env +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 +import GHC.Core.Opt.Simplify.Monad +import GHC.Core.Type hiding( substTy ) +import GHC.Core.Coercion hiding( substCo ) +import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) +import GHC.Core.Multiplicity +import GHC.Core.Opt.ConstantFold + +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Tickish +import GHC.Types.Demand +import GHC.Types.Var.Set +import GHC.Types.Basic + +import GHC.Data.OrdList ( isNilOL ) +import GHC.Data.FastString ( fsLit ) + +import GHC.Utils.Misc +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 ) + +{- ********************************************************************* +* * + The BindContext type +* * +********************************************************************* -} + +-- What sort of binding is this? A let-binding or a join-binding? +data BindContext + = BC_Let -- A regular let-binding + TopLevelFlag RecFlag + + | BC_Join -- A join point with continuation k + RecFlag -- See Note [Rules and unfolding for join points] + SimplCont -- in GHC.Core.Opt.Simplify + +bindContextLevel :: BindContext -> TopLevelFlag +bindContextLevel (BC_Let top_lvl _) = top_lvl +bindContextLevel (BC_Join {}) = NotTopLevel + +bindContextRec :: BindContext -> RecFlag +bindContextRec (BC_Let _ rec_flag) = rec_flag +bindContextRec (BC_Join rec_flag _) = rec_flag + +isJoinBC :: BindContext -> Bool +isJoinBC (BC_Let {}) = False +isJoinBC (BC_Join {}) = True + + +{- ********************************************************************* +* * + The SimplCont and DupFlag types +* * +************************************************************************ + +A SimplCont allows the simplifier to traverse the expression in a +zipper-like fashion. The SimplCont represents the rest of the expression, +"above" the point of interest. + +You can also think of a SimplCont as an "evaluation context", using +that term in the way it is used for operational semantics. This is the +way I usually think of it, For example you'll often see a syntax for +evaluation context looking like + C ::= [] | C e | case C of alts | C `cast` co +That's the kind of thing we are doing here, and I use that syntax in +the comments. + + +Key points: + * A SimplCont describes a *strict* context (just like + evaluation contexts do). E.g. Just [] is not a SimplCont + + * A SimplCont describes a context that *does not* bind + any variables. E.g. \x. [] is not a SimplCont +-} + +data SimplCont + = Stop -- ^ Stop[e] = e + OutType -- ^ Type of the + CallCtxt -- ^ Tells if there is something interesting about + -- the syntactic context, and hence the inliner + -- should be a bit keener (see interestingCallContext) + -- Specifically: + -- This is an argument of a function that has RULES + -- Inlining the call might allow the rule to fire + -- Never ValAppCxt (use ApplyToVal instead) + -- or CaseCtxt (use Select instead) + SubDemand -- ^ The evaluation context of e. Tells how e is evaluated. + -- This fuels eta-expansion or eta-reduction without looking + -- at lambda bodies, for example. + -- + -- See Note [Eta reduction based on evaluation context] + -- The evaluation context for other SimplConts can be + -- reconstructed with 'contEvalContext' + + + | CastIt -- (CastIt co K)[e] = K[ e `cast` co ] + OutCoercion -- The coercion simplified + -- Invariant: never an identity coercion + SimplCont + + | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) + -- See Note [The hole type in ApplyToTy] + , sc_arg :: InExpr -- The argument, + , sc_env :: StaticEnv -- see Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] + { sc_arg_ty :: OutType -- Argument type + , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) + -- See Note [The hole type in ApplyToTy] + , sc_cont :: SimplCont } + + | Select -- (Select alts K)[e] = K[ case e of alts ] + { sc_dup :: DupFlag -- See Note [DupFlag invariants] + , sc_bndr :: InId -- case binder + , sc_alts :: [InAlt] -- Alternatives + , sc_env :: StaticEnv -- See Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + -- The two strict forms have no DupFlag, because we never duplicate them + | 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_body :: InExpr + , sc_env :: StaticEnv -- See Note [StaticEnv invariant] + , sc_cont :: SimplCont } + + | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] + { sc_dup :: DupFlag -- Always Simplified or OkToDup + , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc + -- plus demands and discount flags for *this* arg + -- and further args + -- So ai_dmds and ai_discs are never empty + , sc_fun_ty :: OutType -- Type of the function (f e1 .. en), + -- presumably (arg_ty -> res_ty) + -- where res_ty is expected by sc_cont + , sc_cont :: SimplCont } + + | TickIt -- (TickIt t K)[e] = K[ tick t e ] + CoreTickish -- Tick tickish + SimplCont + +type StaticEnv = SimplEnv -- Just the static part is relevant + +-- See Note [DupFlag invariants] +data DupFlag = NoDup -- Unsimplified, might be big + | Simplified -- Simplified + | OkToDup -- Simplified and small + +isSimplified :: DupFlag -> Bool +isSimplified NoDup = False +isSimplified _ = True -- Invariant: the subst-env is empty + +perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type +perhapsSubstTy dup env ty + | isSimplified dup = ty + | otherwise = substTy env ty + +{- Note [StaticEnv invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pair up an InExpr or InAlts with a StaticEnv, which establishes the +lexical scope for that InExpr. + +When we simplify that InExpr/InAlts, we use + - Its captured StaticEnv + - Overriding its InScopeSet with the larger one at the + simplification point. + +Why override the InScopeSet? Example: + (let y = ey in f) ex +By the time we simplify ex, 'y' will be in scope. + +However the InScopeSet in the StaticEnv is not irrelevant: it should +include all the free vars of applying the substitution to the InExpr. +Reason: contHoleType uses perhapsSubstTy to apply the substitution to +the expression, and that (rightly) gives ASSERT failures if the InScopeSet +isn't big enough. + +Note [DupFlag invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In both ApplyToVal { se_dup = dup, se_env = env, se_cont = k} + and Select { se_dup = dup, se_env = env, se_cont = k} +the following invariants hold + + (a) if dup = OkToDup, then continuation k is also ok-to-dup + (b) if dup = OkToDup or Simplified, the subst-env is empty, + or at least is always ignored; the payload is + already an OutThing +-} + +instance Outputable DupFlag where + ppr OkToDup = text "ok" + ppr NoDup = text "nodup" + ppr Simplified = text "simpl" + +instance Outputable SimplCont where + ppr (Stop ty interesting eval_sd) + = 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 (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) + 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 }) + = (text "Select" <+> ppr dup <+> ppr bndr) $$ + whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont + + +{- Note [The hole type in ApplyToTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The sc_hole_ty field of ApplyToTy records the type of the "hole" in the +continuation. It is absolutely necessary to compute contHoleType, but it is +not used for anything else (and hence may not be evaluated). + +Why is it necessary for contHoleType? Consider the continuation + ApplyToType Int (Stop Int) +corresponding to + ( @Int) :: Int +What is the type of ? It could be (forall a. Int) or (forall a. a), +and there is no way to know which, so we must record it. + +In a chain of applications (f @t1 @t2 @t3) we'll lazily compute exprType +for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably +doesn't matter because we'll never compute them all. + +************************************************************************ +* * + ArgInfo and ArgSpec +* * +************************************************************************ +-} + +data ArgInfo + = 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 + + ai_encl :: Bool, -- Flag saying whether this function + -- or an enclosing one has rules (recursively) + -- True => be keener to inline in all args + + ai_dmds :: [Demand], -- Demands on remaining value arguments (beyond ai_args) + -- Usually infinite, but if it is finite it guarantees + -- that the function diverges after being given + -- that number of args + + ai_discs :: [Int] -- Discounts for remaining value arguments (beyond ai_args) + -- non-zero => be keener to inline + -- 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 + , as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2) + + | 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 }) + = text "ArgInfo" <+> braces + (sep [ text "fun =" <+> ppr fun + , text "dmds(first 10) =" <+> ppr (take 10 dmds) + , text "args =" <+> ppr args ]) + +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 + -- 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 } + | 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) } + 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 + +pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont +pushSimplifiedArg _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont + = ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont } +pushSimplifiedArg env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont + = 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 + +argInfoExpr :: OutId -> [ArgSpec] -> OutExpr +-- NB: the [ArgSpec] is reversed so that the first arg +-- in the list is the last one in the application +argInfoExpr fun rev_args + = go rev_args + where + 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 + +{- +************************************************************************ +* * + Functions on SimplCont +* * +************************************************************************ +-} + +mkBoringStop :: OutType -> SimplCont +mkBoringStop ty = Stop ty BoringCtxt topSubDmd + +mkRhsStop :: OutType -> RecFlag -> Demand -> SimplCont +-- See Note [RHS of lets] in GHC.Core.Unfold +mkRhsStop ty is_rec bndr_dmd = Stop ty (RhsCtxt is_rec) (subDemandIfEvaluated bndr_dmd) + +mkLazyArgStop :: OutType -> ArgInfo -> SimplCont +mkLazyArgStop ty fun_info = Stop ty (lazyArgContext fun_info) arg_sd + where + arg_sd = subDemandIfEvaluated (Partial.head (ai_dmds fun_info)) + +------------------- +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 _ = Nothing + +------------------- +contIsStop :: SimplCont -> Bool +contIsStop (Stop {}) = True +contIsStop _ = False + +contIsDupable :: SimplCont -> Bool +contIsDupable (Stop {}) = True +contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k +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 _ = False + +------------------- +contIsTrivial :: SimplCont -> Bool +contIsTrivial (Stop {}) = True +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 _ = False + +------------------- +contResultType :: SimplCont -> OutType +contResultType (Stop ty _ _) = ty +contResultType (CastIt _ k) = contResultType k +contResultType (StrictBind { sc_cont = k }) = contResultType k +contResultType (StrictArg { sc_cont = k }) = contResultType k +contResultType (Select { sc_cont = k }) = contResultType k +contResultType (ApplyToTy { sc_cont = k }) = contResultType k +contResultType (ApplyToVal { sc_cont = k }) = contResultType k +contResultType (TickIt _ k) = contResultType k + +contHoleType :: SimplCont -> OutType +contHoleType (Stop ty _ _) = ty +contHoleType (TickIt _ k) = contHoleType k +contHoleType (CastIt 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 +contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] +contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] +contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) + = perhapsSubstTy d se (idType b) + + +-- Computes the multiplicity scaling factor at the hole. That is, in (case [] of +-- x ::(p) _ { … }) (respectively for arguments of functions), the scaling +-- factor is p. And in E[G[]], the scaling factor is the product of the scaling +-- factor of E and that of G. +-- +-- The scaling factor at the hole of E[] is used to determine how a binder +-- should be scaled if it commutes with E. This appears, in particular, in the +-- case-of-case transformation. +contHoleScaling :: SimplCont -> Mult +contHoleScaling (Stop _ _ _) = OneTy +contHoleScaling (CastIt _ k) = contHoleScaling k +contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) + = idMult id `mkMultMul` contHoleScaling k +contHoleScaling (Select { sc_bndr = id, sc_cont = k }) + = idMult id `mkMultMul` contHoleScaling k +contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k }) + = w `mkMultMul` contHoleScaling k + where + (w, _, _) = splitFunTy fun_ty +contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k +contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k +contHoleScaling (TickIt _ k) = contHoleScaling k + +------------------- +countArgs :: SimplCont -> Int +-- Count all arguments, including types, coercions, +-- 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 _ = 0 + +countValArgs :: SimplCont -> Int +-- Count value arguments only +countValArgs (ApplyToTy { sc_cont = cont }) = 1 + countValArgs cont +countValArgs (ApplyToVal { sc_cont = cont }) = 1 + countValArgs cont +countValArgs (CastIt _ cont) = countValArgs cont +countValArgs _ = 0 + +------------------- +contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont) +-- Summarises value args, discards type args and coercions +-- The returned continuation of the call is only used to +-- answer questions like "are you interesting?" +contArgs cont + | lone cont = (True, [], cont) + | otherwise = go [] cont + where + lone (ApplyToTy {}) = False -- See Note [Lone variables] in GHC.Core.Unfold + lone (ApplyToVal {}) = False -- NB: even a type application or cast + lone (CastIt {}) = False -- stops it being "lone" + lone _ = True + + 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 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 + +-- | 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 +-- 'SubDemand'. +-- For example, when simplifying the argument `e` in `f e` and `f` has the +-- demand signature ``, this function will give you back `P(S,A)` when +-- simplifying `e`. +-- +-- PRECONDITION: Don't call with 'ApplyToVal'. We haven't thoroughly thought +-- 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 + -- ApplyToVal{sc_cont=k} -> mkCalledOnceDmd $ contEvalContext k + -- Not 100% sure that's correct, . Here's an example: + -- f (e x) and f :: + -- then what is the evaluation context of 'e' when we simplify it? E.g., + -- simpl e (ApplyToVal x $ Stop "C(S,C(1,L))") + -- then it *should* be "C(1,C(S,C(1,L))", so perhaps correct after all. + -- But for now we just panic: + ApplyToVal{} -> pprPanic "contEvalContext" (ppr k) + StrictArg{sc_fun=fun_info} -> subDemandIfEvaluated (Partial.head (ai_dmds fun_info)) + StrictBind{sc_bndr=bndr} -> subDemandIfEvaluated (idDemandInfo bndr) + Select{} -> topSubDmd + -- Perhaps reconstruct the demand on the scrutinee by looking at field + -- and case binder dmds, see addCaseBndrDmd. No priority right now. + +------------------- +mkArgInfo :: SimplEnv -> RuleEnv -> Id -> SimplCont -> ArgInfo + +mkArgInfo env rule_base fun cont + | n_val_args < idArity fun -- Note [Unsaturated functions] + = ArgInfo { ai_fun = fun, ai_args = [] + , ai_rewrite = fun_rewrite + , ai_encl = False + , ai_dmds = vanilla_dmds + , ai_discs = vanilla_discounts } + | otherwise + = ArgInfo { ai_fun = fun + , ai_args = [] + , ai_rewrite = fun_rewrite + , 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 + + vanilla_discounts, arg_discounts :: [Int] + vanilla_discounts = repeat 0 + arg_discounts = case idUnfolding fun of + CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}} + -> discounts ++ vanilla_discounts + _ -> vanilla_discounts + + vanilla_dmds, arg_dmds :: [Demand] + vanilla_dmds = repeat topDmd + + arg_dmds + | not (seInline env) + = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False] + | otherwise + = -- add_type_str fun_ty $ + case splitDmdSig (idDmdSig fun) of + (demands, result_info) + | not (demands `lengthExceeds` n_val_args) + -> -- Enough args, use the strictness given. + -- For bottoming functions we used to pretend that the arg + -- is lazy, so that we don't treat the arg as an + -- interesting context. This avoids substituting + -- top-level bindings for (say) strings into + -- calls to error. But now we are more careful about + -- inlining lone variables, so its ok + -- (see GHC.Core.Op.Simplify.Utils.analyseCont) + if isDeadEndDiv result_info then + demands -- Finite => result is bottom + else + demands ++ vanilla_dmds + | otherwise + -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun) + <+> ppr n_val_args <+> ppr demands) $ + vanilla_dmds -- Not enough args, or no strictness + + add_type_strictness :: Type -> [Demand] -> [Demand] + -- If the function arg types are strict, record that in the 'strictness bits' + -- No need to instantiate because unboxed types (which dominate the strict + -- types) can't instantiate type variables. + -- add_type_strictness is done repeatedly (for each call); + -- might be better once-for-all in the function + -- But beware primops/datacons with no strictness + + add_type_strictness fun_ty dmds + | null dmds = [] + + | Just (_, fun_ty') <- splitForAllTyCoVar_maybe fun_ty + = add_type_strictness fun_ty' dmds -- Look through foralls + + | 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 + = strictifyDmd dmd + | otherwise + -- Something that's not definitely unlifted. + -- If the type is representation-polymorphic, we can't know whether + -- it's strict. + = dmd + = dmd' : add_type_strictness fun_ty' rest_dmds + + | otherwise + = dmds + +{- Note [Unsaturated functions] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (test eyeball/inline4) + x = a:as + y = f x +where f has arity 2. Then we do not want to inline 'x', because +it'll just be floated out again. Even if f has lots of discounts +on its first argument -- it must be saturated for these to kick in + +Note [Do not expose strictness if sm_inline=False] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#15163 showed a case in which we had + + {-# INLINE [1] zip #-} + zip = undefined + + {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-} + +If we expose zip's bottoming nature when simplifying the LHS of the +RULE we get + {-# RULES "foo" forall as bs. + stream (case zip of {}) = ..blah... #-} +discarding the arguments to zip. Usually this is fine, but on the +LHS of a rule it's not, because 'as' and 'bs' are now not bound on +the LHS. + +This is a pretty pathological example, so I'm not losing sleep over +it, but the simplest solution was to check sm_inline; if it is False, +which it is on the LHS of a rule (see updModeForRules), then don't +make use of the strictness info for the function. +-} + + +{- +************************************************************************ +* * + Interesting arguments +* * +************************************************************************ + +Note [Interesting call context] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to avoid inlining an expression where there can't possibly be +any gain, such as in an argument position. Hence, if the continuation +is interesting (eg. a case scrutinee that isn't just a seq, application etc.) +then we inline, otherwise we don't. + +Previously some_benefit used to return True only if the variable was +applied to some value arguments. This didn't work: + + let x = _coerce_ (T Int) Int (I# 3) in + case _coerce_ Int (T Int) x of + I# y -> .... + +we want to inline x, but can't see that it's a constructor in a case +scrutinee position, and some_benefit is False. + +Another example: + +dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t) + +.... case dMonadST _@_ x0 of (a,b,c) -> .... + +we'd really like to inline dMonadST here, but we *don't* want to +inline if the case expression is just + + case x of y { DEFAULT -> ... } + +since we can just eliminate this case instead (x is in WHNF). Similar +applies when x is bound to a lambda expression. Hence +contIsInteresting looks for case expressions with just a single +default case. + +Note [No case of case is boring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we see + case f x of + +we'd usually treat the context as interesting, to encourage 'f' to +inline. But if case-of-case is off, it's really not so interesting +after all, because we are unlikely to be able to push the case +expression into the branches of any case in f's unfolding. So, to +reduce unnecessary code expansion, we just make the context look boring. +This made a small compile-time perf improvement in perf/compiler/T6048, +and it looks plausible to me. + +Note [Seq is boring] +~~~~~~~~~~~~~~~~~~~~ +Suppose + f x = case v of + True -> Just x + False -> Just (x-1) + +Now consider these cases: + +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 + 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) + +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 + 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.) + + +Conclusion: if the case expression + * Has a non-dead case-binder + * 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. +-} + +lazyArgContext :: ArgInfo -> CallCtxt +-- Use this for lazy arguments +lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) + | encl_rules = RuleArgCtxt + | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting + +strictArgContext :: ArgInfo -> CallCtxt +strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs }) +-- Use this for strict arguments + | encl_rules = RuleArgCtxt + | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here + | otherwise = RhsCtxt NonRecursive + -- Why RhsCtxt? if we see f (g x), and f is strict, we + -- want to be a bit more eager to inline g, because it may + -- expose an eval (on x perhaps) that can be eliminated or + -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1 + -- It's worth an 18% improvement in allocation for this + -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier' + -- + -- Why NonRecursive? Becuase it's a bit like + -- let a = g x in f a + +interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt +-- See Note [Interesting call context] +interestingCallContext env cont + = interesting cont + where + interesting (Select {sc_alts=alts, sc_bndr=case_bndr}) + | 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] + | otherwise = CaseCtxt + + + interesting (ApplyToVal {}) = ValAppCtxt + -- Can happen if we have (f Int |> co) y + -- If f has an INLINE prag we need to give it some + -- motivation to inline. See Note [Cast then apply] + -- in GHC.Core.Unfold + + interesting (StrictArg { sc_fun = fun }) = strictArgContext fun + interesting (StrictBind {}) = BoringCtxt + interesting (Stop _ cci _) = cci + interesting (TickIt _ k) = interesting k + interesting (ApplyToTy { sc_cont = k }) = interesting k + interesting (CastIt _ 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. + -- x + (y * z) + -- Here the contIsInteresting makes the '*' keener to inline, + -- which in turn exposes a constructor which makes the '+' inline. + -- Assuming that +,* aren't small enough to inline regardless. + -- + -- It's also very important to inline in a strict context for things + -- like + -- foldr k z (f x) + -- Here, the context of (f x) is strict, and if f's unfolding is + -- a build it's *great* to inline it here. So we must ensure that + -- the context for (f x) is not totally uninteresting. + +contHasRules :: SimplCont -> Bool +-- If the argument has form (f x y), where x,y are boring, +-- and f is marked INLINE, then we don't want to inline f. +-- But if the context of the argument is +-- g (f x y) +-- where g has rules, then we *do* want to inline f, in case it +-- exposes a rule that might fire. Similarly, if the context is +-- h (g (f x x)) +-- where h has rules, then we do want to inline f. So contHasRules +-- tries to see if the context of the f-call is a call to a function +-- with rules. +-- +-- The ai_encl flag makes this happen; if it's +-- set, the inliner gets just enough keener to inline f +-- regardless of how boring f's arguments are, if it's marked INLINE +-- +-- The alternative would be to *always* inline an INLINE function, +-- regardless of how boring its context is; but that seems overkill +-- For example, it'd mean that wrapper functions were always inlined +contHasRules cont + = go cont + where + go (ApplyToVal { sc_cont = cont }) = go cont + go (ApplyToTy { sc_cont = cont }) = go cont + go (CastIt _ cont) = go cont + go (StrictArg { sc_fun = fun }) = ai_encl fun + go (Stop _ RuleArgCtxt _) = True + go (TickIt _ c) = go c + go (Select {}) = False + go (StrictBind {}) = False -- ?? + go (Stop _ _ _) = False + +{- Note [Interesting arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An argument is interesting if it deserves a discount for unfoldings +with a discount in that argument position. The idea is to avoid +unfolding a function that is applied only to variables that have no +unfolding (i.e. they are probably lambda bound): f x y z There is +little point in inlining f here. + +Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But +we must look through lets, eg (let x = e in C a b), because the let will +float, exposing the value, if we inline. That makes it different to +exprIsHNF. + +Before 2009 we said it was interesting if the argument had *any* structure +at all; i.e. (hasSomeUnfolding v). But does too much inlining; see #3016. + +But we don't regard (f x y) as interesting, unless f is unsaturated. +If it's saturated and f hasn't inlined, then it's probably not going +to now! + +Note [Conlike is interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f d = ...((*) d x y)... + ... f (df d')... +where df is con-like. Then we'd really like to inline 'f' so that the +rule for (*) (df d) can fire. To do this + a) we give a discount for being an argument of a class-op (eg (*) d) + b) we say that a con-like argument (eg (df d)) is interesting +-} + +interestingArg :: SimplEnv -> CoreExpr -> ArgSummary +-- See Note [Interesting arguments] +interestingArg env e = go env 0 e + where + -- n is # value args to which the expression is applied + go env n (Var v) + = case substId env v of + DoneId v' -> go_var n v' + DoneEx e _ -> go (zapSubstEnv env) n e + ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e + + go _ _ (Lit l) + | isLitRubbish l = TrivArg -- Leads to unproductive inlining in WWRec, #20035 + | otherwise = ValueArg + go _ _ (Type _) = TrivArg + go _ _ (Coercion _) = TrivArg + go env n (App fn (Type _)) = go env n fn + go env n (App fn _) = go env (n+1) fn + go env n (Tick _ a) = go env n a + go env n (Cast e _) = go env n e + go env n (Lam v e) + | isTyVar v = go env n e + | n>0 = NonTrivArg -- (\x.b) e is NonTriv + | otherwise = ValueArg + go _ _ (Case {}) = NonTrivArg + go env n (Let b e) = case go env' n e of + ValueArg -> ValueArg + _ -> NonTrivArg + where + 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) + +{- +************************************************************************ +* * + SimplMode +* * +************************************************************************ +-} + +updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode +-- See Note [The environments of the Simplify pass] +updModeForStableUnfoldings unf_act current_mode + = current_mode { sm_phase = phaseFromActivation unf_act + , sm_eta_expand = False + , sm_inline = True } + -- sm_eta_expand: see Note [Eta expansion in stable unfoldings and rules] + -- sm_rules: just inherit; sm_rules might be "off" + -- because of -fno-enable-rewrite-rules + where + phaseFromActivation (ActiveAfter _ n) = Phase n + phaseFromActivation _ = InitialPhase + +updModeForRules :: SimplMode -> SimplMode +-- See Note [Simplifying rules] +-- See Note [The environments of the Simplify pass] +updModeForRules current_mode + = current_mode { sm_phase = InitialPhase + , sm_inline = False + -- See Note [Do not expose strictness if sm_inline=False] + , sm_rules = False + , sm_cast_swizzle = False + -- See Note [Cast swizzling on rule LHSs] + , sm_eta_expand = False } + +{- Note [Simplifying rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When simplifying a rule LHS, refrain from /any/ inlining or applying +of other RULES. Doing anything to the LHS is plain confusing, because +it means that what the rule matches is not what the user +wrote. c.f. #10595, and #10528. + +* sm_inline, sm_rules: inlining (or applying rules) on rule LHSs risks + introducing Ticks into the LHS, which makes matching + trickier. #10665, #10745. + + Doing this to either side confounds tools like HERMIT, which seek to reason + about and apply the RULES as originally written. See #10829. + + See also Note [Do not expose strictness if sm_inline=False] + +* sm_eta_expand: the template (LHS) of a rule must only mention coercion + /variables/ not arbitrary coercions. See Note [Casts in the template] in + GHC.Core.Rules. Eta expansion can create new coercions; so we switch + it off. + +There is, however, one case where we are pretty much /forced/ to transform the +LHS of a rule: postInlineUnconditionally. For instance, in the case of + + let f = g @Int in f + +We very much want to inline f into the body of the let. However, to do so (and +be able to safely drop f's binding) we must inline into all occurrences of f, +including those in the LHS of rules. + +This can cause somewhat surprising results; for instance, in #18162 we found +that a rule template contained ticks in its arguments, because +postInlineUnconditionally substituted in a trivial expression that contains +ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for +details. + +Note [Cast swizzling on rule LHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the LHS of a RULE we may have + (\x. blah |> CoVar cv) +where `cv` is a coercion variable. Critically, we really only want +coercion /variables/, not general coercions, on the LHS of a RULE. So +we don't want to swizzle this to + (\x. blah) |> (Refl xty `FunCo` CoVar cv) +So we switch off cast swizzling in updModeForRules. + +Note [Eta expansion in stable unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +SPJ Jul 22: whether or not eta-expansion is switched on in a stable +unfolding, or the RHS of a RULE, seems to be a bit moot. But switching +it on adds clutter, so I'm experimenting with switching off +eta-expansion in such places. + +In the olden days, we really /wanted/ to switch it off. + + Old note: If we have a stable unfolding + f :: Ord a => a -> IO () + -- Unfolding template + -- = /\a \(d:Ord a) (x:a). bla + we do not want to eta-expand to + f :: Ord a => a -> IO () + -- Unfolding template + -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co + because now specialisation of the overloading doesn't work properly + (see Note [Specialisation shape] in GHC.Core.Opt.Specialise), #9509. + So we disable eta-expansion in stable unfoldings. + +But this old note is no longer relevant because the specialiser has +improved: see Note [Account for casts in binding] in +GHC.Core.Opt.Specialise. So we seem to have a free choice. + +Note [Inlining in gentle mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Something is inlined if + (i) the sm_inline flag is on, AND + (ii) the thing has an INLINE pragma, AND + (iii) the thing is inlinable in the earliest phase. + +Example of why (iii) is important: + {-# INLINE [~1] g #-} + g = ... + + {-# INLINE f #-} + f x = g (g x) + +If we were to inline g into f's inlining, then an importing module would +never be able to do + f e --> g (g e) ---> RULE fires +because the stable unfolding for f has had g inlined into it. + +On the other hand, it is bad not to do ANY inlining into an +stable unfolding, because then recursive knots in instance declarations +don't get unravelled. + +However, *sometimes* SimplGently must do no call-site inlining at all +(hence sm_inline = False). Before full laziness we must be careful +not to inline wrappers, because doing so inhibits floating + e.g. ...(case f x of ...)... + ==> ...(case (case x of I# x# -> fw x#) of ...)... + ==> ...(case x of I# x# -> case fw x# of ...)... +and now the redex (f x) isn't floatable any more. + +The no-inlining thing is also important for Template Haskell. You might be +compiling in one-shot mode with -O2; but when TH compiles a splice before +running it, we don't want to use -O2. Indeed, we don't want to inline +anything, because the byte-code interpreter might get confused about +unboxed tuples and suchlike. + +Note [Simplifying inside stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must take care with simplification inside stable unfoldings (which come from +INLINE pragmas). + +First, consider the following example + let f = \pq -> BIG + in + let g = \y -> f y y + {-# INLINE g #-} + in ...g...g...g...g...g... +Now, if that's the ONLY occurrence of f, it might be inlined inside g, +and thence copied multiple times when g is inlined. HENCE we treat +any occurrence in a stable unfolding as a multiple occurrence, not a single +one; see OccurAnal.addRuleUsage. + +Second, we do want *do* to some modest rules/inlining stuff in stable +unfoldings, partly to eliminate senseless crap, and partly to break +the recursive knots generated by instance declarations. + +However, suppose we have + {-# INLINE f #-} + f = +meaning "inline f in phases p where activation (p) holds". +Then what inlinings/rules can we apply to the copy of captured in +f's stable unfolding? Our model is that literally is substituted for +f when it is inlined. So our conservative plan (implemented by +updModeForStableUnfoldings) is this: + + ------------------------------------------------------------- + When simplifying the RHS of a stable unfolding, set the phase + to the phase in which the stable unfolding first becomes active + ------------------------------------------------------------- + +That ensures that + + a) Rules/inlinings that *cease* being active before p will + not apply to the stable unfolding, consistent with it being + inlined in its *original* form in phase p. + + b) Rules/inlinings that only become active *after* p will + not apply to the stable unfolding, again to be consistent with + inlining the *original* rhs in phase p. + +For example, + {-# INLINE f #-} + f x = ...g... + + {-# NOINLINE [1] g #-} + g y = ... + + {-# RULE h g = ... #-} +Here we must not inline g into f's RHS, even when we get to phase 0, +because when f is later inlined into some other module we want the +rule for h to fire. + +Similarly, consider + {-# INLINE f #-} + f x = ...g... + + g y = ... +and suppose that there are auto-generated specialisations and a strictness +wrapper for g. The specialisations get activation AlwaysActive, and the +strictness wrapper get activation (ActiveAfter 0). So the strictness +wrepper fails the test and won't be inlined into f's stable unfolding. That +means f can inline, expose the specialised call to g, so the specialisation +rules can fire. + +A note about wrappers +~~~~~~~~~~~~~~~~~~~~~ +It's also important not to inline a worker back into a wrapper. +A wrapper looks like + wraper = inline_me (\x -> ...worker... ) +Normally, the inline_me prevents the worker getting inlined into +the wrapper (initially, the worker's only call site!). But, +if the wrapper is sure to be called, the strictness analyser will +mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf +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* +-- are not. A notable example is DFuns, which really we want to +-- match in rules like (op dfun) in gentle mode. Another example +-- is 'otherwise' which we want exprIsConApp_maybe to be able to +-- see very early on +getUnfoldingInRuleMatch env + = ISE in_scope id_unf + where + in_scope = seInScope env + phase = sePhase env + id_unf = whenActiveUnfoldingFun (isActive phase) + -- When sm_rules was off we used to test for a /stable/ unfolding, + -- but that seems wrong (#20941) + +---------------------- +activeRule :: SimplMode -> Activation -> Bool +-- Nothing => No rules at all +activeRule mode + | not (sm_rules mode) = \_ -> False -- Rewriting is off + | otherwise = isActive (sm_phase mode) + +{- +************************************************************************ +* * + preInlineUnconditionally +* * +************************************************************************ + +preInlineUnconditionally +~~~~~~~~~~~~~~~~~~~~~~~~ +@preInlineUnconditionally@ examines a bndr to see if it is used just +once in a completely safe way, so that it is safe to discard the +binding inline its RHS at the (unique) usage site, REGARDLESS of how +big the RHS might be. If this is the case we don't simplify the RHS +first, but just inline it un-simplified. + +This is much better than first simplifying a perhaps-huge RHS and then +inlining and re-simplifying it. Indeed, it can be at least quadratically +better. Consider + + x1 = e1 + x2 = e2[x1] + x3 = e3[x2] + ...etc... + xN = eN[xN-1] + +We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc. +This can happen with cascades of functions too: + + f1 = \x1.e1 + f2 = \xs.e2[f1] + f3 = \xs.e3[f3] + ...etc... + +THE MAIN INVARIANT is this: + + ---- preInlineUnconditionally invariant ----- + IF preInlineUnconditionally chooses to inline x = + THEN doing the inlining should not change the occurrence + info for the free vars of + ---------------------------------------------- + +For example, it's tempting to look at trivial binding like + x = y +and inline it unconditionally. But suppose x is used many times, +but this is the unique occurrence of y. Then inlining x would change +y's occurrence info, which breaks the invariant. It matters: y +might have a BIG rhs, which will now be dup'd at every occurrence of x. + + +Even RHSs labelled InlineMe aren't caught here, because there might be +no benefit from inlining at the call site. + +[Sept 01] Don't unconditionally inline a top-level thing, because that +can simply make a static thing into something built dynamically. E.g. + x = (a,b) + main = \s -> h x + +[Remember that we treat \s as a one-shot lambda.] No point in +inlining x unless there is something interesting about the call site. + +But watch out: if you aren't careful, some useful foldr/build fusion +can be lost (most notably in spectral/hartel/parstof) because the +foldr didn't see the build. Doing the dynamic allocation isn't a big +deal, in fact, but losing the fusion can be. But the right thing here +seems to be to do a callSiteInline based on the fact that there is +something interesting about the call site (it's strict). Hmm. That +seems a bit fragile. + +Conclusion: inline top level things gaily until FinalPhase (the last +phase), at which point don't. + +Note [pre/postInlineUnconditionally in gentle mode] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even in gentle mode we want to do preInlineUnconditionally. The +reason is that too little clean-up happens if you don't inline +use-once things. Also a bit of inlining is *good* for full laziness; +it can expose constant sub-expressions. Example in +spectral/mandel/Mandel.hs, where the mandelset function gets a useful +let-float if you inline windowToViewport + +However, as usual for Gentle mode, do not inline things that are +inactive in the initial stages. See Note [Gentle mode]. + +Note [Stable unfoldings and preInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas! +Example + + {-# INLINE f #-} + f :: Eq a => a -> a + f x = ... + + fInt :: Int -> Int + fInt = f Int dEqInt + + ...fInt...fInt...fInt... + +Here f occurs just once, in the RHS of fInt. But if we inline it there +it might make fInt look big, and we'll lose the opportunity to inline f +at each of fInt's call sites. The INLINE pragma will only inline when +the application is saturated for exactly this reason; and we don't +want PreInlineUnconditionally to second-guess it. A live example is #3736. + c.f. Note [Stable unfoldings and postInlineUnconditionally] + +NB: this only applies for INLINE things. Do /not/ switch off +preInlineUnconditionally for + +* INLINABLE. It just says to GHC "inline this if you like". If there + is a unique occurrence, we want to inline the stable unfolding, not + the RHS. + +* NONLINE[n] just switches off inlining until phase n. We should + respect that, but after phase n, just behave as usual. + +* NoUserInlinePrag. There is no pragma at all. This ends up on wrappers. + (See #18815.) + +Note [Top-level bottoming Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't inline top-level Ids that are bottoming, even if they are used just +once, because FloatOut has gone to some trouble to extract them out. +Inlining them won't make the program run faster! + +Note [Do not inline CoVars unconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Coercion variables appear inside coercions, and the RHS of a let-binding +is a term (not a coercion) so we can't necessarily inline the latter in +the former. +-} + +preInlineUnconditionally + :: SimplEnv -> TopLevelFlag -> InId + -> InExpr -> StaticEnv -- These two go together + -> Maybe SimplEnv -- Returned env has extended substitution +-- 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 +preInlineUnconditionally env top_lvl bndr rhs rhs_env + | not pre_inline_unconditionally = Nothing + | not active = Nothing + | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids] + | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally] + | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points] + -- in module Exitify + | not (one_occ (idOccInfo bndr)) = Nothing + | not (isStableUnfolding unf) = Just $! (extend_subst_with rhs) + + -- See Note [Stable unfoldings and preInlineUnconditionally] + | not (isInlinePragma inline_prag) + , Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl) + | otherwise = Nothing + where + unf = idUnfolding bndr + extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs) + + one_occ IAmDead = True -- Happens in ((\x.1) v) + one_occ OneOcc{ occ_n_br = 1 + , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase + one_occ OneOcc{ occ_n_br = 1 + , occ_in_lam = IsInsideLam + , occ_int_cxt = IsInteresting } = canInlineInLam rhs + one_occ _ = False + + pre_inline_unconditionally = sePreInline env + active = isActive (sePhase env) (inlinePragmaActivation inline_prag) + -- See Note [pre/postInlineUnconditionally in gentle mode] + inline_prag = idInlinePragma bndr + +-- Be very careful before inlining inside a lambda, because (a) we must not +-- invalidate occurrence information, and (b) we want to avoid pushing a +-- single allocation (here) into multiple allocations (inside lambda). +-- Inlining a *function* with a single *saturated* call would be ok, mind you. +-- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok) +-- where +-- is_cheap = exprIsCheap rhs +-- ok = is_cheap && int_cxt + + -- int_cxt The context isn't totally boring + -- E.g. let f = \ab.BIG in \y. map f xs + -- Don't want to substitute for f, because then we allocate + -- its closure every time the \y is called + -- But: let f = \ab.BIG in \y. map (f y) xs + -- Now we do want to substitute for f, even though it's not + -- saturated, because we're going to allocate a closure for + -- (f y) every time round the loop anyhow. + + -- canInlineInLam => free vars of rhs are (Once in_lam) or Many, + -- so substituting rhs inside a lambda doesn't change the occ info. + -- Sadly, not quite the same as exprIsHNF. + canInlineInLam (Lit _) = True + canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e + canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e + canInlineInLam _ = False + -- not ticks. Counting ticks cannot be duplicated, and non-counting + -- ticks around a Lam will disappear anyway. + + early_phase = sePhase env /= FinalPhase + -- If we don't have this early_phase test, consider + -- x = length [1,2,3] + -- The full laziness pass carefully floats all the cons cells to + -- top level, and preInlineUnconditionally floats them all back in. + -- Result is (a) static allocation replaced by dynamic allocation + -- (b) many simplifier iterations because this tickles + -- a related problem; only one inlining per pass + -- + -- On the other hand, I have seen cases where top-level fusion is + -- lost if we don't inline top level thing (e.g. string constants) + -- Hence the test for phase zero (which is the phase for all the final + -- simplifications). Until phase zero we take no special notice of + -- top level things, but then we become more leery about inlining + -- them. + +{- +************************************************************************ +* * + postInlineUnconditionally +* * +************************************************************************ + +postInlineUnconditionally +~~~~~~~~~~~~~~~~~~~~~~~~~ +@postInlineUnconditionally@ decides whether to unconditionally inline +a thing based on the form of its RHS; in particular if it has a +trivial RHS. If so, we can inline and discard the binding altogether. + +NB: a loop breaker has must_keep_binding = True and non-loop-breakers +only have *forward* references. Hence, it's safe to discard the binding + +NOTE: This isn't our last opportunity to inline. We're at the binding +site right now, and we'll get another opportunity when we get to the +occurrence(s) + +Note that we do this unconditional inlining only for trivial RHSs. +Don't inline even WHNFs inside lambdas; doing so may simply increase +allocation when the function is called. This isn't the last chance; see +NOTE above. + +NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why? +Because we don't even want to inline them into the RHS of constructor +arguments. See NOTE above + +NB: At one time even NOINLINE was ignored here: if the rhs is trivial +it's best to inline it anyway. We often get a=E; b=a from desugaring, +with both a and b marked NOINLINE. But that seems incompatible with +our new view that inlining is like a RULE, so I'm sticking to the 'active' +story for now. + +NB: unconditional inlining of this sort can introduce ticks in places that +may seem surprising; for instance, the LHS of rules. See Note [Simplifying +rules] for details. +-} + +postInlineUnconditionally + :: SimplEnv -> BindContext + -> OutId -- The binder (*not* a CoVar), including its unfolding + -> OccInfo -- From the InId + -> 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 + | 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" + | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally] + | 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 + | 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] + + && 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. + + && (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' + + (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 + + 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 + -- create the (dead) let-binding let x = (a,b) in ... + + _ -> 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) + -- See Note [pre/postInlineUnconditionally in gentle mode] + +{- Note [Inline small things to avoid creating a thunk] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The point of examining occ_info here is that for *non-values* that +occur outside a lambda, the call-site inliner won't have a chance +(because it doesn't know that the thing only occurs once). The +pre-inliner won't have gotten it either, if the thing occurs in more +than one branch So the main target is things like + + let x = f y in + case v of + True -> case x of ... + False -> case x of ... + +This is very important in practice; e.g. wheel-seive1 doubles +in allocation if you miss this out. And bits of GHC itself start +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 } + +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! + +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). + +So I just set an arbitrary, high limit of 100, to stop any +totally exponential behaviour. + +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). + +Note [Top level and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't do postInlineUnconditionally for top-level things (even for +ones that are trivial): + + * Doing so will inline top-level error expressions that have been + carefully floated out by FloatOut. More generally, it might + replace static allocation with dynamic. + + * Even for trivial expressions there's a problem. Consider + {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-} + blah xs = reverse xs + ruggle = sort + In one simplifier pass we might fire the rule, getting + blah xs = ruggle xs + but in *that* simplifier pass we must not do postInlineUnconditionally + on 'ruggle' because then we'll have an unbound occurrence of 'ruggle' + + If the rhs is trivial it'll be inlined by callSiteInline, and then + the binding will be dead and discarded by the next use of OccurAnal + + * There is less point, because the main goal is to get rid of local + bindings used in multiple case branches. + + * The inliner should inline trivial things at call sites anyway. + + * The Id might be exported. We could check for that separately, + but since we aren't going to postInlineUnconditionally /any/ + top-level bindings, we don't need to test. + +Note [Stable unfoldings and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not do postInlineUnconditionally if the Id has a stable unfolding, +otherwise we lose the unfolding. Example + + -- f has stable unfolding with rhs (e |> co) + -- where 'e' is big + f = e |> co + +Then there's a danger we'll optimise to + + f' = e + f = f' |> co + +and now postInlineUnconditionally, losing the stable unfolding on f. Now f' +won't inline because 'e' is too big. + + c.f. Note [Stable unfoldings and preInlineUnconditionally] + + +************************************************************************ +* * + Rebuilding a lambda +* * +************************************************************************ +-} + +rebuildLam :: SimplEnv + -> [OutBndr] -> OutExpr + -> SimplCont + -> SimplM OutExpr +-- (rebuildLam env bndrs body cont) +-- returns expr which means the same as \bndrs. body +-- +-- But it tries +-- a) eta reduction, if that gives a trivial expression +-- b) eta expansion [only if there are some value lambdas] +-- +-- NB: the SimplEnv already includes the [OutBndr] in its in-scope set + +rebuildLam _env [] body _cont + = return body + +rebuildLam env bndrs@(bndr:_) body cont + = {-# SCC "rebuildLam" #-} try_eta bndrs body + where + rec_ids = seRecIds env + in_scope = getInScope env -- Includes 'bndrs' + mb_rhs = contIsRhs cont + + -- See Note [Eta reduction based on evaluation context] + eval_sd = contEvalContext cont + -- NB: cont is never ApplyToVal, because beta-reduction would + -- have happened. So contEvalContext can panic on ApplyToVal. + + try_eta :: [OutBndr] -> OutExpr -> SimplM OutExpr + try_eta bndrs body + | -- Try eta reduction + seDoEtaReduction env + , Just etad_lam <- tryEtaReduce rec_ids bndrs body eval_sd + = do { tick (EtaReduction bndr) + ; return etad_lam } + + | -- Try eta expansion + Nothing <- mb_rhs -- See Note [Eta expanding lambdas] + , seEtaExpand env + , any isRuntimeVar bndrs -- Only when there is at least one value lambda already + , Just body_arity <- exprEtaExpandArity (seArityOpts env) body + = do { tick (EtaExpansion bndr) + ; let body' = etaExpandAT in_scope body_arity body + ; traceSmpl "eta expand" (vcat [text "before" <+> ppr body + , text "after" <+> ppr body']) + -- NB: body' might have an outer Cast, but if so + -- mk_lams will pull it further out, past 'bndrs' to the top + ; return (mk_lams bndrs body') } + + | otherwise + = return (mk_lams bndrs body) + + mk_lams :: [OutBndr] -> OutExpr -> OutExpr + -- mk_lams pulls casts and ticks to the top + mk_lams bndrs body@(Lam {}) + = mk_lams (bndrs ++ bndrs1) body1 + where + (bndrs1, body1) = collectBinders body + + mk_lams bndrs (Tick t expr) + | tickishFloatable t + = mkTick t (mk_lams bndrs expr) + + mk_lams bndrs (Cast body co) + | -- Note [Casts and lambdas] + seCastSwizzle env + , not (any bad bndrs) + = mkCast (mk_lams bndrs body) (mkPiCos Representational bndrs co) + where + co_vars = tyCoVarsOfCo co + bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars + + mk_lams bndrs body + = mkLams bndrs body + +{- +Note [Eta expanding lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we *do* want to eta-expand lambdas. Consider + f (\x -> case x of (a,b) -> \s -> blah) +where 's' is a state token, and hence can be eta expanded. This +showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather +important function! + +The eta-expansion will never happen unless we do it now. (Well, it's +possible that CorePrep will do it, but CorePrep only has a half-baked +eta-expander that can't deal with casts. So it's much better to do it +here.) + +However, when the lambda is let-bound, as the RHS of a let, we have a +better eta-expander (in the form of tryEtaExpandRhs), so we don't +bother to try expansion in mkLam in that case; hence the contIsRhs +guard. + +Note [Casts and lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (\(x:tx). (\(y:ty). e) `cast` co) + +We float the cast out, thus + (\(x:tx) (y:ty). e) `cast` (tx -> co) + +We do this for at least three reasons: + +1. There is a danger here that the two lambdas look separated, and the + full laziness pass might float an expression to between the two. + +2. The occurrence analyser will mark x as InsideLam if the Lam nodes + are separated (see the Lam case of occAnal). By floating the cast + out we put the two Lams together, so x can get a vanilla Once + annotation. If this lambda is the RHS of a let, which we inline, + we can do preInlineUnconditionally on that x=arg binding. With the + InsideLam OccInfo, we can't do that, which results in an extra + iteration of the Simplifier. + +3. It may cancel with another cast. E.g + (\x. e |> co1) |> co2 + If we float out co1 it might cancel with co2. Similarly + let f = (\x. e |> co1) in ... + If we float out co1, and then do cast worker/wrapper, we get + let f1 = \x.e; f = f1 |> co1 in ... + and now we can inline f, hoping that co1 may cancel at a call site. + +TL;DR: put the lambdas together if at all possible. + +In general, here's the transformation: + \x. e `cast` co ===> (\x. e) `cast` (tx -> co) + /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co) + /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co) + (if not (g `in` co)) + +We call this "cast swizzling". It is controlled by sm_cast_swizzle. +See also Note [Cast swizzling on rule LHSs] + +Wrinkles + +* Notice that it works regardless of 'e'. Originally it worked only + if 'e' was itself a lambda, but in some cases that resulted in + fruitless iteration in the simplifier. A good example was when + compiling Text.ParserCombinators.ReadPrec, where we had a definition + like (\x. Get `cast` g) + where Get is a constructor with nonzero arity. Then mkLam eta-expanded + the Get, and the next iteration eta-reduced it, and then eta-expanded + it again. + +* Note also the side condition for the case of coercion binders, namely + not (any bad bndrs). It does not make sense to transform + /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g) + because the latter is not well-kinded. + + +************************************************************************ +* * + Eta expansion +* * +************************************************************************ +-} + +tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr + -> 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. + 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] + do { tick (EtaExpansion bndr) + ; return (arity_type, etaExpandAT in_scope arity_type rhs) } + + | otherwise + = return (arity_type, rhs) + + where + in_scope = getInScope env + arity_opts = seArityOpts env + is_rec = bindContextRec bind_cxt + (do_eta_expand, arity_type) = findRhsArity arity_opts is_rec bndr rhs + +wantEtaExpansion :: CoreExpr -> Bool +-- Mostly True; but False of PAPs which will immediately eta-reduce again +-- See Note [Which RHSs do we eta-expand?] +wantEtaExpansion (Cast e _) = wantEtaExpansion e +wantEtaExpansion (Tick _ e) = wantEtaExpansion e +wantEtaExpansion (Lam b e) | isTyVar b = wantEtaExpansion e +wantEtaExpansion (App e _) = wantEtaExpansion e +wantEtaExpansion (Var {}) = False +wantEtaExpansion (Lit {}) = False +wantEtaExpansion _ = True + +{- +Note [Eta-expanding at let bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We now eta expand at let-bindings, which is where the payoff comes. +The most significant thing is that we can do a simple arity analysis +(in GHC.Core.Opt.Arity.findRhsArity), which we can't do for free-floating lambdas + +One useful consequence of not eta-expanding lambdas is this example: + genMap :: C a => ... + {-# INLINE genMap #-} + genMap f xs = ... + + myMap :: D a => ... + {-# INLINE myMap #-} + myMap = genMap + +Notice that 'genMap' should only inline if applied to two arguments. +In the stable unfolding for myMap we'll have the unfolding + (\d -> genMap Int (..d..)) +We do not want to eta-expand to + (\d f xs -> genMap Int (..d..) f xs) +because then 'genMap' will inline, and it really shouldn't: at least +as far as the programmer is concerned, it's not applied to two +arguments! + +Note [Which RHSs do we eta-expand?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't eta-expand: + +* Trivial RHSs, e.g. f = g + If we eta expand do + f = \x. g x + we'll just eta-reduce again, and so on; so the + simplifier never terminates. + +* PAPs: see Note [Do not eta-expand PAPs] + +What about things like this? + f = case y of p -> \x -> blah + +Here we do eta-expand. This is a change (Jun 20), but if we have +really decided that f has arity 1, then putting that lambda at the top +seems like a Good idea. + +Note [Do not eta-expand PAPs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have old_arity = manifestArity rhs, which meant that we +would eta-expand even PAPs. But this gives no particular advantage, +and can lead to a massive blow-up in code size, exhibited by #9020. +Suppose we have a PAP + foo :: IO () + foo = returnIO () +Then we can eta-expand to + foo = (\eta. (returnIO () |> sym g) eta) |> g +where + g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #) + +But there is really no point in doing this, and it generates masses of +coercions and whatnot that eventually disappear again. For T9020, GHC +allocated 6.6G before, and 0.8G afterwards; and residency dropped from +1.8G to 45M. + +Moreover, if we eta expand + f = g d ==> f = \x. g d x +that might in turn make g inline (if it has an inline pragma), which +we might not want. After all, INLINE pragmas say "inline only when +saturated" so we don't want to be too gung-ho about saturating! + +But note that this won't eta-expand, say + f = \g -> map g +Does it matter not eta-expanding such functions? I'm not sure. Perhaps +strictness analysis will have less to bite on? + + +************************************************************************ +* * +\subsection{Floating lets out of big lambdas} +* * +************************************************************************ + +Note [Floating and type abstraction] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + x = /\a. C e1 e2 +We'd like to float this to + y1 = /\a. e1 + y2 = /\a. e2 + x = /\a. C (y1 a) (y2 a) +for the usual reasons: we want to inline x rather vigorously. + +You may think that this kind of thing is rare. But in some programs it is +common. For example, if you do closure conversion you might get: + + data a :-> b = forall e. (e -> a -> b) :$ e + + f_cc :: forall a. a :-> a + f_cc = /\a. (\e. id a) :$ () + +Now we really want to inline that f_cc thing so that the +construction of the closure goes away. + +So I have elaborated simplLazyBind to understand right-hand sides that look +like + /\ a1..an. body + +and treat them specially. The real work is done in +GHC.Core.Opt.Simplify.Utils.abstractFloats, but there is quite a bit of plumbing +in simplLazyBind as well. + +The same transformation is good when there are lets in the body: + + /\abc -> let(rec) x = e in b + ==> + let(rec) x' = /\abc -> let x = x' a b c in e + in + /\abc -> let x = x' a b c in b + +This is good because it can turn things like: + + let f = /\a -> letrec g = ... g ... in g +into + letrec g' = /\a -> ... g' a ... + in + let f = /\ a -> g' a + +which is better. In effect, it means that big lambdas don't impede +let-floating. + +This optimisation is CRUCIAL in eliminating the junk introduced by +desugaring mutually recursive definitions. Don't eliminate it lightly! + +[May 1999] If we do this transformation *regardless* then we can +end up with some pretty silly stuff. For example, + + let + st = /\ s -> let { x1=r1 ; x2=r2 } in ... + in .. +becomes + let y1 = /\s -> r1 + y2 = /\s -> r2 + st = /\s -> ...[y1 s/x1, y2 s/x2] + in .. + +Unless the "..." is a WHNF there is really no point in doing this. +Indeed it can make things worse. Suppose x1 is used strictly, +and is of the form + + x1* = case f y of { (a,b) -> e } + +If we abstract this wrt the tyvar we then can't do the case inline +as we would normally do. + +That's why the whole transformation is part of the same process that +floats let-bindings and constructor arguments out of RHSs. In particular, +it is guarded by the doFloatFromRhs call in simplLazyBind. + +Note [Which type variables to abstract over] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Abstract only over the type variables free in the rhs wrt which the +new binding is abstracted. Several points worth noting + +(AB1) The naive approach of abstracting wrt the + tyvars free in the Id's /type/ fails. Consider: + /\ a b -> let t :: (a,b) = (e1, e2) + x :: a = fst t + in ... + Here, b isn't free in x's type, but we must nevertheless + abstract wrt b as well, because t's type mentions b. + Since t is floated too, we'd end up with the bogus: + poly_t = /\ a b -> (e1, e2) + poly_x = /\ a -> fst (poly_t a *b*) + +(AB2) We must do closeOverKinds. Example (#10934): + f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ... + Here we want to float 't', but we must remember to abstract over + 'k' as well, even though it is not explicitly mentioned in the RHS, + otherwise we get + t = /\ (f:k->*) (a:k). AccFailure @ (f a) + which is obviously bogus. + +(AB3) We get the variables to abstract over by filtering down the + the main_tvs for the original function, picking only ones + mentioned in the abstracted body. This means: + - they are automatically in dependency order, because main_tvs is + - there is no issue about non-determinism + - we don't gratuitously change order, which may help (in a tiny + way) with CSE and/or the compiler-debugging experience + +(AB4) For a recursive group, it's a bit of a pain to work out the minimal + set of tyvars over which to abstract: + /\ a b c. let x = ...a... in + letrec { p = ...x...q... + q = .....p...b... } in + ... + Since 'x' is abstracted over 'a', the {p,q} group must be abstracted + over 'a' (because x is replaced by (poly_x a)) as well as 'b'. + Remember this bizarre case too: + x::a = x + Here, we must abstract 'x' over 'a'. + + Why is it worth doing this? Partly tidiness; and partly #22459 + 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 +-} + +abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats + -> OutExpr -> SimplM ([OutBind], OutExpr) +abstractFloats uf_opts top_lvl main_tvs floats body + = assert (notNull body_floats) $ + assert (isNilOL (sfJoinFloats floats)) $ + do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats + ; 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) + = 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 + ; return (subst', NonRec poly_id2 poly_rhs) } + where + rhs' = GHC.Core.Subst.substExpr subst rhs + + -- tvs_here: see Note [Which type variables to abstract over] + tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs') + + abstract subst (Rec prs) + = 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' + | (poly_id, rhs) <- poly_ids `zip` rhss + , let rhs' = GHC.Core.Subst.substExpr subst' rhs ] + ; return (subst', Rec poly_pairs) } + where + (ids,rhss) = unzip prs + + + -- tvs_here: see Note [Which type variables to abstract over] + tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs prs) + + -- 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_tvs :: Var -> VarSet -> VarSet + get_tvs var free_tvs + | isTyVar var -- CoVars have been substituted away + = extendVarSet free_tvs var + | Just poly_app <- GHC.Core.Subst.lookupIdSubst_maybe subst var + = -- 'var' is like 'x' in (AB4) + exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs + | otherwise + = free_tvs + + choose_tvs free_tvs + = filter (`elemVarSet` all_free_tvs) main_tvs -- (AB3) + where + all_free_tvs = closeOverKinds free_tvs -- (AB2) + + mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr) + mk_poly1 tvs_here var + = do { uniq <- getUniqueM + ; let poly_name = setNameUnique (idName var) uniq -- Keep same name + poly_ty = mkInfForAllTys tvs_here (idType var) -- But new type of course + poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id + mkLocalId poly_name (idMult var) poly_ty + ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } + -- In the olden days, it was crucial to copy the occInfo of the original var, + -- because we were looking at occurrence-analysed but as yet unsimplified code! + -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking + -- at already simplified code, so it doesn't matter + -- + -- It's even right to retain single-occurrence or dead-var info: + -- Suppose we started with /\a -> let x = E in B + -- where x occurs once in B. Then we transform to: + -- let x' = /\a -> E in /\a -> let x* = x' a in B + -- where x* has an INLINE prag on it. Now, once x* is inlined, + -- the occurrences of x' will be just the occurrences originally + -- pinned on x. + + mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr) + mk_poly2 poly_id tvs_here rhs + = (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 + + -- We want the unfolding. Consider + -- let + -- x = /\a. let y = ... in Just y + -- in body + -- Then we float the y-binding out (via abstractFloats and addPolyBind) + -- but 'x' may well then be inlined in 'body' in which case we'd like the + -- opportunity to inline 'y' too. + +{- +Note [Abstract over coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the +type variable a. Rather than sort this mess out, we simply bale out and abstract +wrt all the type variables if any of them are coercion variables. + + +Historical note: if you use let-bindings instead of a substitution, beware of this: + + -- Suppose we start with: + -- + -- x = /\ a -> let g = G in E + -- + -- Then we'll float to get + -- + -- x = let poly_g = /\ a -> G + -- in /\ a -> let g = poly_g a in E + -- + -- But now the occurrence analyser will see just one occurrence + -- of poly_g, not inside a lambda, so the simplifier will + -- PreInlineUnconditionally poly_g back into g! Badk to square 1! + -- (I used to think that the "don't inline lone occurrences" stuff + -- would stop this happening, but since it's the *only* occurrence, + -- PreInlineUnconditionally kicks in first!) + -- + -- Solution: put an INLINE note on g's RHS, so that poly_g seems + -- to appear many times. (NB: mkInlineMe eliminates + -- such notes on trivial RHSs, so do it manually.) + +************************************************************************ +* * + prepareAlts +* * +************************************************************************ + +prepareAlts tries these things: + +1. filterAlts: eliminate alternatives that cannot match, including + the DEFAULT alternative. Here "cannot match" includes knowledge + from GADTs + +2. refineDefaultAlt: if the DEFAULT alternative can match only one + possible constructor, then make that constructor explicit. + e.g. + case e of x { DEFAULT -> rhs } + ===> + case e of x { (a,b) -> rhs } + where the type is a single constructor type. This gives better code + when rhs also scrutinises x or e. + See GHC.Core.Utils Note [Refine DEFAULT case alternatives] + +3. combineIdenticalAlts: combine identical alternatives into a DEFAULT. + See CoreUtils Note [Combine identical alternatives], which also + says why we do this on InAlts not on OutAlts + +4. Returns a list of the constructors that cannot holds in the + DEFAULT alternative (if there is one) + +It's a good idea to do this stuff before simplifying the alternatives, to +avoid simplifying alternatives we know can't happen, and to come up with +the list of constructors that are handled, to put into the IdInfo of the +case binder, for use when simplifying the alternatives. + +Eliminating the default alternative in (1) isn't so obvious, but it can +happen: + +data Colour = Red | Green | Blue + +f x = case x of + Red -> .. + Green -> .. + DEFAULT -> h x + +h y = case y of + Blue -> .. + DEFAULT -> [ case y of ... ] + +If we inline h into f, the default case of the inlined h can't happen. +If we don't notice this, we may end up filtering out *all* the cases +of the inner case y, which give us nowhere to go! + +Note [Shadowing in prepareAlts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 +substitution twice: disaster (#23012). + +However this does mean that filling in the default alt might be +delayed by a simplifier cycle, because an InId has less info than an +OutId. Test simplCore/should_compile/simpl013 apparently shows this +up, although I'm not sure exactly how.. +-} + +prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt]) +-- The returned alternatives can be empty, none are possible +-- +-- Note that case_bndr is an InId; see Note [Shadowing in prepareAlts] +prepareAlts scrut case_bndr alts + | Just (tc, tys) <- splitTyConApp_maybe (idType case_bndr) + = do { us <- getUniquesM + ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts + (yes2, alts2) = refineDefaultAlt us (idMult case_bndr) tc tys idcs1 alts1 + -- The multiplicity on case_bndr's is the multiplicity of the + -- case expression The newly introduced patterns in + -- refineDefaultAlt must be scaled by this multiplicity + (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2 + -- "idcs" stands for "impossible default data constructors" + -- i.e. the constructors that can't match the default case + ; when yes2 $ tick (FillInCaseDefault case_bndr) + ; when yes3 $ tick (AltMerge case_bndr) + ; return (idcs3, alts3) } + + | otherwise -- Not a data type, so nothing interesting happens + = return ([], alts) + where + imposs_cons = case scrut of + Var v -> otherCons (idUnfolding v) + _ -> [] + + +{- +************************************************************************ +* * + mkCase +* * +************************************************************************ + +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 + True -> True; + False -> False + +and similar friends. + +Note [Scrutinee Constant Folding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + case x op# k# of _ { ===> case x of _ { + a1# -> e1 (a1# inv_op# k#) -> e1 + a2# -> e2 (a2# inv_op# k#) -> e2 + ... ... + DEFAULT -> ed DEFAULT -> ed + + where (x op# k#) inv_op# k# == x + +And similarly for commuted arguments and for some unary operations. + +The purpose of this transformation is not only to avoid an arithmetic +operation at runtime but to allow other transformations to apply in cascade. + +Example with the "Merge Nested Cases" optimization (from #12877): + + main = case t of t0 + 0## -> ... + DEFAULT -> case t0 `minusWord#` 1## of t1 + 0## -> ... + DEFAULT -> case t1 `minusWord#` 1## of t2 + 0## -> ... + DEFAULT -> case t2 `minusWord#` 1## of _ + 0## -> ... + DEFAULT -> ... + + becomes: + + main = case t of _ + 0## -> ... + 1## -> ... + 2## -> ... + 3## -> ... + DEFAULT -> ... + +There are some wrinkles. + +Wrinkle 1: + Do not apply caseRules if there is just a single DEFAULT alternative, + unless the case-binder is dead. Example: + case e +# 3# of b { DEFAULT -> rhs } + If we applied the transformation here we would (stupidly) get + case e of b' { DEFAULT -> let b = b' +# 3# in rhs } + and now the process may repeat, because that let will really + be a case. But if the original case binder b is dead, we instead get + case e of b' { DEFAULT -> rhs } + and there is no such problem. + + See Note [Example of case-merging and caseRules] for a compelling + example of why this dead-binder business can be really important. + + +Wrinkle 2: + The type of the scrutinee might change. E.g. + case tagToEnum (x :: Int#) of (b::Bool) + False -> e1 + True -> e2 + ==> + case x of (b'::Int#) + DEFAULT -> e1 + 1# -> e2 + +Wrinkle 3: + The case binder may be used in the right hand sides, so we need + to make a local binding for it, if it is alive. e.g. + case e +# 10# of b + DEFAULT -> blah...b... + 44# -> blah2...b... + ===> + case e of b' + DEFAULT -> let b = b' +# 10# in blah...b... + 34# -> let b = 44# in blah2...b... + + Note that in the non-DEFAULT cases we know what to bind 'b' to, + whereas in the DEFAULT case we must reconstruct the original value. + But NB: we use b'; we do not duplicate 'e'. + +Wrinkle 4: + In dataToTag we might need to make up some fake binders; + 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 +subtle example from #22375. We start with + + data T = A | B | ... + deriving Eq + + f :: T -> String + f x = if | x==A -> "one" + | x==B -> "two" + | ... + +In Core after a bit of simplification we get: + + f x = case dataToTag# x of a# { _DEFAULT -> + case a# of + _DEFAULT -> case dataToTag# x of b# { _DEFAULT -> + case b# of + _DEFAULT -> ... + 1# -> "two" + } + 0# -> "one" + } + +Now consider what mkCase does to these case expressions. +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# { + _DEFAULT -> ... + 1# -> "two" + } + 0# -> "one" + } + +Now Note [caseRules for dataToTag] does its work, again +on both dataToTag# cases: + + f x = case x of x1 { + _DEFAULT -> case dataToTag# x1 of a# { _DEFAULT -> + case x of x2 { + _DEFAULT -> case dataToTag# x2 of b# { _DEFAULT -> ... } + B -> "two" + }} + A -> "one" + } + + +The new dataToTag# 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. +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 +[Scrutinee Constant Folding] above. Once we do this we get + + f x = case x of x1 { + _DEFAULT -> case x1 of x2 { _DEFAULT -> + case x1 of x2 { + _DEFAULT -> case x2 of x3 { _DEFAULT -> ... } + B -> "two" + }} + A -> "one" + } + +and now we can do case-merge again, getting the desired + + f x = case x of + A -> "one" + B -> "two" + ... + +-} + +mkCase, mkCase1, mkCase2, mkCase3 + :: SimplMode + -> OutExpr -> OutId + -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order + -> SimplM OutExpr + +-------------------------------------------------- +-- 1. Merge Nested Cases +-------------------------------------------------- + +mkCase mode scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts) + | sm_case_merge mode + , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts) + <- stripTicksTop tickishFloatable deflt_rhs + , inner_scrut_var == outer_bndr + = 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! + -- 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 + +-------------------------------------------------- +-- 2. Eliminate Identity Case +-------------------------------------------------- + +mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts') -- Identity case + | all identity_alt alts + = do { tick (CaseIdentity case_bndr) + ; return (mkTicks ticks $ re_cast scrut rhs1) } + where + ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) alts' + identity_alt (Alt con args rhs) = check_eq rhs con args + + check_eq (Cast rhs co) con args -- See Note [RHS casts] + = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args + check_eq (Tick t e) alt args + = tickishFloatable t && check_eq e alt args + + check_eq (Lit lit) (LitAlt lit') _ = lit == lit' + check_eq (Var v) _ _ | v == case_bndr = True + check_eq (Var v) (DataAlt con) args + | null arg_tys, null args = v == dataConWorkId con + -- Optimisation only + check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $ + mkConApp2 con arg_tys args + check_eq _ _ _ = False + + arg_tys = tyConAppArgs (idType case_bndr) + + -- Note [RHS casts] + -- ~~~~~~~~~~~~~~~~ + -- We've seen this: + -- case e of x { _ -> x `cast` c } + -- And we definitely want to eliminate this case, to give + -- e `cast` c + -- So we throw away the cast from the RHS, and reconstruct + -- it at the other end. All the RHS casts must be the same + -- if (all identity_alt alts) holds. + -- + -- Don't worry about nested casts, because the simplifier combines them + + re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co + re_cast scrut _ = scrut + +mkCase1 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts + +-------------------------------------------------- +-- 2. Scrutinee Constant Folding +-------------------------------------------------- + +mkCase2 mode scrut bndr alts_ty alts + | -- See Note [Scrutinee Constant Folding] + case alts of + [Alt DEFAULT _ _] -> isDeadBinder bndr -- see wrinkle 1 + _ -> True + , sm_case_folding mode + , Just (scrut', tx_con, mk_orig) <- caseRules (smPlatform mode) scrut + = do { bndr' <- newId (fsLit "lwild") ManyTy (exprType scrut') + + ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts + -- mapMaybeM: discard unreachable alternatives + -- See Note [Unreachable caseRules alternatives] + -- in GHC.Core.Opt.ConstantFold + + ; mkCase3 mode scrut' bndr' alts_ty $ + add_default (re_sort alts') + } + + | otherwise + = mkCase3 mode scrut bndr alts_ty alts + where + -- We need to keep the correct association between the scrutinee and its + -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with + -- "let bndr = ... in": + -- + -- case v + 10 of y =====> case v of y' + -- 20 -> e1 10 -> let y = 20 in e1 + -- DEFAULT -> e2 DEFAULT -> let y = y' + 10 in e2 + -- + -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules, + -- to construct an expression equivalent to the original one, for use + -- in the DEFAULT case + + tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id + -> CoreAlt -> SimplM (Maybe CoreAlt) + tx_alt tx_con mk_orig new_bndr (Alt con bs rhs) + = case tx_con con of + Nothing -> return Nothing + Just con' -> do { bs' <- mk_new_bndrs new_bndr con' + ; return (Just (Alt con' bs' rhs')) } + where + rhs' | isDeadBinder bndr = rhs + | otherwise = bindNonRec bndr orig_val rhs + + orig_val = case con of + DEFAULT -> mk_orig new_bndr + LitAlt l -> Lit l + DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs + + mk_new_bndrs new_bndr (DataAlt dc) + | not (isNullaryRepDataCon dc) + = -- For non-nullary data cons we must invent some fake binders + -- See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold + do { us <- getUniquesM + ; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc + (tyConAppArgs (idType new_bndr)) + ; return (ex_tvs ++ arg_ids) } + mk_new_bndrs _ _ = return [] + + re_sort :: [CoreAlt] -> [CoreAlt] + -- Sort the alternatives to re-establish + -- GHC.Core Note [Case expression invariants] + re_sort alts = sortBy cmpAlt alts + + add_default :: [CoreAlt] -> [CoreAlt] + -- See Note [Literal cases] + add_default (Alt (LitAlt {}) bs rhs : alts) = Alt DEFAULT bs rhs : alts + add_default alts = alts + +{- Note [Literal cases] +~~~~~~~~~~~~~~~~~~~~~~~ +If we have + case tagToEnum (a ># b) of + False -> e1 + True -> e2 + +then caseRules for TagToEnum will turn it into + case tagToEnum (a ># b) of + 0# -> e1 + 1# -> e2 + +Since the case is exhaustive (all cases are) we can convert it to + case tagToEnum (a ># b) of + DEFAULT -> e1 + 1# -> e2 + +This may generate slightly better code (although it should not, since +all cases are exhaustive) and/or optimise better. I'm not certain that +it's necessary, but currently we do make this change. We do it here, +NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum] +in GHC.Core.Opt.ConstantFold) +-} + +-------------------------------------------------- +-- Catch-all +-------------------------------------------------- +mkCase3 _mode scrut bndr alts_ty alts = return (Case scrut bndr alts_ty alts) -- See Note [Exitification] and Note [Do not inline exit join points] in 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,3 +1,7 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 905 +{-# LANGUAGE PatternSynonyms #-} +#endif {- ToDo [Oct 2013] ~~~~~~~~~~~~~~~ @@ -28,14 +32,17 @@ import GHC.Core.Subst import GHC.Core.Utils import GHC.Core.Unfold -import GHC.Core.FVs ( exprsFreeVarsList ) +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.DataCon +import GHC.Core.Class( classTyVars ) import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules +import GHC.Core.Predicate ( typeDeterminesValue ) import GHC.Core.Type hiding ( substTy ) -import GHC.Core.TyCon (TyCon, tyConUnique, tyConName ) +import GHC.Core.TyCon (TyCon, tyConName ) import GHC.Core.Multiplicity import GHC.Core.Ppr ( pprParendExpr ) import GHC.Core.Make ( mkImpossibleExpr ) @@ -45,6 +52,7 @@ import GHC.Types.Literal ( litIsLifted ) import GHC.Types.Id +import GHC.Types.Id.Info ( IdDetails(..) ) import GHC.Types.Id.Make ( voidArgId, voidPrimId ) import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -55,6 +63,7 @@ import GHC.Types.Cpr import GHC.Types.Unique.Supply import GHC.Types.Unique.FM +import GHC.Types.Unique( hasKey ) import GHC.Data.Maybe ( orElse, catMaybes, isJust, isNothing ) import GHC.Data.Pair @@ -66,7 +75,6 @@ import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Monad -import GHC.Utils.Trace import GHC.Builtin.Names ( specTyConKey ) @@ -75,7 +83,9 @@ import Control.Monad ( zipWithM ) import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL ) +import Data.Maybe( mapMaybe ) import Data.Ord( comparing ) +import Data.Tuple {- ----------------------------------------------------- @@ -372,11 +382,14 @@ So we want to spot the constructor application inside the cast. That's why we have the Cast case in argToPat -Note [Local recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a *local* recursive group, we can see all the calls to the -function, so we seed the specialisation loop from the calls in the -body, not from the calls in the RHS. Consider: +Note [Seeding recursive groups] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a recursive group that is either + * nested, or + * top-level, but with no exported Ids +we can see all the calls to the function, so we seed the specialisation +loop from the calls in the body, and /not/ from the calls in the RHS. +Consider: bar m n = foo n (n,n) (n,n) (n,n) (n,n) where @@ -399,53 +412,43 @@ In a case like the above we end up never calling the original un-specialised function. (Although we still leave its code around just in case.) -However, if we find any boring calls in the body, including *unsaturated* -ones, such as +Wrinkles + +* Boring calls. If we find any boring calls in the body, including + *unsaturated* ones, such as letrec foo x y = ....foo... in map foo xs -then we will end up calling the un-specialised function, so then we *should* -use the calls in the un-specialised RHS as seeds. We call these -"boring call patterns", and callsToPats reports if it finds any of these. + then we will end up calling the un-specialised function, so then we + *should* use the calls in the un-specialised RHS as seeds. We call + these "boring call patterns", and callsToNewPats reports if it finds + any of these. Then 'specialise' unleashes the usage info from the + un-specialised RHS. -Note [Seeding top-level recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This seeding is done in the binding for seed_calls in specRec. +* Exported Ids. `specialise` /also/ unleashes `si_mb_unspec` + for exported Ids. That way we are sure to generate usage info from + the /un-specialised/ RHS of an exported function. -1. If all the bindings in a top-level recursive group are local (not - exported), then all the calls are in the rest of the top-level - bindings. This means we can specialise with those call patterns - ONLY, and NOT with the RHSs of the recursive group (exactly like - Note [Local recursive groups]) +More precisely: -2. But if any of the bindings are exported, the function may be called - with any old arguments, so (for lack of anything better) we specialise - based on - (a) the call patterns in the RHS - (b) the call patterns in the rest of the top-level bindings - NB: before Apr 15 we used (a) only, but Dimitrios had an example - where (b) was crucial, so I added that. - Adding (b) also improved nofib allocation results: - multiplier: 4% better - minimax: 2.8% better +* Always start from the calls in the body of the let or (for top level) + calls in the rest of the module. See the body_calls in the call to + `specialise` in `specNonRec`, and to `go` in `specRec`. -Actually in case (2), instead of using the calls from the RHS, it -would be better to specialise in the importing module. We'd need to -add an INLINABLE pragma to the function, and then it can be -specialised in the importing scope, just as is done for type classes -in GHC.Core.Opt.Specialise.specImports. This remains to be done (#10346). +* si_mb_unspec holds the usage from the unspecialised RHS. + See `initSpecInfo`. -Note [Top-level recursive groups] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To get the call usage information from "the rest of the top level -bindings" (c.f. Note [Seeding top-level recursive groups]), we work -backwards through the top-level bindings so we see the usage before we -get to the binding of the function. Before we can collect the usage -though, we go through all the bindings and add them to the -environment. This is necessary because usage is only tracked for -functions in the environment. These two passes are called - 'go' and 'goEnv' -in specConstrProgram. (Looks a bit revolting to me.) +* `specialise` will unleash si_mb_unspec, if + - `callsToNewPats` reports "boring calls found", or + - this is a top-level exported Id. +Historical note. At an earlier point, if a top-level Id was exported, +we used only seeds from the RHS, and /not/from the body. But Dimitrios +had an example where using call patterns from the body (the other defns +in the module) was crucial. And doing so improved nofib allocation results: + multiplier: 4% better + minimax: 2.8% better +In any case, it is easier to do! + Note [Do not specialise diverging functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Specialising a function that just diverges is a waste of code. @@ -634,6 +637,52 @@ representing strict fields. See Note [Call-by-value for worker args] for why we do this. +Note [Specialising on dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #21386, SpecConstr saw this call: + + $wgo 100# @.. ($fMonadStateT @.. @.. $fMonadIdentity) + +where $wgo :: Int# -> forall m. Monad m => blah + +You might think that the type-class Specialiser would have specialised +this, but there are good reasons why not: the Specialiser ran too early. +But regardless, SpecConstr can and should! It's easy: + +* isValue: treat ($fblah d1 .. dn) + like a constructor application. + +* scApp: treat (op_sel d), a class method selection, + like a case expression + +* Float that dictionary application to top level, thus + lvl = $fMonadStateT @.. @.. $fMonadIdentity + so the call looks like + ($wgo 100# @.. lvl) + + Why? This way dictionaries will appear as top level binders which we + can trivially match in rules. (CSE runs before SpecConstr, so we + may hope to common-up duplicate top-level dictionaries.) + For the floating part, see the "Arguments" case of Note + [Floating to the top] in GHC.Core.Opt.SetLevels. + + We could be more clever, perhaps, and generate a RULE like + $wgo _ @.. ($fMonadStateT @.. @.. $fMonadIdentity) = $s$wgo ... + but that would mean making argToPat able to spot dfun applications as + well as constructor applications. + +Wrinkles: + +* This should all work perfectly fine for newtype classes. Mind you, + currently newtype classes are inlined fairly agressively, but we + may change that. And it would take extra code to exclude them, as + well as being unnecessary. + +* In isValue, we (mis-) use LambdaVal for this ($fblah d1 .. dn) + because ConVal requires us to list the data constructor and + fields, and that is (a) inconvenient and (b) unnecessary for + class methods. + ----------------------------------------------------- Stuff not yet handled ----------------------------------------------------- @@ -718,35 +767,18 @@ specConstrProgram :: ModGuts -> CoreM ModGuts specConstrProgram guts - = do - dflags <- getDynFlags - us <- getUniqueSupplyM - (_, annos) <- getFirstAnnotations deserializeWithData guts - this_mod <- getModule - -- pprTraceM "specConstrInput" (ppr $ mg_binds guts) - let binds' = reverse $ fst $ initUs us $ do - -- Note [Top-level recursive groups] - (env, binds) <- goEnv (initScEnv dflags this_mod annos) - (mg_binds guts) - -- binds is identical to (mg_binds guts), except that the - -- binders on the LHS have been replaced by extendBndr - -- (SPJ this seems like overkill; I don't think the binders - -- will change at all; and we don't substitute in the RHSs anyway!!) - go env nullUsage (reverse binds) + = do { env0 <- initScEnv guts + ; us <- getUniqueSupplyM + ; let (_usg, binds') = initUs_ us $ + scTopBinds env0 (mg_binds guts) - return (guts { mg_binds = binds' }) - where - -- See Note [Top-level recursive groups] - goEnv env [] = return (env, []) - goEnv env (bind:binds) = do (env', bind') <- scTopBindEnv env bind - (env'', binds') <- goEnv env' binds - return (env'', bind' : binds') + ; return (guts { mg_binds = binds' }) } - -- Arg list of bindings is in reverse order - go _ _ [] = return [] - go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind - binds' <- go env usg' binds - return (bind' : binds') +scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind]) +scTopBinds _env [] = return (nullUsage, []) +scTopBinds env (b:bs) = do { (usg, b', bs') <- scBind TopLevel env b $ + (\env -> scTopBinds env bs) + ; return (usg, b' ++ bs') } {- ************************************************************************ @@ -831,24 +863,38 @@ the function is applied to a data constructor. -} -data ScEnv = SCE { sc_dflags :: DynFlags, - sc_uf_opts :: !UnfoldingOpts, -- ^ Unfolding options - sc_module :: !Module, - sc_size :: Maybe Int, -- Size threshold - -- Nothing => no limit +-- | Options for Specializing over constructors in Core. +data SpecConstrOpts = SpecConstrOpts + { sc_max_args :: !Int + -- ^ 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_count :: Maybe Int, -- Max # of specialisations for any one fn - -- Nothing => no limit - -- See Note [Avoiding exponential blowup] + , sc_debug :: !Bool + -- ^ Whether to print debug information - sc_recursive :: Int, -- Max # of specialisations over recursive type. - -- Stops ForceSpecConstr from diverging. + , sc_uf_opts :: !UnfoldingOpts + -- ^ Unfolding options - sc_keen :: Bool, -- Specialise on arguments that are known - -- constructors, even if they are not - -- scrutinised in the body. See - -- Note [Making SpecConstr keener] + , sc_module :: !Module + -- ^ The name of the module being processed + , sc_size :: !(Maybe Int) + -- ^ Size threshold: Nothing => no limit + + , sc_count :: !(Maybe Int) + -- ^ Max # of specialisations for any one function. Nothing => no limit. + -- See Note [Avoiding exponential blowup] and decreaseSpecCount + + , sc_recursive :: !Int + -- ^ Max # of specialisations over recursive type. Stops + -- ForceSpecConstr from diverging. + + , sc_keen :: !Bool + -- ^ Specialise on arguments that are known constructors, even if they are + -- not scrutinised in the body. See Note [Making SpecConstr keener]. + } + +data ScEnv = SCE { sc_opts :: !SpecConstrOpts, sc_force :: Bool, -- Force specialisation? -- See Note [Forcing specialisation] @@ -884,21 +930,36 @@ ppr LambdaVal = text "" --------------------- -initScEnv :: DynFlags -> Module -> UniqFM Name SpecConstrAnnotation -> ScEnv -initScEnv dflags this_mod anns - = SCE { sc_dflags = dflags, +initScOpts :: DynFlags -> Module -> SpecConstrOpts +initScOpts dflags this_mod = SpecConstrOpts + { sc_max_args = maxWorkerArgs dflags, + sc_debug = hasPprDebug dflags, sc_uf_opts = unfoldingOpts dflags, sc_module = this_mod, sc_size = specConstrThreshold dflags, sc_count = specConstrCount dflags, sc_recursive = specConstrRecursive dflags, - sc_keen = gopt Opt_SpecConstrKeen dflags, - sc_force = False, - sc_subst = emptySubst, - sc_how_bound = emptyVarEnv, - sc_vals = emptyVarEnv, - sc_annotations = anns } + sc_keen = gopt Opt_SpecConstrKeen dflags + } +initScEnv :: ModGuts -> CoreM ScEnv +initScEnv guts + = do { dflags <- getDynFlags + ; (_, anns) <- getFirstAnnotations deserializeWithData guts + ; this_mod <- getModule + ; return (SCE { sc_opts = initScOpts dflags this_mod, + sc_force = False, + sc_subst = init_subst, + sc_how_bound = emptyVarEnv, + sc_vals = emptyVarEnv, + sc_annotations = anns }) } + where + init_subst = mkEmptySubst $ mkInScopeSetBndrs (mg_binds guts) + -- Acccount for top-level bindings that are not in dependency order; + -- see Note [Glomming] in GHC.Core.Opt.OccurAnal + -- Easiest thing is to bring all the top level binders into scope at once, + -- as if at once, as if all the top-level decls were mutually recursive. + data HowBound = RecFun -- These are the recursive functions for which -- we seek interesting call patterns @@ -912,20 +973,42 @@ scForce :: ScEnv -> Bool -> ScEnv scForce env b = env { sc_force = b } -lookupHowBound :: ScEnv -> Id -> Maybe HowBound +lookupHowBound :: ScEnv -> OutId -> Maybe HowBound lookupHowBound env id = lookupVarEnv (sc_how_bound env) id -scSubstId :: ScEnv -> Id -> CoreExpr +scSubstId :: ScEnv -> InId -> OutExpr scSubstId env v = lookupIdSubst (sc_subst env) v -scSubstTy :: ScEnv -> Type -> Type -scSubstTy env ty = substTy (sc_subst env) ty +-- 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 +-- substitution itself is lazy, because that type is often discarded. +-- The callers of `scSubstTy` always force the result (to unpack the `Solo`) +-- so we get the desired effect: we leave a thunk, but retain only the subst, +-- not the whole env. +-- +-- Fully forcing the result of `scSubstTy` regresses performance (#22102) +scSubstTy :: ScEnv -> InType -> Solo OutType +scSubstTy env ty = + let !subst = sc_subst env + in MkSolo (substTyUnchecked subst ty) + scSubstCo :: ScEnv -> Coercion -> Coercion scSubstCo env co = substCo (sc_subst env) co zapScSubst :: ScEnv -> ScEnv -zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) } +zapScSubst env = env { sc_subst = zapSubst (sc_subst env) } extendScInScope :: ScEnv -> [Var] -> ScEnv -- Bring the quantified variables into scope @@ -991,8 +1074,8 @@ = (env2, alt_bndrs') where live_case_bndr = not (isDeadBinder case_bndr) - env1 | Var v <- stripTicksTopE (const True) scrut - = extendValEnv env v cval + env1 | Just (v, mco) <- scrutBinderSwap_maybe 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 | otherwise = env1 @@ -1016,14 +1099,21 @@ decreaseSpecCount :: ScEnv -> Int -> ScEnv -- See Note [Avoiding exponential blowup] -decreaseSpecCount env n_specs +decreaseSpecCount env _n_specs = env { sc_force = False -- See Note [Forcing specialisation] - , sc_count = case sc_count env of - Nothing -> Nothing - Just n -> Just (n `div` (n_specs + 1)) } - -- The "+1" takes account of the original function; - -- See Note [Avoiding exponential blowup] + , sc_opts = opts { sc_count = case sc_count opts of + Nothing -> Nothing + Just n -> Just $! dec n + } + } + where + opts = sc_opts env + dec n = n `div` 2 -- See Note [Avoiding exponential blowup] + -- Or: n `div` (n_specs + 1) + -- See the historical note part of Note [Avoiding exponential blowup] + -- The "+1" takes account of the original function; + --------------------------------------------------- -- See Note [Forcing specialisation] ignoreType :: ScEnv -> Type -> Bool @@ -1048,14 +1138,13 @@ forceSpecArgTy :: ScEnv -> Type -> Bool forceSpecArgTy env ty - | Just ty' <- coreView ty = forceSpecArgTy env ty' + | isFunTy ty + = False -forceSpecArgTy env ty | Just (tycon, tys) <- splitTyConApp_maybe ty - , tycon /= funTyCon - = tyConUnique tycon == specTyConKey - || lookupUFM (sc_annotations env) (tyConName tycon) == Just ForceSpecConstr - || any (forceSpecArgTy env) tys + = tycon `hasKey` specTyConKey + || lookupUFM (sc_annotations env) (tyConName tycon) == Just ForceSpecConstr + || any (forceSpecArgTy env) tys forceSpecArgTy _ _ = False @@ -1079,6 +1168,10 @@ 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 +to identify suitable scrutinees -- but only if there is no cast +(isReflMCo) because that's all that the ValueEnv allows. + Note [Avoiding exponential blowup] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The sc_count field of the ScEnv says how many times we are prepared to @@ -1098,9 +1191,20 @@ specialisation of each, because we also have the original we'll get 2^n copies of $j3, which is not good. -So when recursively specialising we divide the sc_count by the number of -copies we are making at this level, including the original. +So when recursively specialising we divide the sc_count (the maximum +number of specialisations, in the ScEnv) by two. You might think that +gives us n*(n/2)*(n/4)... copies of the innnermost thing, which is +still exponential the depth. But we use integer division, rounding +down, so if the starting sc_count is 3, we'll get 3 -> 1 -> 0, and +stop. In fact, simply subtracting 1 would be good enough, for the same +reason. +Historical note: in the past we divided by (n_specs+1), where n_specs +is the number of specialisations at this level; but that gets us down +to zero jolly quickly, which I found led to some regressions. (An +example is nofib/spectral/fibheaps, the getMin' function inside the +outer function $sfibToList, which has several interesting call +patterns.) ************************************************************************ * * @@ -1118,8 +1222,8 @@ scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences } -- The domain is OutIds -type CallEnv = IdEnv [Call] -data Call = Call Id [CoreArg] ValueEnv +type CallEnv = IdEnv [Call] -- Domain is OutIds +data Call = Call OutId [CoreArg] ValueEnv -- The arguments of the call, together with the -- env giving the constructor bindings at the call site -- We keep the function mainly for debug output @@ -1141,6 +1245,9 @@ combineCalls :: CallEnv -> CallEnv -> CallEnv combineCalls = plusVarEnv_C (++) +delCallsFor :: ScUsage -> [Var] -> ScUsage +delCallsFor env bndrs = env { scu_calls = scu_calls env `delVarEnvList` bndrs } + combineUsage :: ScUsage -> ScUsage -> ScUsage combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2), scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) } @@ -1158,8 +1265,21 @@ | UnkOcc -- Used in some unknown way | ScrutOcc -- See Note [ScrutOcc] - (DataConEnv [ArgOcc]) -- How the sub-components are used + (DataConEnv [ArgOcc]) + -- [ArgOcc]: how the sub-components are used +deadArgOcc :: ArgOcc -> Bool +deadArgOcc (ScrutOcc {}) = False +deadArgOcc UnkOcc = False +deadArgOcc NoOcc = True + +specialisableArgOcc :: ArgOcc -> Bool +-- | Does this occurence represent one worth specializing for. +specialisableArgOcc UnkOcc = False +specialisableArgOcc NoOcc = False +specialisableArgOcc (ScrutOcc {}) = True + + {- Note [ScrutOcc] ~~~~~~~~~~~~~~~~~~ An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, @@ -1184,6 +1304,9 @@ ppr NoOcc = text "no-occ" evalScrutOcc :: ArgOcc +-- We use evalScrutOcc for +-- - mkVarUsage: applied functions +-- - scApp: dicts that are the argument of a classop evalScrutOcc = ScrutOcc emptyUFM -- Experimentally, this version of combineOcc makes ScrutOcc "win", so @@ -1223,6 +1346,121 @@ creates specialised versions of functions. -} +scBind :: TopLevelFlag -> ScEnv -> InBind + -> (ScEnv -> UniqSM (ScUsage, a)) -- Specialise the scope of the binding + -> UniqSM (ScUsage, [OutBind], a) +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') } + + | 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) + + ; 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 + + -- Now make specialised copies of the binding, + -- based on calls in body_usg + ; (spec_usg, specs) <- 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]) + + -- Specialized + original binding + ; let spec_bnds = [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] + bind_usage = (body_usg `delCallsFor` [bndr']) + `combineUsage` spec_usg -- Note [spec_usg includes rhs_usg] + + ; return (bind_usage, spec_bnds, body') + } + + | otherwise -- Top-level, non-recursive value binding + -- At top level we do not specialise non-recursive bindings; that + -- is, we do not call specNonRec, passing the calls from the body. + -- The original paper only specialised /recursive/ bindings, but + -- we later started specialising nested non-recursive bindings: + -- see Note [Specialising local let bindings] + -- + -- 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 + + -- 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 + + ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body') } + +scBind top_lvl env (Rec prs) do_body + | isTopLevel top_lvl + , Just threshold <- sc_size (sc_opts env) + , not force_spec + , 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 + ; let all_usg = (combineUsages rhs_usgs `combineUsage` body_usg) + `delCallsFor` bndrs' + bind' = Rec (bndrs' `zip` rhss') + ; return (all_usg, [bind'], body') } + + | otherwise + = do { rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss) + ; (body_usg, body') <- do_body rhs_env2 + + ; (spec_usg, specs) <- 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)) + -- zipWithEqual: length of returned [SpecInfo] + -- should be the same as incoming [RhsInfo] + + ; return (all_usg, [bind'], body') } + where + (bndrs,rhss) = unzip prs + force_spec = any (forceSpecBndr env) bndrs -- Note [Forcing specialisation] + + (rhs_env1,bndrs') | isTopLevel top_lvl = (env, bndrs) + | otherwise = extendRecBndrs env bndrs + -- At top level, we've already put all binders into scope; see initScEnv + + rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun + +{- Note [Specialising local let bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is not uncommon to find this + + let $j = \x. in ...$j True...$j True... + +Here $j is an arbitrary let-bound function, but it often comes up for +join points. We might like to specialise $j for its call patterns. +Notice the difference from a letrec, where we look for call patterns +in the *RHS* of the function. Here we look for call patterns in the +*body* of the let. + +At one point I predicated this on the RHS mentioning the outer +recursive function, but that's not essential and might even be +harmful. I'm not sure. +-} + +------------------------ scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr) -- The unique supply is needed when we invent -- a new name for the specialised function and its args @@ -1233,7 +1471,9 @@ Var v' -> return (mkVarUsage env v' [], Var v') e' -> scExpr (zapScSubst env) e' -scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t)) +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 @@ -1247,6 +1487,11 @@ (usg, e') <- scExpr env' e return (usg, Lam b' e') +scExpr' env (Let bind body) + = do { (final_usage, binds', body') <- scBind NotTopLevel env bind $ + (\env -> scExpr env body) + ; return (final_usage, mkLets binds' body') } + scExpr' env (Case scrut b ty alts) = do { (scrut_usg, scrut') <- scExpr env scrut ; case isValue (sc_vals env) scrut' of @@ -1256,7 +1501,7 @@ where sc_con_app con args scrut' -- Known constructor; simplify = do { let Alt _ bs rhs = findAlt con alts - `orElse` Alt DEFAULT [] (mkImpossibleExpr ty) + `orElse` Alt DEFAULT [] (mkImpossibleExpr ty "SpecConstr") alt_env' = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args) ; scExpr alt_env' rhs } @@ -1264,100 +1509,72 @@ = 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') <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts ; let scrut_occ = foldr combineOcc NoOcc alt_occs scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ -- The combined usage of the scrutinee is given - -- by scrut_occ, which is passed to scScrut, which + -- by scrut_occ, which is passed to setScrutOcc, which -- in turn treats a bare-variable scrutinee specially + ; let !(MkSolo ty') = scSubstTy env ty ; return (foldr combineUsage scrut_usg' alt_usgs, - Case scrut' b' (scSubstTy env ty) alts') } + Case scrut' b' ty' 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) scrut_occ = case con of - DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) - _ -> ScrutOcc emptyUFM + 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') } -scExpr' env (Let (NonRec bndr rhs) body) - | isTyVar bndr -- Type-lets may be created by doBeta - = scExpr' (extendScSubst env bndr rhs) body - | otherwise - = do { let (body_env, bndr') = extendBndr env bndr - ; rhs_info <- scRecRhs env (bndr',rhs) - ; let body_env2 = extendHowBound body_env [bndr'] RecFun - -- See Note [Local let bindings] - rhs' = ri_new_rhs rhs_info - body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs') - - ; (body_usg, body') <- scExpr body_env3 body - - -- NB: For non-recursive bindings we inherit sc_force flag from - -- the parent function (see Note [Forcing specialisation]) - ; (spec_usg, specs) <- specNonRec env body_usg rhs_info - - -- Specialized + original binding - ; let spec_bnds = mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body' - -- ; pprTraceM "spec_bnds" $ (ppr spec_bnds) - - ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } - `combineUsage` spec_usg, -- Note [spec_usg includes rhs_usg] - spec_bnds - ) - } - - --- A *local* recursive group: see Note [Local recursive groups] -scExpr' env (Let (Rec prs) body) - = do { let (bndrs,rhss) = unzip prs - (rhs_env1,bndrs') = extendRecBndrs env bndrs - rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun - force_spec = any (forceSpecBndr env) bndrs' - -- Note [Forcing specialisation] - - ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss) - ; (body_usg, body') <- scExpr rhs_env2 body +{- Note [Do not specialise evals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x y = case x of I# _ -> + if y>1 then f x (y-1) else x - -- NB: start specLoop from body_usg - ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec) - body_usg rhs_infos - -- Do not unconditionally generate specialisations from rhs_usgs - -- Instead use them only if we find an unspecialised call - -- See Note [Local recursive groups] +Here `x` is scrutinised by a case, but only in an eval-like way; the +/component/ of the I# is unused. We don't want to specialise this +function, even if we find a call (f (I# z)), because nothing is gained + * No case branches are discarded + * No allocation in removed +The specialised version would take an unboxed Int#, pass it along, +and rebox it at the end. - ; let all_usg = spec_usg `combineUsage` body_usg -- Note [spec_usg includes rhs_usg] - bind' = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs)) - -- zipWithEqual: length of returned [SpecInfo] - -- should be the same as incoming [RhsInfo] +In fact this can cause significant regression. In #21763 we had: +like + f = ... case x of x' { I# n -> + join j y = rhs + in ...jump j x'... - ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' }, - Let bind' body') } +Now if we specialise `j` for the argument `I# n`, we'll end up reboxing +it in `j`, without even removing an allocation from the call site. -{- -Note [Local let bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~ -It is not uncommon to find this +Reboxing is always a worry. But here we can ameliorate the problem as +follows. - let $j = \x. in ...$j True...$j True... +* In scExpr (Case ...), for a /single-alternative/ case expression, in + which the pattern binders are all unused, we build a UnkOcc for + the scrutinee, not one that maps the data constructor; we don't treat + this occurrence as a reason for specialisation. -Here $j is an arbitrary let-bound function, but it often comes up for -join points. We might like to specialise $j for its call patterns. -Notice the difference from a letrec, where we look for call patterns -in the *RHS* of the function. Here we look for call patterns in the -*body* of the let. +* Conveniently, SpecConstr is doing its own occurrence analysis, so + the "unused" bit is just looking for NoOcc -At one point I predicated this on the RHS mentioning the outer -recursive function, but that's not essential and might even be -harmful. I'm not sure. +* Note that if we have + f x = case x of { True -> e1; False -> e2 } + then even though the pattern binders are unused (there are none), it is + still worth specialising on x. Hence the /single-alternative/ guard. -} scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr) @@ -1371,8 +1588,15 @@ fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args') -- Do beta-reduction and try again - Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args', + Var fn' -> return (arg_usg' `combineUsage` mkVarUsage env fn' args', mkApps (Var fn') args') + where + -- arg_usg': see Note [Specialising on dictionaries] + arg_usg' | Just cls <- isClassOpId_maybe fn' + , dict_arg : _ <- dropList (classTyVars cls) args' + = setScrutOcc env arg_usg dict_arg evalScrutOcc + | otherwise + = arg_usg other_fn' -> return (arg_usg, mkApps other_fn' args') } -- NB: doing this ignores any usage info from the substituted @@ -1380,7 +1604,6 @@ -- we can fix it. where doBeta :: OutExpr -> [OutExpr] -> OutExpr - -- ToDo: adjust for System IF doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args) doBeta fn args = mkApps fn args @@ -1403,56 +1626,10 @@ , scu_occs = unitVarEnv fn arg_occ } Nothing -> nullUsage where - -- I rather think we could use UnkOcc all the time arg_occ | null args = UnkOcc | otherwise = evalScrutOcc ---------------------- -scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) -scTopBindEnv env (Rec prs) - = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs - rhs_env2 = extendHowBound rhs_env1 bndrs RecFun - - prs' = zip bndrs' rhss - ; return (rhs_env2, Rec prs') } - where - (bndrs,rhss) = unzip prs - -scTopBindEnv env (NonRec bndr rhs) - = do { let (env1, bndr') = extendBndr env bndr - env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs) - ; return (env2, NonRec bndr' rhs) } - ----------------------- -scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) - -scTopBind env body_usage (Rec prs) - | Just threshold <- sc_size env - , not force_spec - , not (all (couldBeSmallEnoughToInline (sc_uf_opts env) threshold) rhss) - -- No specialisation - = -- pprTrace "scTopBind: nospec" (ppr bndrs) $ - do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss - ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) } - - | otherwise -- Do specialisation - = do { rhs_infos <- mapM (scRecRhs env) prs - - ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec) - body_usage rhs_infos - - ; return (body_usage `combineUsage` spec_usage, - Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) } - where - (bndrs,rhss) = unzip prs - force_spec = any (forceSpecBndr env) bndrs - -- Note [Forcing specialisation] - -scTopBind env usage (NonRec bndr rhs) -- Oddly, we don't seem to specialise top-level non-rec functions - = do { (rhs_usg', rhs') <- scExpr env rhs - ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') } - ----------------------- scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo scRecRhs env (bndr,rhs) = do { let (arg_bndrs,body) = collectBinders rhs @@ -1499,7 +1676,8 @@ } data SpecInfo -- Info about specialisations for a particular Id - = SI { si_specs :: [OneSpec] -- The specialisations we have generated + = SI { si_specs :: [OneSpec] -- The specialisations we have + -- generated for this function , si_n_specs :: Int -- Length of si_specs; used for numbering them @@ -1510,7 +1688,7 @@ -- RHS usage (which has not yet been -- unleashed) -- Nothing => we have - -- See Note [Local recursive groups] + -- See Note [Seeding recursive groups] -- See Note [spec_usg includes rhs_usg] -- One specialisation: Rule plus definition @@ -1520,84 +1698,84 @@ , os_id :: OutId -- Spec id , os_rhs :: OutExpr } -- Spec rhs -noSpecInfo :: SpecInfo -noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing } +initSpecInfo :: RhsInfo -> SpecInfo +initSpecInfo (RI { ri_rhs_usg = rhs_usg }) + = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Just rhs_usg } + -- si_mb_unspec: add in rhs_usg if there are any boring calls, + -- or if the bndr is exported ---------------------- specNonRec :: ScEnv - -> ScUsage -- Body usage + -> CallEnv -- Calls in body -> RhsInfo -- Structure info usage info for un-specialised RHS -> UniqSM (ScUsage, SpecInfo) -- Usage from RHSs (specialised and not) -- plus details of specialisations -specNonRec env body_usg rhs_info - = specialise env (scu_calls body_usg) rhs_info - (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) }) +specNonRec env body_calls rhs_info + = specialise env body_calls rhs_info (initSpecInfo rhs_info) ---------------------- -specRec :: TopLevelFlag -> ScEnv - -> ScUsage -- Body usage +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) -- plus details of specialisations -specRec top_lvl env body_usg rhs_infos - = go 1 seed_calls nullUsage init_spec_infos +specRec env body_calls 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, + -- or if any of the Id(s) are exported where - (seed_calls, init_spec_infos) -- Note [Seeding top-level recursive groups] - | isTopLevel top_lvl - , any (isExportedId . ri_fn) rhs_infos -- Seed from body and RHSs - = (all_calls, [noSpecInfo | _ <- rhs_infos]) - | otherwise -- Seed from body only - = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) } - | ri <- rhs_infos]) - - calls_in_body = scu_calls body_usg - calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos - all_calls = calls_in_rhss `combineCalls` calls_in_body + opts = sc_opts env -- Loop, specialising, until you get no new specialisations - go :: Int -- Which iteration of the "until no new specialisations" - -- loop we are on; first iteration is 1 - -> CallEnv -- Seed calls - -- Two accumulating parameters: - -> ScUsage -- Usage from earlier specialisations - -> [SpecInfo] -- Details of specialisations so far - -> UniqSM (ScUsage, [SpecInfo]) + go, go_again :: Int -- Which iteration of the "until no new specialisations" + -- loop we are on; first iteration is 1 + -> CallEnv -- Seed calls + -- 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 + = -- 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 + 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 deals with termination + go_again n_iter seed_calls usg_so_far spec_infos | isEmptyVarEnv seed_calls - = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos) - -- , ppr seed_calls - -- , ppr body_usg ]) $ - return (usg_so_far, spec_infos) + = return (usg_so_far, spec_infos) -- Limit recursive specialisation -- See Note [Limit recursive specialisation] - | n_iter > sc_recursive env -- Too many iterations of the 'go' loop - , sc_force env || isNothing (sc_count env) + | n_iter > sc_recursive opts -- Too many iterations of the 'go' loop + , sc_force env || isNothing (sc_count opts) -- If both of these are false, the sc_count -- threshold will prevent non-termination , any ((> the_limit) . si_n_specs) spec_infos - = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $ - return (usg_so_far, 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) | otherwise - = -- 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, new_spec_infos) = unzip specs_w_usg - extra_usg = combineUsages extra_usg_s - all_usg = usg_so_far `combineUsage` extra_usg - ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos } + = go (n_iter + 1) seed_calls usg_so_far spec_infos -- See Note [Limit recursive specialisation] - the_limit = case sc_count env of + the_limit = case sc_count opts of Nothing -> 10 -- Ugh! Just max -> max - ---------------------- specialise :: ScEnv @@ -1620,14 +1798,12 @@ spec_info@(SI { si_specs = specs, si_n_specs = spec_count , si_mb_unspec = mb_unspec }) | isDeadEndId fn -- Note [Do not specialise diverging functions] - -- and do not generate specialisation seeds from its RHS + -- /and/ do not generate specialisation seeds from its RHS = -- pprTrace "specialise bot" (ppr fn) $ return (nullUsage, spec_info) | not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation] - -- - -- -- Don't specialise OPAQUE things, see Note [OPAQUE pragma]. -- Since OPAQUE things are always never-active (see -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for @@ -1635,16 +1811,19 @@ , 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, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls + do { (boring_call, pats_discarded, new_pats) + <- callsToNewPats env fn spec_info arg_occs all_calls ; let n_pats = length new_pats --- ; if (not (null new_pats) || isJust mb_unspec) then --- pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns" --- , text "mb_unspec" <+> ppr (isJust mb_unspec) --- , text "arg_occs" <+> ppr arg_occs --- , text "good pats" <+> ppr new_pats]) $ --- return () --- else return () +-- ; when (not (null new_pats) || isJust mb_unspec) $ +-- pprTraceM "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns" +-- , text "boring_call:" <+> ppr boring_call +-- , text "pats_discarded:" <+> ppr pats_discarded +-- , text "old spec_count" <+> ppr spec_count +-- , text "spec count limit" <+> ppr (sc_count (sc_opts env)) +-- , text "mb_unspec" <+> ppr (isJust mb_unspec) +-- , text "arg_occs" <+> ppr arg_occs +-- , 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) @@ -1653,24 +1832,25 @@ ; let spec_usg = combineUsages spec_usgs + unspec_rhs_needed = pats_discarded || boring_call || isExportedId fn + -- If there were any boring calls among the seeds (= all_calls), then those -- calls will call the un-specialised function. So we should use the seeds -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning -- then in new_usg. - (new_usg, mb_unspec') - = case mb_unspec of - Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing) - _ -> (spec_usg, mb_unspec) + (new_usg, mb_unspec') = case mb_unspec of + Just rhs_usg | unspec_rhs_needed + -> (spec_usg `combineUsage` rhs_usg, Nothing) + _ -> (spec_usg, mb_unspec) --- ; pprTrace "specialise return }" --- (vcat [ ppr fn --- , text "boring_call:" <+> ppr boring_call --- , text "new calls:" <+> ppr (scu_calls new_usg)]) $ --- return () +-- ; pprTraceM "specialise return }" $ +-- vcat [ ppr fn +-- , text "unspec_rhs_needed:" <+> ppr unspec_rhs_needed +-- , text "new calls:" <+> ppr (scu_calls new_usg)] - ; return (new_usg, SI { si_specs = new_specs ++ specs - , si_n_specs = spec_count + n_pats - , si_mb_unspec = mb_unspec' }) } + ; return (new_usg, SI { si_specs = new_specs ++ specs + , si_n_specs = spec_count + n_pats + , si_mb_unspec = mb_unspec' }) } | otherwise -- No calls, inactive, or not a function -- Behave as if there was a single, boring call @@ -1713,7 +1893,9 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) | CP { cp_qvars = qvars, cp_args = pats, cp_strict_args = cbv_args } <- call_pat - = do { spec_uniq <- getUniqueM + = do { -- pprTraceM "spec_one {" (ppr fn <+> ppr pats) + + ; spec_uniq <- getUniqueM ; let env1 = extendScSubstList (extendScInScope env qvars) (arg_bndrs `zip` pats) (body_env, extra_bndrs) = extendBndrs env1 (dropList pats arg_bndrs) @@ -1739,10 +1921,8 @@ -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env) ; (spec_usg, spec_body) <- scExpr body_env body --- ; pprTrace "done spec_one }" (ppr fn $$ ppr (scu_calls spec_usg)) $ --- return () - -- And build the results + ; (qvars', pats') <- generaliseDictPats qvars pats ; let spec_body_ty = exprType spec_body (spec_lam_args, spec_call_args, spec_sig) = calcSpecInfo fn arg_bndrs call_pat extra_bndrs @@ -1751,7 +1931,7 @@ spec_join_arity | isJoinId fn = Just (length spec_call_args) | otherwise = Nothing spec_id = asWorkerLikeId $ - mkLocalId spec_name Many + mkLocalId spec_name ManyTy (mkLamTypes spec_lam_args spec_body_ty) -- See Note [Transfer strictness] `setIdDmdSig` spec_sig @@ -1763,30 +1943,53 @@ 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 - this_mod = sc_module env + this_mod = sc_module $ sc_opts env rule = mkRule this_mod True {- Auto -} True {- Local -} - rule_name inline_act fn_name qvars pats rule_rhs + rule_name inline_act + fn_name qvars' pats' rule_rhs -- See Note [Transfer activation] - -- ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn) - -- , text "sc_count:" <+> ppr (sc_count env) - -- , text "pats:" <+> ppr pats - -- , text "call_pat:" <+> ppr call_pat - -- , text "-->" <+> ppr spec_name - -- , text "bndrs" <+> ppr arg_bndrs - -- , text "extra_bndrs" <+> ppr extra_bndrs - -- , text "spec_lam_args" <+> ppr spec_lam_args - -- , text "spec_call_args" <+> ppr spec_call_args - -- , text "rule_rhs" <+> ppr rule_rhs - -- , text "adds_void_worker_arg" <+> ppr adds_void_worker_arg - -- , text "body" <+> ppr body - -- , text "spec_rhs" <+> ppr spec_rhs - -- , text "how_bound" <+> ppr (sc_how_bound env) ]) $ - -- return () +-- ; pprTraceM "spec_one end }" $ +-- vcat [ text "function:" <+> ppr fn <+> braces (ppr (idUnique fn)) +-- , text "pats:" <+> ppr pats +-- , text "call_pat:" <+> ppr call_pat +-- , text "-->" <+> ppr spec_name +-- , text "bndrs" <+> ppr arg_bndrs +-- , text "extra_bndrs" <+> ppr extra_bndrs +-- , text "cbv_args" <+> ppr cbv_args +-- , text "spec_lam_args" <+> ppr spec_lam_args +-- , text "spec_call_args" <+> ppr spec_call_args +-- , text "rule_rhs" <+> ppr rule_rhs +-- , text "adds_void_worker_arg" <+> ppr add_void_arg +---- , text "body" <+> ppr body +---- , text "spec_rhs" <+> ppr spec_rhs +---- , text "how_bound" <+> ppr (sc_how_bound env) ] +-- ] ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule , os_id = spec_id , os_rhs = spec_rhs }) } +generaliseDictPats :: [Var] -> [CoreExpr] -- Quantified vars and pats + -> UniqSM ([Var], [CoreExpr]) -- New quantified vars and pats +-- See Note [generaliseDictPats] +generaliseDictPats qvars pats + = do { (extra_qvars, pats') <- mapAccumLM go [] pats + ; case extra_qvars of + [] -> return (qvars, pats) + _ -> return (qvars ++ extra_qvars, pats') } + where + qvar_set = mkVarSet qvars + go :: [Id] -> CoreExpr -> UniqSM ([Id], CoreExpr) + go extra_qvs pat + | not (isTyCoArg pat) + , let pat_ty = exprType pat + , typeDeterminesValue pat_ty + , exprFreeVars pat `disjointVarSet` qvar_set + = do { id <- mkSysLocalOrCoVarM (fsLit "dict") ManyTy pat_ty + ; return (id:extra_qvs, Var id) } + | otherwise + = return (extra_qvs, pat) + -- See Note [SpecConstr and strict fields] mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr mkSeqs seqees res_ty rhs = @@ -1892,16 +2095,15 @@ calcSpecInfo fn arg_bndrs (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs = ( spec_lam_bndrs_w_dmds , spec_call_args - , zapDmdEnvSig (DmdSig (dt{dt_args = spec_fn_dmds})) ) + , mkClosedDmdSig [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b] div ) where - DmdSig dt@DmdType{dt_args=fn_dmds} = idDmdSig fn - spec_fn_dmds = [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b] + DmdSig (DmdType _ fn_dmds div) = idDmdSig fn val_pats = filterOut isTypeArg pats -- Value args at call sites, used to determine how many demands to drop - -- from the original functions demand and for setting up arg_dmd_env. - arg_dmd_env = go emptyVarEnv fn_dmds val_pats - qvar_dmds = [ lookupVarEnv arg_dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] + -- from the original functions demand and for setting up dmd_env. + dmd_env = go emptyVarEnv fn_dmds val_pats + qvar_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ] extra_dmds = dropList val_pats fn_dmds -- Annotate the variables with the strictness information from @@ -1925,12 +2127,12 @@ set_dmds (v:vs) ds@(d:ds') | isTyVar v = v : set_dmds vs ds | otherwise = setIdDemandInfo v d : set_dmds vs ds' - go :: VarEnv Demand -> [Demand] -> [CoreExpr] -> VarEnv Demand + go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv -- We've filtered out all the type patterns already go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats go env _ _ = env - go_one :: VarEnv Demand -> Demand -> CoreExpr -> VarEnv Demand + go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv go_one env d (Var v) = extendVarEnv_C plusDmd env v d go_one env (_n :* cd) e -- NB: _n does not have to be strict | (Var _, args) <- collectArgs e @@ -1942,7 +2144,8 @@ Note [spec_usg includes rhs_usg] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In calls to 'specialise', the returned ScUsage must include the rhs_usg in -the passed-in SpecInfo, unless there are no calls at all to the function. +the passed-in SpecInfo in si_mb_unspec, unless there are no calls at all to +the function. The caller can, indeed must, assume this. They should not combine in rhs_usg themselves, or they'll get rhs_usg twice -- and that can lead to an exponential @@ -2159,10 +2362,14 @@ callsToNewPats :: ScEnv -> Id -> SpecInfo -> [ArgOcc] -> [Call] - -> UniqSM (Bool, [CallPat]) - -- Result has no duplicate patterns, - -- nor ones mentioned in done_pats - -- Bool indicates that there was at least one boring pattern + -> UniqSM ( Bool -- At least one boring call + , Bool -- Patterns were discarded + , [CallPat] ) -- Patterns to specialise +-- 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 @@ -2180,9 +2387,8 @@ -- Remove ones that have too many worker variables small_pats = filterOut too_big non_dups - max_args = maxWorkerArgs (sc_dflags env) too_big (CP { cp_qvars = vars, cp_args = args }) - = not (isWorkerSmallEnough max_args (valArgCount args) vars) + = not (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars) -- 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 @@ -2190,12 +2396,11 @@ -- Discard specialisations if there are too many of them (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats --- ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls --- , text "done_specs:" <+> ppr (map os_pat done_specs) --- , text "good_pats:" <+> ppr good_pats ]) $ --- return () +-- ; pprTraceM "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls +-- , 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) } -- 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. @@ -2219,7 +2424,7 @@ n_pats = length pats spec_count' = n_pats + done_spec_count n_remaining = max_specs - done_spec_count - mb_scc = sc_count env + mb_scc = sc_count $ sc_opts env Just max_specs = mb_scc sorted_pats = map fst $ @@ -2244,7 +2449,7 @@ n_cons _ = 0 emit_trace result - | debugIsOn || hasPprDebug (sc_dflags env) + | debugIsOn || sc_debug (sc_opts env) -- Suppress this scary message for ordinary users! #5125 = pprTrace "SpecConstr" msg result | otherwise @@ -2265,7 +2470,7 @@ -- 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 = substInScope (sc_subst env) + = do { let in_scope = getSubstInScope (sc_subst env) ; arg_tripples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args) -- This zip trims the args to be no longer than @@ -2304,29 +2509,29 @@ sanitise id = updateIdTypeAndMult expandTypeSynonyms id -- See Note [Free type variables of the qvar types] - -- Bad coercion variables: see Note [SpecConstr and casts] - bad_covars :: CoVarSet + + -- 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) - ; -- pprTrace "callToPats" (ppr args $$ ppr bndr_occs) $ - warnPprTrace (not (isEmptyVarSet bad_covars)) + ; warnPprTrace (not (isEmptyVarSet bad_covars)) "SpecConstr: bad covars" (ppr bad_covars $$ ppr call) $ + if interesting && isEmptyVarSet bad_covars - then do - -- pprTraceM "callToPatsOut" ( - -- text "fn:" <+> ppr fn $$ - -- text "args:" <+> ppr args $$ - -- text "in_scope:" <+> ppr in_scope $$ - -- -- text "in_scope:" <+> ppr in_scope $$ - -- text "pat_fvs:" <+> ppr pat_fvs - -- ) - -- ppr (CP { cp_qvars = qvars', cp_args = pats })) >> - return (Just (CP { cp_qvars = qvars', cp_args = pats, cp_strict_args = concat cbv_ids })) + then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats + , cp_strict_args = concat cbv_ids } +-- ; pprTraceM "callToPatsOut" $ +-- vcat [ text "fn:" <+> ppr fn +-- , text "args:" <+> ppr args +-- , text "bndr_occs:" <+> ppr bndr_occs +-- , text "pat_fvs:" <+> ppr pat_fvs +-- , text "cp_res:" <+> ppr cp_res ] + ; return (Just cp_res) } else return Nothing } -- argToPat takes an actual argument, and returns an abstracted @@ -2430,7 +2635,7 @@ , Just arg_occs <- mb_scrut dc = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args con_str, matched_str :: [StrictnessMark] - -- con_str corrresponds 1-1 with the /value/ arguments + -- con_str corresponds 1-1 with the /value/ arguments -- matched_str corresponds 1-1 with /all/ arguments con_str = dataConRepStrictness dc matched_str = match_vals con_str rest_args @@ -2450,7 +2655,7 @@ mb_scrut dc = case arg_occ of ScrutOcc bs | Just occs <- lookupUFM bs dc -> Just (occs) -- See Note [Reboxing] - _other | sc_force env || sc_keen env + _other | sc_force env || sc_keen (sc_opts env) -> Just (repeat UnkOcc) | otherwise -> Nothing @@ -2474,10 +2679,8 @@ -- (b) we know what its value is -- In that case it counts as "interesting" argToPat1 env in_scope val_env (Var v) arg_occ arg_str - | sc_force env || case arg_occ of { ScrutOcc {} -> True - ; UnkOcc -> False - ; NoOcc -> False } -- (a) - , is_value -- (b) + | sc_force env || specialisableArgOcc arg_occ -- (a) + , is_value -- (b) -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing] -- So sc_keen focused just on f (I# x), where we have freshly-allocated -- box that we can eliminate in the caller @@ -2518,7 +2721,7 @@ -- | wildCardPats are always boring wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id]) wildCardPat ty str - = do { id <- mkSysLocalOrCoVarM (fsLit "sc") Many ty + = do { id <- mkSysLocalOrCoVarM (fsLit "sc") ManyTy ty -- ; pprTraceM "wildCardPat" (ppr id' <+> ppr (idUnfolding id')) ; return (False, varToCoreExpr id, if isMarkedStrict str then [id] else []) } @@ -2552,12 +2755,14 @@ isValue _env expr -- Maybe it's a constructor application | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr - = case isDataConWorkId_maybe fun of - - Just con | args `lengthAtLeast` dataConRepArity con + = case idDetails fun of + DataConWorkId con | args `lengthAtLeast` dataConRepArity con -- Check saturated; might be > because the -- arity excludes type args -> Just (ConVal (DataAlt con) args) + + DFunId {} -> Just LambdaVal + -- DFunId: see Note [Specialising on dictionaries] _other | valArgCount args < idArity fun -- Under-applied function 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,3107 +1,3453 @@ - - -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -{- -(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 - -\section[Specialise]{Stamping out overloading, and (optionally) polymorphism} --} - -module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where - -import GHC.Prelude - -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Config -import GHC.Driver.Config.Diagnostic -import GHC.Driver.Env - -import GHC.Tc.Utils.TcType hiding( substTy ) - -import GHC.Core.Type hiding( substTy, extendTvSubstList ) -import GHC.Core.Multiplicity -import GHC.Core.Predicate -import GHC.Core.Coercion( Coercion ) -import GHC.Core.Opt.Monad -import qualified GHC.Core.Subst as Core -import GHC.Core.Unfold.Make -import GHC.Core -import GHC.Core.Rules -import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable - , getIdFromTrivialExpr_maybe - , mkCast, exprType ) -import GHC.Core.FVs -import GHC.Core.TyCo.Rep (TyCoBinder (..)) -import GHC.Core.Opt.Arity ( collectBindersPushingCo - , etaExpandToJoinPointRule ) - -import GHC.Builtin.Types ( unboxedUnitTy ) - -import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust ) -import GHC.Data.Bag -import GHC.Data.FastString -import GHC.Data.List.SetOps - -import GHC.Types.Basic -import GHC.Types.Unique.Supply -import GHC.Types.Unique.DFM -import GHC.Types.Name -import GHC.Types.Tickish -import GHC.Types.Id.Make ( voidArgId, voidPrimId ) -import GHC.Types.Var ( isLocalVar, mkLocalVar ) -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Error - -import GHC.Utils.Error ( mkMCDiagnostic ) -import GHC.Utils.Monad ( foldlM ) -import GHC.Utils.Misc -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Trace -import GHC.Utils.Panic.Plain( assert ) - -import GHC.Unit.Module( Module ) -import GHC.Unit.Module.ModGuts -import GHC.Unit.External - -{- -************************************************************************ -* * -\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]} -* * -************************************************************************ - -These notes describe how we implement specialisation to eliminate -overloading. - -The specialisation pass works on Core -syntax, complete with all the explicit dictionary application, -abstraction and construction as added by the type checker. The -existing type checker remains largely as it is. - -One important thought: the {\em types} passed to an overloaded -function, and the {\em dictionaries} passed are mutually redundant. -If the same function is applied to the same type(s) then it is sure to -be applied to the same dictionary(s)---or rather to the same {\em -values}. (The arguments might look different but they will evaluate -to the same value.) - -Second important thought: we know that we can make progress by -treating dictionary arguments as static and worth specialising on. So -we can do without binding-time analysis, and instead specialise on -dictionary arguments and no others. - -The basic idea -~~~~~~~~~~~~~~ -Suppose we have - - let f = - in - -and suppose f is overloaded. - -STEP 1: CALL-INSTANCE COLLECTION - -We traverse , accumulating all applications of f to types and -dictionaries. - -(Might there be partial applications, to just some of its types and -dictionaries? In principle yes, but in practice the type checker only -builds applications of f to all its types and dictionaries, so partial -applications could only arise as a result of transformation, and even -then I think it's unlikely. In any case, we simply don't accumulate such -partial applications.) - - -STEP 2: EQUIVALENCES - -So now we have a collection of calls to f: - f t1 t2 d1 d2 - f t3 t4 d3 d4 - ... -Notice that f may take several type arguments. To avoid ambiguity, we -say that f is called at type t1/t2 and t3/t4. - -We take equivalence classes using equality of the *types* (ignoring -the dictionary args, which as mentioned previously are redundant). - -STEP 3: SPECIALISATION - -For each equivalence class, choose a representative (f t1 t2 d1 d2), -and create a local instance of f, defined thus: - - f@t1/t2 = t1 t2 d1 d2 - -f_rhs presumably has some big lambdas and dictionary lambdas, so lots -of simplification will now result. However we don't actually *do* that -simplification. Rather, we leave it for the simplifier to do. If we -*did* do it, though, we'd get more call instances from the specialised -RHS. We can work out what they are by instantiating the call-instance -set from f's RHS with the types t1, t2. - -Add this new id to f's IdInfo, to record that f has a specialised version. - -Before doing any of this, check that f's IdInfo doesn't already -tell us about an existing instance of f at the required type/s. -(This might happen if specialisation was applied more than once, or -it might arise from user SPECIALIZE pragmas.) - -Recursion -~~~~~~~~~ -Wait a minute! What if f is recursive? Then we can't just plug in -its right-hand side, can we? - -But it's ok. The type checker *always* creates non-recursive definitions -for overloaded recursive functions. For example: - - f x = f (x+x) -- Yes I know its silly - -becomes - - f a (d::Num a) = let p = +.sel a d - in - letrec fl (y::a) = fl (p y y) - in - fl - -We still have recursion for non-overloaded functions which we -specialise, but the recursive call should get specialised to the -same recursive version. - - -Polymorphism 1 -~~~~~~~~~~~~~~ - -All this is crystal clear when the function is applied to *constant -types*; that is, types which have no type variables inside. But what if -it is applied to non-constant types? Suppose we find a call of f at type -t1/t2. There are two possibilities: - -(a) The free type variables of t1, t2 are in scope at the definition point -of f. In this case there's no problem, we proceed just as before. A common -example is as follows. Here's the Haskell: - - g y = let f x = x+x - in f y + f y - -After typechecking we have - - g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x - in +.sel a d (f a d y) (f a d y) - -Notice that the call to f is at type type "a"; a non-constant type. -Both calls to f are at the same type, so we can specialise to give: - - g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x - in +.sel a d (f@a y) (f@a y) - - -(b) The other case is when the type variables in the instance types -are *not* in scope at the definition point of f. The example we are -working with above is a good case. There are two instances of (+.sel a d), -but "a" is not in scope at the definition of +.sel. Can we do anything? -Yes, we can "common them up", a sort of limited common sub-expression deal. -This would give: - - g a (d::Num a) (y::a) = let +.sel@a = +.sel a d - f@a (x::a) = +.sel@a x x - in +.sel@a (f@a y) (f@a y) - -This can save work, and can't be spotted by the type checker, because -the two instances of +.sel weren't originally at the same type. - -Further notes on (b) - -* There are quite a few variations here. For example, the defn of - +.sel could be floated outside the \y, to attempt to gain laziness. - It certainly mustn't be floated outside the \d because the d has to - be in scope too. - -* We don't want to inline f_rhs in this case, because -that will duplicate code. Just commoning up the call is the point. - -* Nothing gets added to +.sel's IdInfo. - -* Don't bother unless the equivalence class has more than one item! - -Not clear whether this is all worth it. It is of course OK to -simply discard call-instances when passing a big lambda. - -Polymorphism 2 -- Overloading -~~~~~~~~~~~~~~ -Consider a function whose most general type is - - f :: forall a b. Ord a => [a] -> b -> b - -There is really no point in making a version of g at Int/Int and another -at Int/Bool, because it's only instantiating the type variable "a" which -buys us any efficiency. Since g is completely polymorphic in b there -ain't much point in making separate versions of g for the different -b types. - -That suggests that we should identify which of g's type variables -are constrained (like "a") and which are unconstrained (like "b"). -Then when taking equivalence classes in STEP 2, we ignore the type args -corresponding to unconstrained type variable. In STEP 3 we make -polymorphic versions. Thus: - - f@t1/ = /\b -> t1 b d1 d2 - -We do this. - - -Dictionary floating -~~~~~~~~~~~~~~~~~~~ -Consider this - - f a (d::Num a) = let g = ... - in - ...(let d1::Ord a = Num.Ord.sel a d in g a d1)... - -Here, g is only called at one type, but the dictionary isn't in scope at the -definition point for g. Usually the type checker would build a -definition for d1 which enclosed g, but the transformation system -might have moved d1's defn inward. Solution: float dictionary bindings -outwards along with call instances. - -Consider - - f x = let g p q = p==q - h r s = (r+s, g r s) - in - h x x - - -Before specialisation, leaving out type abstractions we have - - f df x = let g :: Eq a => a -> a -> Bool - g dg p q = == dg p q - h :: Num a => a -> a -> (a, Bool) - h dh r s = let deq = eqFromNum dh - in (+ dh r s, g deq r s) - in - h df x x - -After specialising h we get a specialised version of h, like this: - - h' r s = let deq = eqFromNum df - in (+ df r s, g deq r s) - -But we can't naively make an instance for g from this, because deq is not in scope -at the defn of g. Instead, we have to float out the (new) defn of deq -to widen its scope. Notice that this floating can't be done in advance -- it only -shows up when specialisation is done. - -User SPECIALIZE pragmas -~~~~~~~~~~~~~~~~~~~~~~~ -Specialisation pragmas can be digested by the type checker, and implemented -by adding extra definitions along with that of f, in the same way as before - - f@t1/t2 = t1 t2 d1 d2 - -Indeed the pragmas *have* to be dealt with by the type checker, because -only it knows how to build the dictionaries d1 and d2! For example - - g :: Ord a => [a] -> [a] - {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} - -Here, the specialised version of g is an application of g's rhs to the -Ord dictionary for (Tree Int), which only the type checker can conjure -up. There might not even *be* one, if (Tree Int) is not an instance of -Ord! (All the other specialision has suitable dictionaries to hand -from actual calls.) - -Problem. The type checker doesn't have to hand a convenient , because -it is buried in a complex (as-yet-un-desugared) binding group. -Maybe we should say - - f@t1/t2 = f* t1 t2 d1 d2 - -where f* is the Id f with an IdInfo which says "inline me regardless!". -Indeed all the specialisation could be done in this way. -That in turn means that the simplifier has to be prepared to inline absolutely -any in-scope let-bound thing. - - -Again, the pragma should permit polymorphism in unconstrained variables: - - h :: Ord a => [a] -> b -> b - {-# SPECIALIZE h :: [Int] -> b -> b #-} - -We *insist* that all overloaded type variables are specialised to ground types, -(and hence there can be no context inside a SPECIALIZE pragma). -We *permit* unconstrained type variables to be specialised to - - a ground type - - or left as a polymorphic type variable -but nothing in between. So - - {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} - -is *illegal*. (It can be handled, but it adds complication, and gains the -programmer nothing.) - - -SPECIALISING INSTANCE DECLARATIONS -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - instance Foo a => Foo [a] where - ... - {-# SPECIALIZE instance Foo [Int] #-} - -The original instance decl creates a dictionary-function -definition: - - dfun.Foo.List :: forall a. Foo a -> Foo [a] - -The SPECIALIZE pragma just makes a specialised copy, just as for -ordinary function definitions: - - dfun.Foo.List@Int :: Foo [Int] - dfun.Foo.List@Int = dfun.Foo.List Int dFooInt - -The information about what instance of the dfun exist gets added to -the dfun's IdInfo in the same way as a user-defined function too. - - -Automatic instance decl specialisation? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Can instance decls be specialised automatically? It's tricky. -We could collect call-instance information for each dfun, but -then when we specialised their bodies we'd get new call-instances -for ordinary functions; and when we specialised their bodies, we might get -new call-instances of the dfuns, and so on. This all arises because of -the unrestricted mutual recursion between instance decls and value decls. - -Still, there's no actual problem; it just means that we may not do all -the specialisation we could theoretically do. - -Furthermore, instance decls are usually exported and used non-locally, -so we'll want to compile enough to get those specialisations done. - -Lastly, there's no such thing as a local instance decl, so we can -survive solely by spitting out *usage* information, and then reading that -back in as a pragma when next compiling the file. So for now, -we only specialise instance decls in response to pragmas. - - -SPITTING OUT USAGE INFORMATION -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -To spit out usage information we need to traverse the code collecting -call-instance information for all imported (non-prelude?) functions -and data types. Then we equivalence-class it and spit it out. - -This is done at the top-level when all the call instances which escape -must be for imported functions and data types. - -*** Not currently done *** - - -Partial specialisation by pragmas -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What about partial specialisation: - - k :: (Ord a, Eq b) => [a] -> b -> b -> [a] - {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} - -or even - - {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} - -Seems quite reasonable. Similar things could be done with instance decls: - - instance (Foo a, Foo b) => Foo (a,b) where - ... - {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} - {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} - -Ho hum. Things are complex enough without this. I pass. - - -Requirements for the simplifier -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The simplifier has to be able to take advantage of the specialisation. - -* When the simplifier finds an application of a polymorphic f, it looks in -f's IdInfo in case there is a suitable instance to call instead. This converts - - f t1 t2 d1 d2 ===> f_t1_t2 - -Note that the dictionaries get eaten up too! - -* Dictionary selection operations on constant dictionaries must be - short-circuited: - - +.sel Int d ===> +Int - -The obvious way to do this is in the same way as other specialised -calls: +.sel has inside it some IdInfo which tells that if it's applied -to the type Int then it should eat a dictionary and transform to +Int. - -In short, dictionary selectors need IdInfo inside them for constant -methods. - -* Exactly the same applies if a superclass dictionary is being - extracted: - - Eq.sel Int d ===> dEqInt - -* Something similar applies to dictionary construction too. Suppose -dfun.Eq.List is the function taking a dictionary for (Eq a) to -one for (Eq [a]). Then we want - - dfun.Eq.List Int d ===> dEq.List_Int - -Where does the Eq [Int] dictionary come from? It is built in -response to a SPECIALIZE pragma on the Eq [a] instance decl. - -In short, dfun Ids need IdInfo with a specialisation for each -constant instance of their instance declaration. - -All this uses a single mechanism: the SpecEnv inside an Id - - -What does the specialisation IdInfo look like? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The SpecEnv of an Id maps a list of types (the template) to an expression - - [Type] |-> Expr - -For example, if f has this RuleInfo: - - [Int, a] -> \d:Ord Int. f' a - -it means that we can replace the call - - f Int t ===> (\d. f' t) - -This chucks one dictionary away and proceeds with the -specialised version of f, namely f'. - - -What can't be done this way? -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is no way, post-typechecker, to get a dictionary for (say) -Eq a from a dictionary for Eq [a]. So if we find - - ==.sel [t] d - -we can't transform to - - eqList (==.sel t d') - -where - eqList :: (a->a->Bool) -> [a] -> [a] -> Bool - -Of course, we currently have no way to automatically derive -eqList, nor to connect it to the Eq [a] instance decl, but you -can imagine that it might somehow be possible. Taking advantage -of this is permanently ruled out. - -Still, this is no great hardship, because we intend to eliminate -overloading altogether anyway! - -A note about non-tyvar dictionaries -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Some Ids have types like - - forall a,b,c. Eq a -> Ord [a] -> tau - -This seems curious at first, because we usually only have dictionary -args whose types are of the form (C a) where a is a type variable. -But this doesn't hold for the functions arising from instance decls, -which sometimes get arguments with types of form (C (T a)) for some -type constructor T. - -Should we specialise wrt this compound-type dictionary? We used to say -"no", saying: - "This is a heuristic judgement, as indeed is the fact that we - specialise wrt only dictionaries. We choose *not* to specialise - wrt compound dictionaries because at the moment the only place - they show up is in instance decls, where they are simply plugged - into a returned dictionary. So nothing is gained by specialising - wrt them." - -But it is simpler and more uniform to specialise wrt these dicts too; -and in future GHC is likely to support full fledged type signatures -like - f :: Eq [(a,b)] => ... - - -************************************************************************ -* * -\subsubsection{The new specialiser} -* * -************************************************************************ - -Our basic game plan is this. For let(rec) bound function - f :: (C a, D c) => (a,b,c,d) -> Bool - -* Find any specialised calls of f, (f ts ds), where - ts are the type arguments t1 .. t4, and - ds are the dictionary arguments d1 .. d2. - -* Add a new definition for f1 (say): - - f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 - - Note that we abstract over the unconstrained type arguments. - -* Add the mapping - - [t1,b,t3,d] |-> \d1 d2 -> f1 b d - - to the specialisations of f. This will be used by the - simplifier to replace calls - (f t1 t2 t3 t4) da db - by - (\d1 d1 -> f1 t2 t4) da db - - All the stuff about how many dictionaries to discard, and what types - to apply the specialised function to, are handled by the fact that the - SpecEnv contains a template for the result of the specialisation. - -We don't build *partial* specialisations for f. For example: - - f :: Eq a => a -> a -> Bool - {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-} - -Here, little is gained by making a specialised copy of f. -There's a distinct danger that the specialised version would -first build a dictionary for (Eq b, Eq c), and then select the (==) -method from it! Even if it didn't, not a great deal is saved. - -We do, however, generate polymorphic, but not overloaded, specialisations: - - f :: Eq a => [a] -> b -> b -> b - ... SPECIALISE f :: [Int] -> b -> b -> b ... - -Hence, the invariant is this: - - *** no specialised version is overloaded *** - - -************************************************************************ -* * -\subsubsection{The exported function} -* * -************************************************************************ --} - --- | Specialise calls to type-class overloaded functions occurring in a program. -specProgram :: ModGuts -> CoreM ModGuts -specProgram guts@(ModGuts { mg_module = this_mod - , mg_rules = local_rules - , mg_binds = binds }) - = do { dflags <- getDynFlags - - -- We need to start with a Subst that knows all the things - -- that are in scope, so that the substitution engine doesn't - -- accidentally re-use a unique that's already in use - -- Easiest thing is to do it all at once, as if all the top-level - -- decls were mutually recursive - ; let top_env = SE { se_subst = Core.mkEmptySubst $ mkInScopeSet $ mkVarSet $ - bindersOfBinds binds - , se_interesting = emptyVarSet - , se_module = this_mod - , se_dflags = dflags } - - go [] = return ([], emptyUDs) - go (bind:binds) = do (binds', uds) <- go binds - (bind', uds') <- specBind top_env bind uds - return (bind' ++ binds', uds') - - -- Specialise the bindings of this module - ; (binds', uds) <- runSpecM (go binds) - - ; (spec_rules, spec_binds) <- specImports top_env local_rules uds - - ; return (guts { mg_binds = spec_binds ++ binds' - , mg_rules = spec_rules ++ local_rules }) } - -{- -Note [Wrap bindings returned by specImports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'specImports' returns a set of specialized bindings. However, these are lacking -necessary floated dictionary bindings, which are returned by -UsageDetails(ud_binds). These dictionaries need to be brought into scope with -'wrapDictBinds' before the bindings returned by 'specImports' can be used. See, -for instance, the 'specImports' call in 'specProgram'. - - -Note [Disabling cross-module specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Since GHC 7.10 we have performed specialisation of INLINABLE bindings living -in modules outside of the current module. This can sometimes uncover user code -which explodes in size when aggressively optimized. The --fno-cross-module-specialise option was introduced to allow users to being -bitten by such instances to revert to the pre-7.10 behavior. - -See #10491 --} - - -{- ********************************************************************* -* * - Specialising imported functions -* * -********************************************************************* -} - -specImports :: SpecEnv - -> [CoreRule] - -> UsageDetails - -> CoreM ([CoreRule], [CoreBind]) -specImports top_env local_rules - (MkUD { ud_binds = dict_binds, ud_calls = calls }) - | not $ gopt Opt_CrossModuleSpecialise (se_dflags top_env) - -- See Note [Disabling cross-module specialisation] - = return ([], wrapDictBinds dict_binds []) - - | otherwise - = do { hpt_rules <- getRuleBase - ; let rule_base = extendRuleBaseList hpt_rules local_rules - - ; (spec_rules, spec_binds) <- spec_imports top_env [] rule_base - dict_binds calls - - -- Don't forget to wrap the specialized bindings with - -- bindings for the needed dictionaries. - -- See Note [Wrap bindings returned by specImports] - -- and Note [Glom the bindings if imported functions are specialised] - ; let final_binds - | null spec_binds = wrapDictBinds dict_binds [] - | otherwise = [Rec $ flattenBinds $ - wrapDictBinds dict_binds spec_binds] - - ; return (spec_rules, final_binds) - } - --- | Specialise a set of calls to imported bindings -spec_imports :: SpecEnv -- Passed in so that all top-level Ids are in scope - -> [Id] -- Stack of imported functions being specialised - -- See Note [specImport call stack] - -> RuleBase -- Rules from this module and the home package - -- (but not external packages, which can change) - -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls - -- See Note [Avoiding loops in specImports] - -> CallDetails -- Calls for imported things - -> CoreM ( [CoreRule] -- New rules - , [CoreBind] ) -- Specialised bindings -spec_imports top_env callers rule_base dict_binds calls - = do { let import_calls = dVarEnvElts calls --- ; debugTraceMsg (text "specImports {" <+> --- vcat [ text "calls:" <+> ppr import_calls --- , text "dict_binds:" <+> ppr dict_binds ]) - ; (rules, spec_binds) <- go rule_base import_calls --- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls) - - ; return (rules, spec_binds) } - where - go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind]) - go _ [] = return ([], []) - go rb (cis : other_calls) - = do { -- debugTraceMsg (text "specImport {" <+> ppr cis) - ; (rules1, spec_binds1) <- spec_import top_env callers rb dict_binds cis - ; -- debugTraceMsg (text "specImport }" <+> ppr cis) - - ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls - ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } - -spec_import :: SpecEnv -- Passed in so that all top-level Ids are in scope - -> [Id] -- Stack of imported functions being specialised - -- See Note [specImport call stack] - -> RuleBase -- Rules from this module - -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls - -- See Note [Avoiding loops in specImports] - -> CallInfoSet -- Imported function and calls for it - -> CoreM ( [CoreRule] -- New rules - , [CoreBind] ) -- Specialised bindings -spec_import top_env callers rb dict_binds cis@(CIS fn _) - | isIn "specImport" fn callers - = return ([], []) -- No warning. This actually happens all the time - -- when specialising a recursive function, because - -- the RHS of the specialised function contains a recursive - -- call to the original function - - | null good_calls - = return ([], []) - - | Just rhs <- canSpecImport dflags fn - = do { -- Get rules from the external package state - -- We keep doing this in case we "page-fault in" - -- more rules as we go along - ; hsc_env <- getHscEnv - ; eps <- liftIO $ hscEPS hsc_env - ; vis_orphs <- getVisibleOrphanMods - ; let rules_for_fn = getRules (RuleEnv [rb, eps_rule_base eps] vis_orphs) fn - - ; -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) - ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls }) - <- runSpecM $ specCalls True top_env dict_binds - rules_for_fn good_calls fn rhs - - ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] - -- After the rules kick in we may get recursion, but - -- we rely on a global GlomBinds to sort that out later - -- See Note [Glom the bindings if imported functions are specialised] - - -- Now specialise any cascaded calls - ; -- debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1)) - ; (rules2, spec_binds2) <- spec_imports top_env - (fn:callers) - (extendRuleBaseList rb rules1) - (dict_binds `thenFDBs` dict_binds1) - new_calls - - ; let final_binds = wrapDictBinds dict_binds1 $ - spec_binds2 ++ spec_binds1 - - ; return (rules2 ++ rules1, final_binds) } - - | otherwise - = do { tryWarnMissingSpecs dflags callers fn good_calls - ; return ([], [])} - - where - dflags = se_dflags top_env - good_calls = filterCalls cis dict_binds - -- SUPER IMPORTANT! Drop calls that (directly or indirectly) refer to fn - -- See Note [Avoiding loops in specImports] - -canSpecImport :: DynFlags -> Id -> Maybe CoreExpr --- See Note [Specialise imported INLINABLE things] -canSpecImport dflags fn - | CoreUnfolding { uf_src = src, uf_tmpl = rhs } <- unf - , isStableSource src - = Just rhs -- By default, specialise only imported things that have a stable - -- unfolding; that is, have an INLINE or INLINABLE pragma - -- Specialise even INLINE things; it hasn't inlined yet, - -- so perhaps it never will. Moreover it may have calls - -- inside it that we want to specialise - - -- CoreUnfolding case does /not/ include DFunUnfoldings; - -- We only specialise DFunUnfoldings with -fspecialise-aggressively - -- See Note [Do not specialise imported DFuns] - - | gopt Opt_SpecialiseAggressively dflags - = maybeUnfoldingTemplate unf -- With -fspecialise-aggressively, specialise anything - -- with an unfolding, stable or not, DFun or not - - | otherwise = Nothing - where - unf = realIdUnfolding fn -- We want to see the unfolding even for loop breakers - --- | Returns whether or not to show a missed-spec warning. --- If -Wall-missed-specializations is on, show the warning. --- Otherwise, if -Wmissed-specializations is on, only show a warning --- if there is at least one imported function being specialized, --- and if all imported functions are marked with an inline pragma --- Use the most specific warning as the reason. -tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () --- See Note [Warning about missed specialisations] -tryWarnMissingSpecs dflags callers fn calls_for_fn - | isClassOpId fn = return () -- See Note [Missed specialisation for ClassOps] - | wopt Opt_WarnMissedSpecs dflags - && not (null callers) - && allCallersInlined = doWarn $ WarningWithFlag Opt_WarnMissedSpecs - | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ WarningWithFlag Opt_WarnAllMissedSpecs - | otherwise = return () - where - allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers - diag_opts = initDiagOpts dflags - doWarn reason = - msg (mkMCDiagnostic diag_opts reason) - (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) - 2 (vcat [ text "when specialising" <+> quotes (ppr caller) - | caller <- callers]) - , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) - , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) - -{- Note [Missed specialisation for ClassOps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In #19592 I saw a number of missed specialisation warnings -which were the result of things like: - - case isJumpishInstr @X86.Instr $dInstruction_s7f8 eta3_a78C of { ... - -where isJumpishInstr is part of the Instruction class and defined like -this: - - class Instruction instr where - ... - isJumpishInstr :: instr -> Bool - ... - -isJumpishInstr is a ClassOp which will select the right method -from within the dictionary via our built in rules. See also -Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance. - -We don't give these unfoldings, and as a result the specialiser -complains. But usually this doesn't matter. The simplifier will -apply the rule and we end up with - - case isJumpishInstrImplX86 eta3_a78C of { ... - -Since isJumpishInstrImplX86 is defined for a concrete instance (given -by the dictionary) it is usually already well specialised! -Theoretically the implementation of a method could still be overloaded -over a different type class than what it's a method of. But I wasn't able -to make this go wrong, and SPJ thinks this should be fine as well. - -So I decided to remove the warnings for failed specialisations on ClassOps -alltogether as they do more harm than good. --} - -{- Note [Do not specialise imported DFuns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Ticket #18223 shows that specialising calls of DFuns is can cause a huge -and entirely unnecessary blowup in program size. Consider a call to - f @[[[[[[[[T]]]]]]]] d1 x -where df :: C a => C [a] - d1 :: C [[[[[[[[T]]]]]]]] = dfC[] @[[[[[[[T]]]]]]] d1 - d2 :: C [[[[[[[T]]]]]]] = dfC[] @[[[[[[T]]]]]] d3 - ... -Now we'll specialise f's RHS, which may give rise to calls to 'g', -also overloaded, which we will specialise, and so on. However, if -we specialise the calls to dfC[], we'll generate specialised copies of -all methods of C, at all types; and the same for C's superclasses. - -And many of these specialised functions will never be called. We are -going to call the specialised 'f', and the specialised 'g', but DFuns -group functions into a tuple, many of whose elements may never be used. - -With deeply-nested types this can lead to a simply overwhelming number -of specialisations: see #18223 for a simple example (from the wild). -I measured the number of specialisations for various numbers of calls -of `flip evalStateT ()`, and got this - - Size after one simplification - #calls #SPEC rules Terms Types - 5 56 3100 10600 - 9 108 13660 77206 - -The real tests case has 60+ calls, which blew GHC out of the water. - -Solution: don't specialise DFuns. The downside is that if we end -up with (h (dfun d)), /and/ we don't specialise 'h', then we won't -pass to 'h' a tuple of specialised functions. - -However, the flag -fspecialise-aggressively (experimental, off by default) -allows DFuns to specialise as well. - -Note [Avoiding loops in specImports] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must take great care when specialising instance declarations -(DFuns like $fOrdList) lest we accidentally build a recursive -dictionary. See Note [Avoiding loops (DFuns)]. - -The basic strategy of Note [Avoiding loops (DFuns)] is to use filterCalls -to discard loopy specialisations. But to do that we must ensure -that the in-scope dict-binds (passed to filterCalls) contains -all the needed dictionary bindings. In particular, in the recursive -call to spec_imports in spec_import, we must include the dict-binds -from the parent. Lacking this caused #17151, a really nasty bug. - -Here is what happened. -* Class structure: - Source is a superclass of Mut - Index is a superclass of Source - -* We started with these dict binds - dSource = $fSourcePix @Int $fIndexInt - dIndex = sc_sel dSource - dMut = $fMutPix @Int dIndex - and these calls to specialise - $fMutPix @Int dIndex - $fSourcePix @Int $fIndexInt - -* We specialised the call ($fMutPix @Int dIndex) - ==> new call ($fSourcePix @Int dIndex) - (because Source is a superclass of Mut) - -* We specialised ($fSourcePix @Int dIndex) - ==> produces specialised dict $s$fSourcePix, - a record with dIndex as a field - plus RULE forall d. ($fSourcePix @Int d) = $s$fSourcePix - *** This is the bogus step *** - -* Now we decide not to specialise the call - $fSourcePix @Int $fIndexInt - because we alredy have a RULE that matches it - -* Finally the simplifer rewrites - dSource = $fSourcePix @Int $fIndexInt - ==> dSource = $s$fSourcePix - -Disaster. Now we have - -Rewrite dSource's RHS to $s$fSourcePix Disaster - dSource = $s$fSourcePix - dIndex = sc_sel dSource - $s$fSourcePix = MkSource dIndex ... - -Solution: filterCalls should have stopped the bogus step, -by seeing that dIndex transitively uses $fSourcePix. But -it can only do that if it sees all the dict_binds. Wow. - --------------- -Here's another example (#13429). Suppose we have - class Monoid v => C v a where ... - -We start with a call - f @ [Integer] @ Integer $fC[]Integer - -Specialising call to 'f' gives dict bindings - $dMonoid_1 :: Monoid [Integer] - $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer - - $dC_1 :: C [Integer] (Node [Integer] Integer) - $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 - -...plus a recursive call to - f @ [Integer] @ (Node [Integer] Integer) $dC_1 - -Specialising that call gives - $dMonoid_2 :: Monoid [Integer] - $dMonoid_2 = M.$p1C @ [Integer] $dC_1 - - $dC_2 :: C [Integer] (Node [Integer] Integer) - $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2 - -Now we have two calls to the imported function - M.$fCvNode :: Monoid v => C v a - M.$fCvNode @v @a m = C m some_fun - -But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2) -for specialisation, else we get: - - $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 - $dMonoid_2 = M.$p1C @ [Integer] $dC_1 - $s$fCvNode = C $dMonoid_2 ... - RULE M.$fCvNode [Integer] _ _ = $s$fCvNode - -Now use the rule to rewrite the call in the RHS of $dC_1 -and we get a loop! - - -Note [specImport call stack] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When specialising an imports function 'f', we may get new calls -of an imported function 'g', which we want to specialise in turn, -and similarly specialising 'g' might expose a new call to 'h'. - -We track the stack of enclosing functions. So when specialising 'h' we -have a specImport call stack of [g,f]. We do this for two reasons: -* Note [Warning about missed specialisations] -* Note [Avoiding recursive specialisation] - -Note [Warning about missed specialisations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose - * In module Lib, you carefully mark a function 'foo' INLINABLE - * Import Lib(foo) into another module M - * Call 'foo' at some specialised type in M -Then you jolly well expect it to be specialised in M. But what if -'foo' calls another function 'Lib.bar'. Then you'd like 'bar' to be -specialised too. But if 'bar' is not marked INLINABLE it may well -not be specialised. The warning Opt_WarnMissedSpecs warns about this. - -It's more noisy to warning about a missed specialisation opportunity -for /every/ overloaded imported function, but sometimes useful. That -is what Opt_WarnAllMissedSpecs does. - -ToDo: warn about missed opportunities for local functions. - -Note [Avoiding recursive specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we specialise 'f' we may find new overloaded calls to 'g', 'h' in -'f's RHS. So we want to specialise g,h. But we don't want to -specialise f any more! It's possible that f's RHS might have a -recursive yet-more-specialised call, so we'd diverge in that case. -And if the call is to the same type, one specialisation is enough. -Avoiding this recursive specialisation loop is one reason for the -'callers' stack passed to specImports and specImport. - -Note [Specialise imported INLINABLE things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What imported functions do we specialise? The basic set is - * DFuns and things with INLINABLE pragmas. -but with -fspecialise-aggressively we add - * Anything with an unfolding template - -#8874 has a good example of why we want to auto-specialise DFuns. - -We have the -fspecialise-aggressively flag (usually off), because we -risk lots of orphan modules from over-vigorous specialisation. -However it's not a big deal: anything non-recursive with an -unfolding-template will probably have been inlined already. - -Note [Glom the bindings if imported functions are specialised] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have an imported, *recursive*, INLINABLE function - f :: Eq a => a -> a - f = /\a \d x. ...(f a d)... -In the module being compiled we have - g x = f (x::Int) -Now we'll make a specialised function - f_spec :: Int -> Int - f_spec = \x -> ...(f Int dInt)... - {-# RULE f Int _ = f_spec #-} - g = \x. f Int dInt x -Note that f_spec doesn't look recursive -After rewriting with the RULE, we get - f_spec = \x -> ...(f_spec)... -BUT since f_spec was non-recursive before it'll *stay* non-recursive. -The occurrence analyser never turns a NonRec into a Rec. So we must -make sure that f_spec is recursive. Easiest thing is to make all -the specialisations for imported bindings recursive. - - - -************************************************************************ -* * -\subsubsection{@specExpr@: the main function} -* * -************************************************************************ --} - -data SpecEnv - = SE { se_subst :: Core.Subst - -- We carry a substitution down: - -- a) we must clone any binding that might float outwards, - -- to avoid name clashes - -- b) we carry a type substitution to use when analysing - -- the RHS of specialised bindings (no type-let!) - - - , se_interesting :: VarSet - -- Dict Ids that we know something about - -- and hence may be worth specialising against - -- See Note [Interesting dictionary arguments] - - , se_module :: Module - , se_dflags :: DynFlags - } - -instance Outputable SpecEnv where - ppr (SE { se_subst = subst, se_interesting = interesting }) - = text "SE" <+> braces (sep $ punctuate comma - [ text "subst =" <+> ppr subst - , text "interesting =" <+> ppr interesting ]) - -specVar :: SpecEnv -> Id -> CoreExpr -specVar env v = Core.lookupIdSubst (se_subst env) v - -specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) - ----------------- First the easy cases -------------------- -specExpr env (Type ty) = return (Type (substTy env ty), emptyUDs) -specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs) -specExpr env (Var v) = return (specVar env v, emptyUDs) -specExpr _ (Lit lit) = return (Lit lit, emptyUDs) -specExpr env (Cast e co) - = do { (e', uds) <- specExpr env e - ; return ((mkCast e' (substCo env co)), uds) } -specExpr env (Tick tickish body) - = do { (body', uds) <- specExpr env body - ; return (Tick (specTickish env tickish) body', uds) } - ----------------- Applications might generate a call instance -------------------- -specExpr top_env expr@(App {}) - = go top_env expr [] - where - go env (App fun arg) args = do (arg', uds_arg) <- specExpr env arg - let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_arg - -- Some dicts may have floated out of arg; - -- they should be in scope (#21689) - (fun', uds_app) <- go env_args fun (arg':args) - return (App fun' arg', uds_arg `thenUDs` uds_app) - - go env (Var f) args = case specVar env f of - Var f' -> return (Var f', mkCallUDs env f' args) - e' -> return (e', emptyUDs) -- I don't expect this! - go env other _ = specExpr env other - ----------------- Lambda/case require dumping of usage details -------------------- -specExpr env e@(Lam {}) - = specLam env' bndrs' body - where - (bndrs, body) = collectBinders e - (env', bndrs') = substBndrs env bndrs - -- More efficient to collect a group of binders together all at once - -- and we don't want to split a lambda group with dumped bindings - -specExpr env (Case scrut case_bndr ty alts) - = do { (scrut', scrut_uds) <- specExpr env scrut - ; (scrut'', case_bndr', alts', alts_uds) - <- specCase env scrut' case_bndr alts - ; return (Case scrut'' case_bndr' (substTy env ty) alts' - , scrut_uds `thenUDs` alts_uds) } - ----------------- Finally, let is the interesting case -------------------- -specExpr env (Let bind body) - = do { -- Clone binders - (rhs_env, body_env, bind') <- cloneBindSM env bind - - -- Deal with the body - ; (body', body_uds) <- specExpr body_env body - - -- Deal with the bindings - ; (binds', uds) <- specBind rhs_env bind' body_uds - - -- All done - ; return (foldr Let body' binds', uds) } - --------------- -specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails) --- The binders have been substituted, but the body has not -specLam env bndrs body - | null bndrs - = specExpr env body - | otherwise - = do { (body', uds) <- specExpr env body - ; let (free_uds, dumped_dbs) = dumpUDs bndrs uds - ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) } - --------------- -specTickish :: SpecEnv -> CoreTickish -> CoreTickish -specTickish env (Breakpoint ext ix ids) - = Breakpoint ext ix [ id' | id <- ids, Var id' <- [specVar env 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 - --------------- -specCase :: SpecEnv - -> CoreExpr -- Scrutinee, already done - -> Id -> [CoreAlt] - -> SpecM ( CoreExpr -- New scrutinee - , Id - , [CoreAlt] - , UsageDetails) -specCase env scrut' case_bndr [Alt con args rhs] - | isDictId case_bndr -- See Note [Floating dictionaries out of cases] - , interestingDict env scrut' - , not (isDeadBinder case_bndr && null sc_args') - = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') - - ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg') - [Alt con args' (Var sc_arg')] - | sc_arg' <- sc_args' ] - - -- Extend the substitution for RHS to map the *original* binders - -- to their floated versions. - mb_sc_flts :: [Maybe DictId] - mb_sc_flts = map (lookupVarEnv clone_env) args' - clone_env = zipVarEnv sc_args' sc_args_flt - subst_prs = (case_bndr, Var case_bndr_flt) - : [ (arg, Var sc_flt) - | (arg, Just sc_flt) <- args `zip` mb_sc_flts ] - env_rhs' = env_rhs { se_subst = Core.extendIdSubstList (se_subst env_rhs) subst_prs - , se_interesting = se_interesting env_rhs `extendVarSetList` - (case_bndr_flt : sc_args_flt) } - - ; (rhs', rhs_uds) <- specExpr env_rhs' rhs - ; let scrut_bind = mkDB (NonRec case_bndr_flt scrut') - case_bndr_set = unitVarSet case_bndr_flt - sc_binds = [ DB { db_bind = NonRec sc_arg_flt sc_rhs - , db_fvs = case_bndr_set } - | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ] - flt_binds = scrut_bind : sc_binds - (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds - all_uds = flt_binds `consDictBinds` free_uds - alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs') - ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } - where - (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args) - sc_args' = filter is_flt_sc_arg args' - - clone_me bndr = do { uniq <- getUniqueM - ; return (mkUserLocalOrCoVar occ uniq wght ty loc) } - where - name = idName bndr - wght = idMult bndr - ty = idType bndr - occ = nameOccName name - loc = getSrcSpan name - - arg_set = mkVarSet args' - is_flt_sc_arg var = isId var - && not (isDeadBinder var) - && isDictTy var_ty - && tyCoVarsOfType var_ty `disjointVarSet` arg_set - 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) } - where - (env_alt, case_bndr') = substBndr env case_bndr - spec_alt (Alt con args rhs) = do - (rhs', uds) <- specExpr env_rhs rhs - let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds - return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) - where - (env_rhs, args') = substBndrs env_alt args - -{- -Note [Floating dictionaries out of cases] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - g = \d. case d of { MkD sc ... -> ...(f sc)... } -Naively we can't float d2's binding out of the case expression, -because 'sc' is bound by the case, and that in turn means we can't -specialise f, which seems a pity. - -So we invert the case, by floating out a binding -for 'sc_flt' thus: - sc_flt = case d of { MkD sc ... -> sc } -Now we can float the call instance for 'f'. Indeed this is just -what'll happen if 'sc' was originally bound with a let binding, -but case is more efficient, and necessary with equalities. So it's -good to work with both. - -You might think that this won't make any difference, because the -call instance will only get nuked by the \d. BUT if 'g' itself is -specialised, then transitively we should be able to specialise f. - -In general, given - case e of cb { MkD sc ... -> ...(f sc)... } -we transform to - let cb_flt = e - sc_flt = case cb_flt of { MkD sc ... -> sc } - in - case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... } - -The "_flt" things are the floated binds; we use the current substitution -to substitute sc -> sc_flt in the RHS - -************************************************************************ -* * - Dealing with a binding -* * -************************************************************************ --} - -bringFloatedDictsIntoScope :: SpecEnv -> FloatedDictBinds -> SpecEnv -bringFloatedDictsIntoScope env (FDB { fdb_bndrs = dx_bndrs }) - = -- pprTrace "brought into scope" (ppr dx_bndrs) $ - env {se_subst=subst'} - where - subst' = se_subst env `Core.extendSubstInScopeSet` dx_bndrs - -specBind :: SpecEnv -- Use this for RHSs - -> CoreBind -- Binders are already cloned by cloneBindSM, - -- but RHSs are un-processed - -> UsageDetails -- Info on how the scope of the binding - -> SpecM ([CoreBind], -- New bindings - UsageDetails) -- And info to pass upstream - --- Returned UsageDetails: --- No calls for binders of this bind -specBind rhs_env (NonRec fn rhs) body_uds - = do { (rhs', rhs_uds) <- specExpr rhs_env rhs - - ; let zapped_fn = zapIdDemandInfo fn - -- We zap the demand info because the binding may float, - -- which would invaidate the demand info (see #17810 for example). - -- Destroying demand info is not terrible; specialisation is - -- always followed soon by demand analysis. - ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds zapped_fn rhs - - ; let pairs = spec_defns ++ [(fn', rhs')] - -- fn' mentions the spec_defns in its rules, - -- so put the latter first - - combined_uds = body_uds1 `thenUDs` rhs_uds - - (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds - - final_binds :: [DictBind] - -- See Note [From non-recursive to recursive] - final_binds - | not (isEmptyBag dump_dbs) - , not (null spec_defns) - = [recWithDumpedDicts pairs dump_dbs] - | otherwise - = [mkDB $ NonRec b r | (b,r) <- pairs] - ++ bagToList dump_dbs - - can_float_this_one = exprIsTopLevelBindable rhs (idType fn) - -- exprIsTopLevelBindable: see Note [Care with unlifted bindings] - - ; if float_all && can_float_this_one then - -- Rather than discard the calls mentioning the bound variables - -- we float this (dictionary) binding along with the others - return ([], free_uds `snocDictBinds` final_binds) - else - -- No call in final_uds mentions bound variables, - -- so we can just leave the binding here - return (map db_bind final_binds, free_uds) } - - -specBind rhs_env (Rec pairs) body_uds - -- Note [Specialising a recursive group] - = do { let (bndrs,rhss) = unzip pairs - ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss - ; let scope_uds = body_uds `thenUDs` rhs_uds - -- Includes binds and calls arising from rhss - - ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs - - ; (bndrs3, spec_defns3, uds3) - <- if null spec_defns1 -- Common case: no specialisation - then return (bndrs1, [], uds1) - else do { -- Specialisation occurred; do it again - (bndrs2, spec_defns2, uds2) - <- specDefns rhs_env uds1 (bndrs1 `zip` rhss) - ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) } - - ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3 - final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss') - dumped_dbs - - ; if float_all then - return ([], final_uds `snocDictBind` final_bind) - else - return ([db_bind final_bind], final_uds) } - - ---------------------------- -specDefns :: SpecEnv - -> UsageDetails -- Info on how it is used in its scope - -> [(OutId,InExpr)] -- The things being bound and their un-processed RHS - -> SpecM ([OutId], -- Original Ids with RULES added - [(OutId,OutExpr)], -- Extra, specialised bindings - UsageDetails) -- Stuff to fling upwards from the specialised versions - --- Specialise a list of bindings (the contents of a Rec), but flowing usages --- upwards binding by binding. Example: { f = ...g ...; g = ...f .... } --- Then if the input CallDetails has a specialised call for 'g', whose specialisation --- in turn generates a specialised call for 'f', we catch that in this one sweep. --- But not vice versa (it's a fixpoint problem). - -specDefns _env uds [] - = return ([], [], uds) -specDefns env uds ((bndr,rhs):pairs) - = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs - ; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs - ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) } - ---------------------------- -specDefn :: SpecEnv - -> UsageDetails -- Info on how it is used in its scope - -> OutId -> InExpr -- The thing being bound and its un-processed RHS - -> SpecM (Id, -- Original Id with added RULES - [(Id,CoreExpr)], -- Extra, specialised bindings - UsageDetails) -- Stuff to fling upwards from the specialised versions - -specDefn env body_uds fn rhs - = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds - rules_for_me = idCoreRules fn - dict_binds = ud_binds body_uds - - ; (rules, spec_defns, spec_uds) <- specCalls False env dict_binds - rules_for_me calls_for_me fn rhs - - ; return ( fn `addIdSpecialisations` rules - , spec_defns - , body_uds_without_me `thenUDs` spec_uds) } - -- It's important that the `thenUDs` is this way - -- round, because body_uds_without_me may bind - -- dictionaries that are used in calls_for_me passed - -- to specDefn. So the dictionary bindings in - -- spec_uds may mention dictionaries bound in - -- body_uds_without_me - ---------------------------- -specCalls :: Bool -- True => specialising imported fn - -- False => specialising local fn - -> SpecEnv - -> FloatedDictBinds -- Just so that we can extend the in-scope set - -> [CoreRule] -- Existing RULES for the fn - -> [CallInfo] - -> OutId -> InExpr - -> SpecM SpecInfo -- New rules, specialised bindings, and usage details - --- This function checks existing rules, and does not create --- duplicate ones. So the caller does not need to do this filtering. --- See 'already_covered' - -type SpecInfo = ( [CoreRule] -- Specialisation rules - , [(Id,CoreExpr)] -- Specialised definition - , UsageDetails ) -- Usage details from specialised RHSs - -specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs - -- The first case is the interesting one - | notNull calls_for_me -- And there are some calls to specialise - && not (isNeverActive (idInlineActivation fn)) - -- Don't specialise NOINLINE things - -- See Note [Auto-specialisation and RULES] - -- - -- Don't specialise OPAQUE things, see Note [OPAQUE pragma]. - -- Since OPAQUE things are always never-active (see - -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for - -- OPAQUE things. - --- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small --- See Note [Inline specialisations] for why we do not --- switch off specialisation for inline functions - - = -- pprTrace "specCalls: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $ - 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) - "Missed specialisation opportunity" (ppr fn $$ _trace_doc) $ - -- Note [Specialisation shape] - -- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $ - return ([], [], emptyUDs) - where - _trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ] - - fn_type = idType fn - fn_arity = idArity fn - fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here - inl_prag = idInlinePragma fn - inl_act = inlinePragmaActivation inl_prag - is_local = isLocalId fn - is_dfun = isDFunId fn - dflags = se_dflags env - this_mod = se_module env - -- 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] - - -- Bring into scope the binders from the floated dicts - env_with_dict_bndrs = bringFloatedDictsIntoScope env dict_binds - - already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool - already_covered env new_rules args -- Note [Specialisations already covered] - = isJust (specLookupRule env fn args (new_rules ++ existing_rules)) - -- NB: we look both in the new_rules (generated by this invocation - -- of specCalls), and in existing_rules (passed in to specCalls) - - ---------------------------------------------------------- - -- Specialise to one particular call pattern - spec_call :: SpecInfo -- Accumulating parameter - -> CallInfo -- Call instance - -> SpecM SpecInfo - spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) _ci@(CI { ci_key = call_args }) - = -- See Note [Specialising Calls] - do { let all_call_args | is_dfun = call_args ++ repeat UnspecArg - | otherwise = call_args - -- See Note [Specialising DFuns] - ; ( useful, rhs_env2, leftover_bndrs - , rule_bndrs, rule_lhs_args - , spec_bndrs1, dx_binds, spec_args) <- specHeader env_with_dict_bndrs - rhs_bndrs all_call_args - --- ; 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_body" <+> ppr rhs_body --- , text "rhs_env2: " <+> ppr (se_subst rhs_env2) --- , ppr dx_binds ]) $ --- return () - - ; if not useful -- No useful specialisation - || already_covered rhs_env2 rules_acc rule_lhs_args - then return spec_acc - else - do { -- Run the specialiser on the specialised RHS - -- The "1" suffix is before we maybe add the void arg - ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs1 ++ leftover_bndrs) rhs_body - ; let spec_fn_ty1 = exprType spec_rhs1 - - -- 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 - - simpl_opts = initSimpleOpts dflags - - -------------------------------------- - -- Add a suitable unfolding if the spec_inl_prag says so - -- See Note [Inline specialisations] - (spec_inl_prag, spec_unf) - | not is_local && isStrongLoopBreaker (idOccInfo fn) - = (neverInlinePragma, noUnfolding) - -- See Note [Specialising imported functions] in "GHC.Core.Opt.OccurAnal" - - | isInlinablePragma inl_prag - = (inl_prag { inl_inline = NoUserInlinePrag }, noUnfolding) - - | otherwise - = (inl_prag, specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args) - 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 - - -------------------------------------- - -- Add a suitable unfolding; see Note [Inline specialisations] - -- The wrap_unf_body applies the original unfolding to the specialised - -- arguments, not forgetting to wrap the dx_binds around the outside (#22358) - spec_fn_info - = vanillaIdInfo `setArityInfo` max 0 (fn_arity - arity_decr) - `setInlinePragInfo` spec_inl_prag - `setUnfoldingInfo` spec_unf - - -- Compute the IdDetails of the specialise Id - -- See Note [Transfer IdDetails during specialisation] - spec_fn_details - = case idDetails fn of - JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing - DFunId is_nt -> DFunId is_nt - _ -> VanillaId - - ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info - ; let - -- The rule to put in the function's specialisation is: - -- forall x @b d1' d2'. - -- f x @T1 @b @T2 d1' d2' = f1 x @b - -- See Note [Specialising Calls] - herald | spec_imp = -- Specialising imported fn - text "SPEC/" <> ppr this_mod - | otherwise = -- Specialising local fn - text "SPEC" - - rule_name = mkFastString $ showSDoc dflags $ - herald <+> ftext (occNameFS (getOccName fn)) - <+> hsep (mapMaybe ppr_call_key_ty call_args) - -- This name ends up in interface files, so use occNameString. - -- Otherwise uniques end up there, making builds - -- less deterministic (See #4012 comment:61 ff) - - rule_wout_eta = mkRule - this_mod - True {- Auto generated -} - is_local - rule_name - inl_act -- Note [Auto-specialisation and RULES] - (idName fn) - rule_bndrs - rule_lhs_args - (mkVarApps (Var spec_fn) spec_bndrs) - - spec_rule - = case isJoinId_maybe fn of - Just join_arity -> etaExpandToJoinPointRule join_arity rule_wout_eta - Nothing -> rule_wout_eta - - -- Add the { d1' = dx1; d2' = dx2 } usage stuff - -- See Note [Specialising Calls] - spec_uds = foldr consDictBind rhs_uds dx_binds - - spec_f_w_arity = spec_fn - - _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type - , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty - , ppr rhs_bndrs, ppr call_args - , ppr spec_rule - ] - - ; -- 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 - ) } } - --- Convenience function for invoking lookupRule from Specialise --- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr] -specLookupRule :: SpecEnv -> Id -> [CoreExpr] -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -specLookupRule env fn args rules - = lookupRule ropts (in_scope, realIdUnfolding) (const True) fn args rules - where - dflags = se_dflags env - in_scope = Core.substInScope (se_subst env) - ropts = initRuleOpts dflags - - -{- Note [Specialising DFuns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -DFuns have a special sort of unfolding (DFunUnfolding), and it is -hard to specialise a DFunUnfolding to give another DFunUnfolding -unless the DFun is fully applied (#18120). So, in the case of DFunIds -we simply extend the CallKey with trailing UnspecArgs, so we'll -generate a rule that completely saturates the DFun. - -There is an ASSERT that checks this, in the DFunUnfolding case of -GHC.Core.Unfold.specUnfolding. - -Note [Transfer IdDetails during specialisation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When specialising a function, `newSpecIdSM` comes up with a fresh Id the -specialised RHS will be bound to. It is critical that we get the `IdDetails` of -the specialised Id correct: - -* JoinId: We want the specialised Id to be a join point, too. But - we have to carefully adjust the arity - -* DFunId: It is crucial that we also make the new Id a DFunId. - - First, because it obviously /is/ a DFun, having a DFunUnfolding and - all that; see Note [Specialising DFuns] - - - Second, DFuns get very delicate special treatment in the demand analyser; - see GHC.Core.Opt.DmdAnal.enterDFun. If the specialised function isn't - also a DFunId, this special treatment doesn't happen, so the demand - analyser makes a too-strict DFun, and we get an infinite loop. See Note - [Do not strictify a DFun's parameter dictionaries] in GHC.Core.Opt.DmdAnal. - #22549 describes the loop, and (lower down) a case where a /specialised/ - DFun caused a loop. - -* WorkerLikeId: Introduced by WW, so after Specialise. Nevertheless, they come - up when specialising imports. We must keep them as VanillaIds because WW - will detect them as WorkerLikeIds again. That is, unless specialisation - allows unboxing of all previous CBV args, in which case sticking to - VanillaIds was the only correct choice to begin with. - -* RecSelId, DataCon*Id, ClassOpId, PrimOpId, FCallId, CoVarId, TickBoxId: - Never specialised. - -Note [Specialisation Must Preserve Sharing] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a function: - - f :: forall a. Eq a => a -> blah - f = - if expensive - then f1 - else f2 - -As written, all calls to 'f' will share 'expensive'. But if we specialise 'f' -at 'Int', eg: - - $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2) - - RULE "SPEC f" - forall (d :: Eq Int). - f Int _ = $sfIntf - -We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes! - -To avoid this, we only generate specialisations for functions whose arity is -enough to bind all of the arguments we need to specialise. This ensures our -specialised functions don't do any work before receiving all of their dicts, -and thus avoids the 'f' case above. - -Note [Specialisations Must Be Lifted] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a function 'f': - - f = forall a. Eq a => Array# a - -used like - - case x of - True -> ...f @Int dEqInt... - False -> 0 - -Naively, we might generate an (expensive) specialisation - - $sfInt :: Array# Int - -even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to -the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to -preserve laziness. - -Note [Care with unlifted bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider (#22998) - f x = let x::ByteArray# = - n::Natural = NB x - in wombat @192827 (n |> co) -where - co :: Natural ~ KnownNat 192827 - wombat :: forall (n:Nat). KnownNat n => blah - -Left to itself, the specialiser would float the bindings for `x` and `n` to top -level, so we can specialise `wombat`. But we can't have a top-level ByteArray# -(see Note [Core letrec invariant] in GHC.Core). Boo. - -This is pretty exotic, so we take a simple way out: in specBind (the NonRec -case) do not float the binding itself unless it satisfies exprIsTopLevelBindable. -This is conservative: maybe the RHS of `x` has a free var that would stop it -floating to top level anyway; but that is hard to spot (since we don't know what -the non-top-level in-scope binders are) and rare (since the binding must satisfy -Note [Core let-can-float invariant] in GHC.Core). - - -Note [Specialising Calls] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have a function with a complicated type: - - f :: forall a b c. Int -> Eq a => Show b => c -> Blah - f @a @b @c i dEqA dShowA x = blah - -and suppose it is called at: - - f 7 @T1 @T2 @T3 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 ] - -Why are 'a' and 'b' identified as 'SpecType', while 'c' is 'UnspecType'? -Because we must specialise the function on type variables that appear -free in its *dictionary* arguments; but not on type variables that do not -appear in any dictionaries, i.e. are fully polymorphic. - -Because this call has dictionaries applied, we'd like to specialise -the call on any type argument that appears free in those dictionaries. -In this case, those are [a :-> T1, b :-> T2]. - -We also need to substitute the dictionary binders with their -specialised dictionaries. The simplest substitution would be -[dEqA :-> dEqT1, dShowA :-> $dfShow dShowT2], but this duplicates -work, since `$dfShow dShowT2` is a function application. Therefore, we -also want to *float the dictionary out* (via bindAuxiliaryDict), -creating a new dict binding - - dShow1 = $dfShow dShowT2 - -and the substitution [dEqA :-> dEqT1, dShowA :-> dShow1]. - -With the substitutions in hand, we can generate a specialised function: - - $sf :: forall c. Int -> c -> Blah - $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah) - -Note that the substitution is applied to the whole thing. This is -convenient, but just slightly fragile. Notably: - * There had better be no name clashes in a/b/c - -We must construct a rewrite rule: - - RULE "SPEC f @T1 @T2 _" - forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2). - f @T1 @T2 @c i d1 d2 = $sf @c i - -In the rule, d1 and d2 are just wildcards, not used in the RHS. Note -additionally that 'x' isn't captured by this rule --- we bind only -enough etas in order to capture all of the *specialised* arguments. - -Note [Drop dead args from specialisations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When specialising a function, it’s possible some of the arguments may -actually be dead. For example, consider: - - f :: forall a. () -> Show a => a -> String - f x y = show y ++ "!" - -We might generate the following CallInfo for `f @Int`: - - [SpecType Int, UnspecArg, SpecDict $dShowInt, UnspecArg] - -Normally we’d include both the x and y arguments in the -specialisation, since we’re not specialising on either of them. But -that’s silly, since x is actually unused! So we might as well drop it -in the specialisation: - - $sf :: Int -> String - $sf y = show y ++ "!" - - {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-} - -This doesn’t save us much, since the arg would be removed later by -worker/wrapper, anyway, but it’s easy to do. Note, however, that we -only drop dead arguments if: - - 1. We don’t specialise on them. - 2. They come before an argument we do specialise on. - - The right thing to do is to produce a LitRubbish; it should rapidly - disappear. Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let. - -Note [Zap occ info in rule binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we generate a specialisation RULE, we need to drop occurrence -info on the binders. If we don’t, things go wrong when we specialise a -function like - - f :: forall a. () -> Show a => a -> String - f x y = show y ++ "!" - -since we’ll generate a RULE like - - RULE "SPEC f @Int" forall x [Occ=Dead]. - f @Int x $dShow = $sf - -and Core Lint complains, even though x only appears on the LHS (due to -Note [Drop dead args from specialisations]). - -Why is that a Lint error? Because the arguments on the LHS of a rule -are syntactically expressions, not patterns, so Lint treats the -appearance of x as a use rather than a binding. Fortunately, the -solution is simple: we just make sure to zap the occ info before -using ids as wildcard binders in a rule. - -Note [Account for casts in binding] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - f :: Eq a => a -> IO () - {-# INLINABLE f - StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g - #-} - f = ... - -In f's stable unfolding we have done some modest simplification which -has pushed the cast to the outside. (I wonder if this is the Right -Thing, but it's what happens now; see GHC.Core.Opt.Simplify.Utils Note [Casts and -lambdas].) Now that stable unfolding must be specialised, so we want -to push the cast back inside. It would be terrible if the cast -defeated specialisation! Hence the use of collectBindersPushingCo. - -Note [Evidence foralls] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose (#12212) that we are specialising - 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). - f Int Int d g = f_spec -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 - * exprsFreeIdsList returns the Ids bound by the args, - which won't include g - -You might wonder if this will match as often, but the simplifier replaces -complicated Refl coercions with Refl pretty aggressively. - -Note [Orphans and auto-generated rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we specialise an INLINABLE function, or when we have --fspecialise-aggressively, we auto-generate RULES that are orphans. -We don't want to warn about these, or we'd generate a lot of warnings. -Thus, we only warn about user-specified orphan rules. - -Indeed, we don't even treat the module as an orphan module if it has -auto-generated *rule* orphans. Orphan modules are read every time we -compile, so they are pretty obtrusive and slow down every compilation, -even non-optimised ones. (Reason: for type class instances it's a -type correctness issue.) But specialisation rules are strictly for -*optimisation* only so it's fine not to read the interface. - -What this means is that a SPEC rules from auto-specialisation in -module M will be used in other modules only if M.hi has been read for -some other reason, which is actually pretty likely. - -Note [From non-recursive to recursive] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Even in the non-recursive case, if any dict-binds depend on 'fn' we might -have built a recursive knot - - f a d x = - MkUD { ud_binds = NonRec d7 (MkD ..f..) - , ud_calls = ...(f T d7)... } - -The we generate - - Rec { fs x = [T/a, d7/d] - f a d x = - RULE f T _ = fs - d7 = ...f... } - -Here the recursion is only through the RULE. - -However we definitely should /not/ make the Rec in this wildly common -case: - d = ... - MkUD { ud_binds = NonRec d7 (...d...) - , ud_calls = ...(f T d7)... } - -Here we want simply to add d to the floats, giving - MkUD { ud_binds = NonRec d (...) - NonRec d7 (...d...) - , ud_calls = ...(f T d7)... } - -In general, we need only make this Rec if - - there are some specialisations (spec_binds non-empty) - - there are some dict_binds that depend on f (dump_dbs non-empty) - -Note [Avoiding loops (DFuns)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When specialising /dictionary functions/ we must be very careful to -avoid building loops. Here is an example that bit us badly, on -several distinct occasions. - -Here is one: #3591 - class Eq a => C a - instance Eq [a] => C [a] - -This translates to - dfun :: Eq [a] -> C [a] - dfun a d = MkD a d (meth d) - - d4 :: Eq [T] = - d2 :: C [T] = dfun T d4 - d1 :: Eq [T] = $p1 d2 - d3 :: C [T] = dfun T d1 - -None of these definitions is recursive. What happened was that we -generated a specialisation: - RULE forall d. dfun T d = dT :: C [T] - dT = (MkD a d (meth d)) [T/a, d1/d] - = MkD T d1 (meth d1) - -But now we use the RULE on the RHS of d2, to get - d2 = dT = MkD d1 (meth d1) - d1 = $p1 d2 - -and now d1 is bottom! The problem is that when specialising 'dfun' we -should first dump "below" the binding all floated dictionary bindings -that mention 'dfun' itself. So d2 and d3 (and hence d1) must be -placed below 'dfun', and thus unavailable to it when specialising -'dfun'. That in turn means that the call (dfun T d1) must be -discarded. On the other hand, the call (dfun T d4) is fine, assuming -d4 doesn't mention dfun. - -Solution: - Discard all calls that mention dictionaries that depend - (directly or indirectly) on the dfun we are specialising. - This is done by 'filterCalls' - -Note [Avoiding loops (non-DFuns)] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The whole Note [Avoiding loops (DFuns)] things applies only to DFuns. -It's important /not/ to apply filterCalls to non-DFuns. For example: - - class C a where { foo,bar :: [a] -> [a] } - - instance C Int where - foo x = r_bar x - bar xs = reverse xs - - r_bar :: C a => [a] -> [a] - r_bar xs = bar (xs ++ xs) - -That translates to: - - r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) - - Rec { $fCInt :: C Int = MkC foo_help reverse - foo_help (xs::[Int]) = r_bar Int $fCInt xs } - -The call (r_bar $fCInt) mentions $fCInt, - which mentions foo_help, - which mentions r_bar - -But we DO want to specialise r_bar at Int: - Rec { $fCInt :: C Int = MkC foo_help reverse - foo_help (xs::[Int]) = r_bar Int $fCInt xs - - r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) - RULE r_bar Int _ = r_bar_Int - - r_bar_Int xs = bar Int $fCInt (xs ++ xs) - } - -Note that, because of its RULE, r_bar joins the recursive -group. (In this case it'll unravel a short moment later.) -See test simplCore/should_compile/T19599a. - -Another example is #19599, which looked like this: - - class (Show a, Enum a) => MyShow a where - myShow :: a -> String - - myShow_impl :: MyShow a => a -> String - - foo :: Int -> String - foo = myShow_impl @Int $fMyShowInt - - Rec { $fMyShowInt = MkMyShowD $fEnumInt $fShowInt $cmyShow - ; $cmyShow = myShow_impl @Int $fMyShowInt } - -Here, we really do want to specialise `myShow_impl @Int $fMyShowInt`. - - -Note [Specialising a recursive group] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - let rec { f x = ...g x'... - ; g y = ...f y'.... } - in f 'a' -Here we specialise 'f' at Char; but that is very likely to lead to -a specialisation of 'g' at Char. We must do the latter, else the -whole point of specialisation is lost. - -But we do not want to keep iterating to a fixpoint, because in the -presence of polymorphic recursion we might generate an infinite number -of specialisations. - -So we use the following heuristic: - * Arrange the rec block in dependency order, so far as possible - (the occurrence analyser already does this) - - * Specialise it much like a sequence of lets - - * Then go through the block a second time, feeding call-info from - the RHSs back in the bottom, as it were - -In effect, the ordering maxmimises the effectiveness of each sweep, -and we do just two sweeps. This should catch almost every case of -monomorphic recursion -- the exception could be a very knotted-up -recursion with multiple cycles tied up together. - -This plan is implemented in the Rec case of specBindItself. - -Note [Specialisations already covered] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We obviously don't want to generate two specialisations for the same -argument pattern. There are two 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 - -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 - -Note [Auto-specialisation and RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: - g :: Num a => a -> a - g = ... - - f :: (Int -> Int) -> Int - f w = ... - {-# RULE f g = 0 #-} - -Suppose that auto-specialisation makes a specialised version of -g::Int->Int That version won't appear in the LHS of the RULE for f. -So if the specialisation rule fires too early, the rule for f may -never fire. - -It might be possible to add new rules, to "complete" the rewrite system. -Thus when adding - RULE forall d. g Int d = g_spec -also add - RULE f g_spec = 0 - -But that's a bit complicated. For now we ask the programmer's help, -by *copying the INLINE activation pragma* to the auto-specialised -rule. So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule -will also not be active until phase 2. And that's what programmers -should jolly well do anyway, even aside from specialisation, to ensure -that g doesn't inline too early. - -This in turn means that the RULE would never fire for a NOINLINE -thing so not much point in generating a specialisation at all. - -Note [Specialisation shape] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only specialise a function if it has visible top-level lambdas -corresponding to its overloading. E.g. if - f :: forall a. Eq a => .... -then its body must look like - f = /\a. \d. ... - -Reason: when specialising the body for a call (f ty dexp), we want to -substitute dexp for d, and pick up specialised calls in the body of f. - -We do allow casts, however; see Note [Account for casts in binding]. - -This doesn't always work. One example I came across was this: - newtype Gen a = MkGen{ unGen :: Int -> a } - - choose :: Eq a => a -> Gen a - choose n = MkGen (\r -> n) - - oneof = choose (1::Int) - -It's a silly example, but we get - choose = /\a. g `cast` co -where choose doesn't have any dict arguments. Thus far I have not -tried to fix this (wait till there's a real example). - -Mind you, then 'choose' will be inlined (since RHS is trivial) so -it doesn't matter. This comes up with single-method classes - - class C a where { op :: a -> a } - instance C a => C [a] where .... -==> - $fCList :: C a => C [a] - $fCList = $copList |> (...coercion>...) - ....(uses of $fCList at particular types)... - -So we suppress the WARN if the rhs is trivial. - -Note [Inline specialisations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here is what we do with the InlinePragma of the original function - * Activation/RuleMatchInfo: both transferred to the - specialised function - * InlineSpec: - (a) An INLINE pragma is transferred - (b) An INLINABLE pragma is *not* transferred - -Why (a): transfer INLINE pragmas? The point of INLINE was precisely to -specialise the function at its call site, and arguably that's not so -important for the specialised copies. BUT *pragma-directed* -specialisation now takes place in the typechecker/desugarer, with -manually specified INLINEs. The specialisation here is automatic. -It'd be very odd if a function marked INLINE was specialised (because -of some local use), and then forever after (including importing -modules) the specialised version wasn't INLINEd. After all, the -programmer said INLINE! - -You might wonder why we specialise INLINE functions at all. After -all they should be inlined, right? Two reasons: - - * Even INLINE functions are sometimes not inlined, when they aren't - applied to interesting arguments. But perhaps the type arguments - alone are enough to specialise (even though the args are too boring - to trigger inlining), and it's certainly better to call the - specialised version. - - * The RHS of an INLINE function might call another overloaded function, - and we'd like to generate a specialised version of that function too. - This actually happens a lot. Consider - replicateM_ :: (Monad m) => Int -> m a -> m () - {-# INLINABLE replicateM_ #-} - replicateM_ d x ma = ... - The strictness analyser may transform to - replicateM_ :: (Monad m) => Int -> m a -> m () - {-# INLINE replicateM_ #-} - replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma - - $wreplicateM_ :: (Monad m) => Int# -> m a -> m () - {-# INLINABLE $wreplicateM_ #-} - $wreplicateM_ = ... - Now an importing module has a specialised call to replicateM_, say - (replicateM_ dMonadIO). We certainly want to specialise $wreplicateM_! - This particular example had a huge effect on the call to replicateM_ - in nofib/shootout/n-body. - -Why (b): discard INLINABLE pragmas? See #4874 for persuasive examples. -Suppose we have - {-# INLINABLE f #-} - f :: Ord a => [a] -> Int - f xs = letrec f' = ...f'... in f' -Then, when f is specialised and optimised we might get - wgo :: [Int] -> Int# - wgo = ...wgo... - f_spec :: [Int] -> Int - f_spec xs = case wgo xs of { r -> I# r } -and we clearly want to inline f_spec at call sites. But if we still -have the big, un-optimised of f (albeit specialised) captured in an -INLINABLE pragma for f_spec, we won't get that optimisation. - -So we simply drop INLINABLE pragmas when specialising. It's not really -a complete solution; ignoring specialisation for now, INLINABLE functions -don't get properly strictness analysed, for example. But it works well -for examples involving specialisation, which is the dominant use of -INLINABLE. See #4874. --} - -{- ********************************************************************* -* * - SpecArg, and specHeader -* * -********************************************************************* -} - --- | An argument that we might want to specialise. --- See Note [Specialising Calls] for the nitty gritty details. -data SpecArg - = - -- | Type arguments that should be specialised, due to appearing - -- free in the type of a 'SpecDict'. - SpecType Type - - -- | Type arguments that should remain polymorphic. - | UnspecType - - -- | Dictionaries that should be specialised. mkCallUDs ensures - -- that only "interesting" dictionary arguments get a SpecDict; - -- see Note [Interesting dictionary arguments] - | SpecDict DictExpr - - -- | Value arguments that should not be specialised. - | 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" - -specArgFreeVars :: SpecArg -> VarSet -specArgFreeVars (SpecType ty) = tyCoVarsOfType ty -specArgFreeVars (SpecDict dx) = exprFreeVars dx -specArgFreeVars UnspecType = emptyVarSet -specArgFreeVars UnspecArg = emptyVarSet - -isSpecDict :: SpecArg -> Bool -isSpecDict (SpecDict {}) = True -isSpecDict _ = False - --- | Given binders from an original function 'f', and the 'SpecArg's --- corresponding to its usage, compute everything necessary to build --- a specialisation. --- --- We will use the running example from Note [Specialising Calls]: --- --- f :: forall a b c. Int -> Eq a => Show b => c -> Blah --- f @a @b @c i dEqA dShowA x = blah --- --- Suppose we decide to specialise it at the following pattern: --- --- [ SpecType T1, SpecType T2, UnspecType, UnspecArg --- , SpecDict dEqT1, SpecDict ($dfShow dShowT2), UnspecArg ] --- --- We'd eventually like to build the RULE --- --- RULE "SPEC f @T1 @T2 _" --- forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2). --- f @T1 @T2 @c i d1 d2 = $sf @c i --- --- and the specialisation '$sf' --- --- $sf :: forall c. Int -> c -> Blah --- $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah) --- --- where dShow1 is a floated binding created by bindAuxiliaryDict. --- --- The cases for 'specHeader' below are presented in the same order as this --- running example. The result of 'specHeader' for this example is as follows: --- --- ( -- Returned arguments --- env + [a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] --- , [x] --- --- -- RULE helpers --- , [c, i, d1, d2] --- , [T1, T2, c, i, d1, d2] --- --- -- Specialised function helpers --- , [c, i, x] --- , [dShow1 = $dfShow dShowT2] --- , [T1, T2, c, i, dEqT1, dShow1] --- ) -specHeader - :: SpecEnv - -> [InBndr] -- The 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 - - -- RULE helpers - , [OutBndr] -- Binders for the RULE - , [OutExpr] -- 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" - ) - --- 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 t : args) - = do { let env' = extendTvSubstList env [(bndr, t)] - ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env' bndrs args - ; pure ( useful - , env'' - , leftover_bndrs - , rule_bs - , Type t : rule_es - , bs' - , dx - , Type t : 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 - ) - } - --- 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) - = 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 - ) - } - --- Finally, we have the unspecialised argument 'i'. We need to produce --- a binder, LHS and RHS argument for the RULE, and a binder for the --- specialised body. --- --- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is --- 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) (UnspecArg : args) - = 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 - ; pure ( useful - , env'' - , leftover_bndrs - , bndr' : rule_bs - , varToCoreExpr bndr' : rule_es - , if isDeadBinder bndr - then bs' -- see Note [Drop dead args from specialisations] - else bndr' : bs' - , dx - , varToCoreExpr bndr' : spec_args - ) - } - --- If we run out of binders, stop immediately --- See Note [Specialisation Must Preserve Sharing] -specHeader env [] _ = pure (False, env, [], [], [], [], [], []) - --- 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 - - --- | Binds a dictionary argument to a fresh name, to preserve sharing -bindAuxiliaryDict - :: SpecEnv - -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression - -> ( SpecEnv -- Substitutes for orig_dict_id - , Maybe DictBind -- Auxiliary dict binding, if any - , OutExpr) -- Witnessing expression (always trivial) -bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting }) - orig_dict_id fresh_dict_id dict_expr - - -- If the dictionary argument is trivial, - -- don’t bother creating a new dict binding; just substitute - | Just dict_id <- getIdFromTrivialExpr_maybe dict_expr - = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr - -- See Note [Keep the old dictionaries interesting] - , se_interesting = interesting `extendVarSet` dict_id } - in (env', Nothing, dict_expr) - - | otherwise -- Non-trivial dictionary arg; make an auxiliary binding - = let 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 - -- See Note [Make the new dictionaries interesting] - , se_interesting = interesting `extendVarSet` fresh_dict_id } - in (env', Just dict_bind, Var fresh_dict_id) - -{- -Note [Make the new dictionaries interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Important! We're going to substitute dx_id1 for d -and we want it to look "interesting", else we won't gather *any* -consequential calls. E.g. - f d = ...g d.... -If we specialise f for a call (f (dfun dNumInt)), we'll get -a consequent call (g d') with an auxiliary definition - d' = df dNumInt -We want that consequent call to look interesting - -Note [Keep the old dictionaries interesting] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In bindAuxiliaryDict, we don’t bother creating a new dict binding if -the dict expression is trivial. For example, if we have - - f = \ @m1 (d1 :: Monad m1) -> ... - -and we specialize it at the pattern - - [SpecType IO, SpecArg $dMonadIO] - -it would be silly to create a new binding for $dMonadIO; it’s already -a binding! So we just extend the substitution directly: - - m1 :-> IO - d1 :-> $dMonadIO - -But this creates a new subtlety: the dict expression might be a dict -binding we floated out while specializing another function. For -example, we might have - - d2 = $p1Monad $dMonadIO -- floated out by bindAuxiliaryDict - $sg = h @IO d2 - h = \ @m2 (d2 :: Applicative m2) -> ... - -and end up specializing h at the following pattern: - - [SpecType IO, SpecArg d2] - -When we created the d2 binding in the first place, we locally marked -it as interesting while specializing g as described above by -Note [Make the new dictionaries interesting]. But when we go to -specialize h, it isn’t in the SpecEnv anymore, so we’ve lost the -knowledge that we should specialize on it. - -To fix this, we have to explicitly add d2 *back* to the interesting -set. That way, it will still be considered interesting while -specializing the body of h. See !2913. --} - - -{- ********************************************************************* -* * - UsageDetails and suchlike -* * -********************************************************************* -} - -data UsageDetails - = MkUD { ud_binds :: !FloatedDictBinds - , ud_calls :: !CallDetails } - -- INVARIANT: suppose bs = fdb_bndrs ud_binds - -- Then 'calls' may *mention* 'bs', - -- but there should be no calls *for* bs - -data FloatedDictBinds -- See Note [Floated dictionary bindings] - = FDB { fdb_binds :: !(Bag DictBind) - -- The order is important; - -- in ds1 `unionBags` ds2, bindings in ds2 can depend on those in ds1 - -- (Remember, Bags preserve order in GHC.) - - , fdb_bndrs :: !IdSet - } -- ^ The binders of 'fdb_binds'. - -- Caches a superset of the expression - -- `mkVarSet (bindersOfDictBinds fdb_binds))` - -- for later addition to an InScopeSet - --- | A 'DictBind' is a binding along with a cached set containing its free --- variables (both type variables and dictionaries) -data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet } - -bindersOfDictBind :: DictBind -> [Id] -bindersOfDictBind = bindersOf . db_bind - -bindersOfDictBinds :: Foldable f => f DictBind -> [Id] -bindersOfDictBinds = bindersOfBinds . foldr ((:) . db_bind) [] - -{- Note [Floated dictionary bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We float out dictionary bindings for the reasons described under -"Dictionary floating" above. But not /just/ dictionary bindings. -Consider - - f :: Eq a => blah - f a d = rhs - - $c== :: T -> T -> Bool - $c== x y = ... - - $df :: Eq T - $df = Eq $c== ... - - gurgle = ...(f @T $df)... - -We gather the call info for (f @T $df), and we don't want to drop it -when we come across the binding for $df. So we add $df to the floats -and continue. But then we have to add $c== to the floats, and so on. -These all float above the binding for 'f', and now we can -successfully specialise 'f'. - -So the DictBinds in (ud_binds :: Bag DictBind) may contain -non-dictionary bindings too. - -It's important to add the dictionary binders that are currently in-float to the -InScopeSet of the SpecEnv before calling 'specBind'. That's what we do when we -call 'bringFloatedDictsIntoScope'. --} - -instance Outputable DictBind where - ppr (DB { db_bind = bind, db_fvs = fvs }) - = text "DB" <+> braces (sep [ text "fvs: " <+> ppr fvs - , text "bind:" <+> ppr bind ]) - -instance Outputable UsageDetails where - ppr (MkUD { ud_binds = dbs, ud_calls = calls }) - = text "MkUD" <+> braces (sep (punctuate comma - [text "binds" <+> equals <+> ppr dbs, - text "calls" <+> equals <+> ppr calls])) - -instance Outputable FloatedDictBinds where - ppr (FDB { fdb_binds = binds }) = ppr binds - -emptyUDs :: UsageDetails -emptyUDs = MkUD { ud_binds = emptyFDBs, ud_calls = emptyDVarEnv } - - -emptyFDBs :: FloatedDictBinds -emptyFDBs = FDB { fdb_binds = emptyBag, fdb_bndrs = emptyVarSet } - ------------------------------------------------------------- -type CallDetails = DIdEnv CallInfoSet - -- The order of specialized binds and rules depends on how we linearize - -- CallDetails, so to get determinism we must use a deterministic set here. - -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM - -data CallInfoSet = CIS Id (Bag CallInfo) - -- 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 - -data CallInfo - = CI { ci_key :: [SpecArg] -- All arguments - , ci_fvs :: IdSet -- Free Ids of the ci_key call - -- _not_ including the main id itself, of course - -- NB: excluding tyvars: - } - -type DictExpr = CoreExpr - -ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet -ciSetFilter p (CIS id a) = CIS id (filterBag p a) - -instance Outputable CallInfoSet where - ppr (CIS fn map) = hang (text "CIS" <+> ppr fn) - 2 (ppr map) - -pprCallInfo :: Id -> CallInfo -> SDoc -pprCallInfo fn (CI { ci_key = key }) - = ppr fn <+> ppr key - -ppr_call_key_ty :: SpecArg -> Maybe SDoc -ppr_call_key_ty (SpecType ty) = Just $ char '@' <> pprParendType ty -ppr_call_key_ty UnspecType = Just $ char '_' -ppr_call_key_ty (SpecDict _) = Nothing -ppr_call_key_ty UnspecArg = Nothing - -instance Outputable CallInfo where - ppr (CI { ci_key = key, ci_fvs = _fvs }) - = text "CI" <> braces (sep (map ppr key)) - -unionCalls :: CallDetails -> CallDetails -> CallDetails -unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2 - -unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet -unionCallInfoSet (CIS f calls1) (CIS _ calls2) = - CIS f (calls1 `unionBags` calls2) - -callDetailsFVs :: CallDetails -> VarSet -callDetailsFVs calls = - nonDetStrictFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls - -- It's OK to use nonDetStrictFoldUDFM here because we forget the ordering - -- immediately by converting to a nondeterministic set. - -callInfoFVs :: CallInfoSet -> VarSet -callInfoFVs (CIS _ call_info) = - foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info - -getTheta :: [TyCoBinder] -> [PredType] -getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder) - - ------------------------------------------------------------- -singleCall :: Id -> [SpecArg] -> UsageDetails -singleCall id args - = MkUD {ud_binds = emptyFDBs, - ud_calls = unitDVarEnv id $ CIS id $ - unitBag (CI { ci_key = args -- used to be tys - , ci_fvs = call_fvs }) } - where - call_fvs = foldr (unionVarSet . specArgFreeVars) emptyVarSet args - -- The type args (tys) are guaranteed to be part of the dictionary - -- types, because they are just the constrained types, - -- and the dictionary is therefore sure to be bound - -- inside the binding for any type variables free in the type; - -- hence it's safe to neglect tyvars free in tys when making - -- the free-var set for this call - -- BUT I don't trust this reasoning; play safe and include tys_fvs - -- - -- We don't include the 'id' itself. - -mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails -mkCallUDs env f args - = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ]) - res - where - res = mkCallUDs' env f args - -mkCallUDs' env f args - | wantCallsFor env f -- We want it, and... - , not (null ci_key) -- this call site has a useful specialisation - = -- pprTrace "mkCallUDs: keeping" _trace_doc - singleCall f ci_key - - | otherwise -- See also Note [Specialisations already covered] - = -- pprTrace "mkCallUDs: discarding" _trace_doc - emptyUDs - - where - _trace_doc = vcat [ppr f, ppr args, ppr ci_key] - pis = fst $ splitPiTys $ idType f - constrained_tyvars = tyCoVarsOfTypes $ getTheta pis - - 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 - - mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg - mk_spec_arg arg (Named bndr) - | binderVar bndr `elemVarSet` constrained_tyvars - = case arg of - Type ty -> SpecType ty - _ -> pprPanic "ci_key" $ ppr arg - | otherwise = UnspecType - - -- For "InvisArg", 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 InvisArg pred) - | not (isIPLikePred (scaledThing pred)) - -- See Note [Type determines value] - , interestingDict env arg - -- See Note [Interesting dictionary arguments] - = SpecDict arg - - | otherwise = UnspecArg - - mk_spec_arg _ (Anon VisArg _) - = UnspecArg - -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 [Type determines value] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Only specialise on non-impicit-parameter predicates, because these -are the ones whose *type* determines their *value*. In particular, -with implicit params, the type args *don't* say what the value of the -implicit param is! See #7101. - -So we treat implicit params just like ordinary arguments for the -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. - -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? - - * A variable might be imported, in which case its unfolding - will tell us whether it has useful structure - - * Local variables are cloned on the way down (to avoid clashes when - we float dictionaries), and cloning drops the unfolding - (cloneIdBndr). Moreover, we make up some new bindings, and it's a - nuisance to give them unfoldings. So we keep track of the - "interesting" dictionaries as a VarSet in SpecEnv. - We have to take care to put any new interesting dictionary - bindings in the set. - -We accidentally lost accurate tracking of local variables for a long -time, because cloned variables don'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. --} - -interestingDict :: SpecEnv -> CoreExpr -> Bool --- A dictionary argument is interesting if it has *some* structure --- NB: "dictionary" arguments include constraints of all sorts, --- including equality constraints; hence the Coercion case -interestingDict env (Var v) = hasSomeUnfolding (idUnfolding v) - || isDataConWorkId v - || v `elemVarSet` se_interesting env -interestingDict _ (Type _) = False -interestingDict _ (Coercion _) = False -interestingDict env (App fn (Type _)) = interestingDict env fn -interestingDict env (App fn (Coercion _)) = interestingDict env fn -interestingDict env (Tick _ a) = interestingDict env a -interestingDict env (Cast e _) = interestingDict env e -interestingDict _ _ = True - -thenUDs :: UsageDetails -> UsageDetails -> UsageDetails -thenUDs (MkUD {ud_binds = db1, ud_calls = calls1}) - (MkUD {ud_binds = db2, ud_calls = calls2}) - = MkUD { ud_binds = db1 `thenFDBs` db2 - , ud_calls = calls1 `unionCalls` calls2 } - -thenFDBs :: FloatedDictBinds -> FloatedDictBinds -> FloatedDictBinds --- Combine FloatedDictBinds --- In (dbs1 `thenFDBs` dbs2), dbs2 may mention dbs1 but not vice versa -thenFDBs (FDB { fdb_binds = dbs1, fdb_bndrs = bs1 }) - (FDB { fdb_binds = dbs2, fdb_bndrs = bs2 }) - = FDB { fdb_binds = dbs1 `unionBags` dbs2 - , fdb_bndrs = bs1 `unionVarSet` bs2 } - ------------------------------ -_dictBindBndrs :: Bag DictBind -> [Id] -_dictBindBndrs dbs = foldr ((++) . bindersOf . db_bind) [] dbs - --- | Construct a 'DictBind' from a 'CoreBind' -mkDB :: CoreBind -> DictBind -mkDB bind = DB { db_bind = bind, db_fvs = bind_fvs bind } - --- | Identify the free variables of a 'CoreBind' -bind_fvs :: CoreBind -> VarSet -bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs) -bind_fvs (Rec prs) = rhs_fvs `delVarSetList` (map fst prs) - where - rhs_fvs = unionVarSets (map pair_fvs prs) - -pair_fvs :: (Id, CoreExpr) -> VarSet -pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs - `unionVarSet` idFreeVars bndr - -- idFreeVars: don't forget variables mentioned in - -- the rules of the bndr. C.f. OccAnal.addRuleUsage - -- Also tyvars mentioned in its type; they may not appear - -- in the RHS - -- type T a = Int - -- x :: T a = 3 - where - interesting :: InterestingVarFun - interesting v = isLocalVar v || (isId v && isDFunId v) - -- Very important: include DFunIds /even/ if it is imported - -- Reason: See Note [Avoiding loops in specImports], the #13429 - -- example involving an imported dfun. We must know - -- whether a dictionary binding depends on an imported - -- DFun in case we try to specialise that imported DFun - --- | Flatten a set of "dumped" 'DictBind's, and some other binding --- pairs, into a single recursive binding. -recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind -> DictBind -recWithDumpedDicts pairs dbs - = DB { db_bind = Rec bindings - , db_fvs = fvs `delVarSetList` map fst bindings } - where - (bindings, fvs) = foldr add ([], emptyVarSet) - (dbs `snocBag` mkDB (Rec pairs)) - add (DB { db_bind = bind, db_fvs = fvs }) (prs_acc, fvs_acc) - = case bind of - NonRec b r -> ((b,r) : prs_acc, fvs') - Rec prs1 -> (prs1 ++ prs_acc, fvs') - where - fvs' = fvs_acc `unionVarSet` fvs - -snocDictBind :: UsageDetails -> DictBind -> UsageDetails -snocDictBind uds@MkUD{ud_binds= FDB { fdb_binds = dbs, fdb_bndrs = bs }} db - = uds { ud_binds = FDB { fdb_binds = dbs `snocBag` db - , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } } - -snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails --- Add ud_binds to the tail end of the bindings in uds -snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs - = uds { ud_binds = FDB { fdb_binds = binds `unionBags` listToBag dbs - , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } } - -consDictBind :: DictBind -> UsageDetails -> UsageDetails -consDictBind db uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs=bs}} - = uds { ud_binds = FDB { fdb_binds = db `consBag` binds - , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } } - -consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails -consDictBinds dbs uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}} - = uds { ud_binds = FDB{ fdb_binds = listToBag dbs `unionBags` binds - , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } } - -wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind] -wrapDictBinds (FDB { fdb_binds = dbs }) binds - = foldr add binds dbs - where - add (DB { db_bind = bind }) binds = bind : binds - -wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr -wrapDictBindsE dbs expr - = foldr add expr dbs - where - add (DB { db_bind = bind }) expr = Let bind expr - ----------------------- -dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind) --- 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, emptyBag) -- Common in case alternatives - | otherwise = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ - (free_uds, dump_dbs) - where - free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls } - bndr_set = mkVarSet bndrs - (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set - free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor - deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be - -- no calls for any of the dicts in dump_dbs - -dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool) --- Used at a let(rec) binding. --- We return a boolean indicating whether the binding itself is mentioned, --- directly or indirectly, by any of the ud_calls; in that case we want to --- float the binding itself; --- See Note [Floated dictionary bindings] -dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) - = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ - (free_uds, dump_dbs, float_all) - where - free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } - bndr_set = mkVarSet bndrs - (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set - free_calls = deleteCallsFor bndrs orig_calls - float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls - -callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo]) -callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls } - = -- pprTrace ("callsForMe") - -- (vcat [ppr fn, - -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), - -- text "Orig calls =" <+> ppr orig_calls, - -- text "Calls for me =" <+> ppr calls_for_me]) $ - (uds_without_me, calls_for_me) - where - uds_without_me = uds { ud_calls = delDVarEnv orig_calls fn } - 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)]) -filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs }) - | isDFunId fn -- Note [Avoiding loops (DFuns)] applies only to DFuns - = filter ok_call unfiltered_calls - | otherwise -- Do not apply it to non-DFuns - = unfiltered_calls -- See Note [Avoiding loops (non-DFuns)] - where - unfiltered_calls = bagToList call_bag - - dump_set = foldl' go (unitVarSet fn) dbs - -- This dump-set could also be computed by splitDictBinds - -- (_,_,dump_set) = splitDictBinds dbs {fn} - -- But this variant is shorter - - go so_far (DB { db_bind = bind, db_fvs = fvs }) - | fvs `intersectsVarSet` so_far - = extendVarSetList so_far (bindersOf bind) - | otherwise = so_far - - ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set - ----------------------- -splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, Bag DictBind, IdSet) --- splitDictBinds dbs bndrs returns --- (free_dbs, dump_dbs, dump_set) --- where --- * dump_dbs depends, transitively on bndrs --- * free_dbs does not depend on bndrs --- * dump_set = bndrs `union` bndrs(dump_dbs) -splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set - = (FDB { fdb_binds = free_dbs - , fdb_bndrs = bs `minusVarSet` dump_set } - , dump_dbs, dump_set) - where - (free_dbs, dump_dbs, dump_set) - = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs - -- Important that it's foldl' not foldr; - -- we're accumulating the set of dumped ids in dump_set - - split_db (free_dbs, dump_dbs, dump_idset) db - | DB { db_bind = bind, db_fvs = fvs } <- db - , dump_idset `intersectsVarSet` fvs -- Dump it - = (free_dbs, dump_dbs `snocBag` db, - extendVarSetList dump_idset (bindersOf bind)) - - | otherwise -- Don't dump it - = (free_dbs `snocBag` db, dump_dbs, dump_idset) - - ----------------------- -deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails --- Remove calls *mentioning* bs in any way -deleteCallsMentioning bs calls - = mapDVarEnv (ciSetFilter keep_call) calls - where - keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bs - -deleteCallsFor :: [Id] -> CallDetails -> CallDetails --- Remove calls *for* bs -deleteCallsFor bs calls = delDVarEnvList calls bs - -{- -************************************************************************ -* * -\subsubsection{Boring helper functions} -* * -************************************************************************ --} - -type SpecM a = UniqSM a - -runSpecM :: SpecM a -> CoreM a -runSpecM thing_inside - = do { us <- getUniqueSupplyM - ; return (initUs_ us thing_inside) } - -mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails) -mapAndCombineSM _ [] = return ([], emptyUDs) -mapAndCombineSM f (x:xs) = do (y, uds1) <- f x - (ys, uds2) <- mapAndCombineSM f xs - return (y:ys, uds1 `thenUDs` uds2) - -extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv -extendTvSubstList env tv_binds - = env { se_subst = Core.extendTvSubstList (se_subst env) tv_binds } - -substTy :: SpecEnv -> Type -> Type -substTy env ty = Core.substTy (se_subst env) ty - -substCo :: SpecEnv -> Coercion -> Coercion -substCo env co = Core.substCo (se_subst env) co - -substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr) -substBndr env bs = case Core.substBndr (se_subst env) bs of - (subst', bs') -> (env { se_subst = subst' }, bs') - -substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr]) -substBndrs env bs = case Core.substBndrs (se_subst env) bs of - (subst', bs') -> (env { se_subst = subst' }, bs') - -cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind) --- Clone the binders of the bind; return new bind with the cloned binders --- Return the substitution to use for RHSs, and the one to use for the body -cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs) - = do { us <- getUniqueSupplyM - ; let (subst', bndr') = Core.cloneIdBndr subst us bndr - interesting' | interestingDict env rhs - = interesting `extendVarSet` bndr' - | otherwise = interesting --- ; pprTrace "cloneBindSM" (ppr bndr <+> text ":->" <+> ppr bndr') return () - ; return (env, env { se_subst = subst', se_interesting = interesting' } - , NonRec bndr' rhs) } - -cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs) - = do { us <- getUniqueSupplyM - ; let (subst', bndrs') = Core.cloneRecIdBndrs subst us (map fst pairs) - env' = env { se_subst = subst' - , se_interesting = interesting `extendVarSetList` - [ v | (v,r) <- pairs, interestingDict env r ] } - ; return (env', env', Rec (bndrs' `zip` map snd pairs)) } - -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' = Core.substTy subst (idType b) - b' = mkUserLocal (nameOccName n) uniq Many 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 -newSpecIdSM old_name new_ty details info - = do { uniq <- getUniqueM - ; let new_occ = mkSpecOcc (nameOccName old_name) - new_name = mkInternalName uniq new_occ (getSrcSpan old_name) - ; return (assert (not (isCoVarType new_ty)) $ - mkLocalVar details new_name Many new_ty info) } +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[Specialise]{Stamping out overloading, and (optionally) polymorphism} +-} + +module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where + +import GHC.Prelude + +import GHC.Driver.Session +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.Predicate +import GHC.Core.Coercion( Coercion ) +import GHC.Core.Opt.Monad +import qualified GHC.Core.Subst as Core +import GHC.Core.Unfold.Make +import GHC.Core +import GHC.Core.Make ( mkLitRubbish ) +import GHC.Core.Unify ( tcMatchTy ) +import GHC.Core.Rules +import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable + , mkCast, exprType + , 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.Bag +import GHC.Data.OrdList +import GHC.Data.List.SetOps + +import GHC.Types.Basic +import GHC.Types.Unique.Supply +import GHC.Types.Unique.DFM +import GHC.Types.Name +import GHC.Types.Tickish +import GHC.Types.Id.Make ( voidArgId, voidPrimId ) +import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg ) +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Id +import GHC.Types.Error + +import GHC.Utils.Error ( mkMCDiagnostic ) +import GHC.Utils.Monad ( foldlM ) +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Unit.Module( Module ) +import GHC.Unit.Module.ModGuts +import GHC.Core.Unfold + +import Data.List( partition ) +import Data.List.NonEmpty ( NonEmpty (..) ) + +{- +************************************************************************ +* * +\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]} +* * +************************************************************************ + +These notes describe how we implement specialisation to eliminate +overloading. + +The specialisation pass works on Core +syntax, complete with all the explicit dictionary application, +abstraction and construction as added by the type checker. The +existing type checker remains largely as it is. + +One important thought: the {\em types} passed to an overloaded +function, and the {\em dictionaries} passed are mutually redundant. +If the same function is applied to the same type(s) then it is sure to +be applied to the same dictionary(s)---or rather to the same {\em +values}. (The arguments might look different but they will evaluate +to the same value.) + +Second important thought: we know that we can make progress by +treating dictionary arguments as static and worth specialising on. So +we can do without binding-time analysis, and instead specialise on +dictionary arguments and no others. + +The basic idea +~~~~~~~~~~~~~~ +Suppose we have + + let f = + in + +and suppose f is overloaded. + +STEP 1: CALL-INSTANCE COLLECTION + +We traverse , accumulating all applications of f to types and +dictionaries. + +(Might there be partial applications, to just some of its types and +dictionaries? In principle yes, but in practice the type checker only +builds applications of f to all its types and dictionaries, so partial +applications could only arise as a result of transformation, and even +then I think it's unlikely. In any case, we simply don't accumulate such +partial applications.) + + +STEP 2: EQUIVALENCES + +So now we have a collection of calls to f: + f t1 t2 d1 d2 + f t3 t4 d3 d4 + ... +Notice that f may take several type arguments. To avoid ambiguity, we +say that f is called at type t1/t2 and t3/t4. + +We take equivalence classes using equality of the *types* (ignoring +the dictionary args, which as mentioned previously are redundant). + +STEP 3: SPECIALISATION + +For each equivalence class, choose a representative (f t1 t2 d1 d2), +and create a local instance of f, defined thus: + + f@t1/t2 = t1 t2 d1 d2 + +f_rhs presumably has some big lambdas and dictionary lambdas, so lots +of simplification will now result. However we don't actually *do* that +simplification. Rather, we leave it for the simplifier to do. If we +*did* do it, though, we'd get more call instances from the specialised +RHS. We can work out what they are by instantiating the call-instance +set from f's RHS with the types t1, t2. + +Add this new id to f's IdInfo, to record that f has a specialised version. + +Before doing any of this, check that f's IdInfo doesn't already +tell us about an existing instance of f at the required type/s. +(This might happen if specialisation was applied more than once, or +it might arise from user SPECIALIZE pragmas.) + +Recursion +~~~~~~~~~ +Wait a minute! What if f is recursive? Then we can't just plug in +its right-hand side, can we? + +But it's ok. The type checker *always* creates non-recursive definitions +for overloaded recursive functions. For example: + + f x = f (x+x) -- Yes I know its silly + +becomes + + f a (d::Num a) = let p = +.sel a d + in + letrec fl (y::a) = fl (p y y) + in + fl + +We still have recursion for non-overloaded functions which we +specialise, but the recursive call should get specialised to the +same recursive version. + + +Polymorphism 1 +~~~~~~~~~~~~~~ + +All this is crystal clear when the function is applied to *constant +types*; that is, types which have no type variables inside. But what if +it is applied to non-constant types? Suppose we find a call of f at type +t1/t2. There are two possibilities: + +(a) The free type variables of t1, t2 are in scope at the definition point +of f. In this case there's no problem, we proceed just as before. A common +example is as follows. Here's the Haskell: + + g y = let f x = x+x + in f y + f y + +After typechecking we have + + g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x + in +.sel a d (f a d y) (f a d y) + +Notice that the call to f is at type type "a"; a non-constant type. +Both calls to f are at the same type, so we can specialise to give: + + g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x + in +.sel a d (f@a y) (f@a y) + + +(b) The other case is when the type variables in the instance types +are *not* in scope at the definition point of f. The example we are +working with above is a good case. There are two instances of (+.sel a d), +but "a" is not in scope at the definition of +.sel. Can we do anything? +Yes, we can "common them up", a sort of limited common sub-expression deal. +This would give: + + g a (d::Num a) (y::a) = let +.sel@a = +.sel a d + f@a (x::a) = +.sel@a x x + in +.sel@a (f@a y) (f@a y) + +This can save work, and can't be spotted by the type checker, because +the two instances of +.sel weren't originally at the same type. + +Further notes on (b) + +* There are quite a few variations here. For example, the defn of + +.sel could be floated outside the \y, to attempt to gain laziness. + It certainly mustn't be floated outside the \d because the d has to + be in scope too. + +* We don't want to inline f_rhs in this case, because +that will duplicate code. Just commoning up the call is the point. + +* Nothing gets added to +.sel's IdInfo. + +* Don't bother unless the equivalence class has more than one item! + +Not clear whether this is all worth it. It is of course OK to +simply discard call-instances when passing a big lambda. + +Polymorphism 2 -- Overloading +~~~~~~~~~~~~~~ +Consider a function whose most general type is + + f :: forall a b. Ord a => [a] -> b -> b + +There is really no point in making a version of g at Int/Int and another +at Int/Bool, because it's only instantiating the type variable "a" which +buys us any efficiency. Since g is completely polymorphic in b there +ain't much point in making separate versions of g for the different +b types. + +That suggests that we should identify which of g's type variables +are constrained (like "a") and which are unconstrained (like "b"). +Then when taking equivalence classes in STEP 2, we ignore the type args +corresponding to unconstrained type variable. In STEP 3 we make +polymorphic versions. Thus: + + f@t1/ = /\b -> t1 b d1 d2 + +We do this. + + +Dictionary floating +~~~~~~~~~~~~~~~~~~~ +Consider this + + f a (d::Num a) = let g = ... + in + ...(let d1::Ord a = Num.Ord.sel a d in g a d1)... + +Here, g is only called at one type, but the dictionary isn't in scope at the +definition point for g. Usually the type checker would build a +definition for d1 which enclosed g, but the transformation system +might have moved d1's defn inward. Solution: float dictionary bindings +outwards along with call instances. + +Consider + + f x = let g p q = p==q + h r s = (r+s, g r s) + in + h x x + + +Before specialisation, leaving out type abstractions we have + + f df x = let g :: Eq a => a -> a -> Bool + g dg p q = == dg p q + h :: Num a => a -> a -> (a, Bool) + h dh r s = let deq = eqFromNum dh + in (+ dh r s, g deq r s) + in + h df x x + +After specialising h we get a specialised version of h, like this: + + h' r s = let deq = eqFromNum df + in (+ df r s, g deq r s) + +But we can't naively make an instance for g from this, because deq is not in scope +at the defn of g. Instead, we have to float out the (new) defn of deq +to widen its scope. Notice that this floating can't be done in advance -- it only +shows up when specialisation is done. + +User SPECIALIZE pragmas +~~~~~~~~~~~~~~~~~~~~~~~ +Specialisation pragmas can be digested by the type checker, and implemented +by adding extra definitions along with that of f, in the same way as before + + f@t1/t2 = t1 t2 d1 d2 + +Indeed the pragmas *have* to be dealt with by the type checker, because +only it knows how to build the dictionaries d1 and d2! For example + + g :: Ord a => [a] -> [a] + {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-} + +Here, the specialised version of g is an application of g's rhs to the +Ord dictionary for (Tree Int), which only the type checker can conjure +up. There might not even *be* one, if (Tree Int) is not an instance of +Ord! (All the other specialisation has suitable dictionaries to hand +from actual calls.) + +Problem. The type checker doesn't have to hand a convenient , because +it is buried in a complex (as-yet-un-desugared) binding group. +Maybe we should say + + f@t1/t2 = f* t1 t2 d1 d2 + +where f* is the Id f with an IdInfo which says "inline me regardless!". +Indeed all the specialisation could be done in this way. +That in turn means that the simplifier has to be prepared to inline absolutely +any in-scope let-bound thing. + + +Again, the pragma should permit polymorphism in unconstrained variables: + + h :: Ord a => [a] -> b -> b + {-# SPECIALIZE h :: [Int] -> b -> b #-} + +We *insist* that all overloaded type variables are specialised to ground types, +(and hence there can be no context inside a SPECIALIZE pragma). +We *permit* unconstrained type variables to be specialised to + - a ground type + - or left as a polymorphic type variable +but nothing in between. So + + {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-} + +is *illegal*. (It can be handled, but it adds complication, and gains the +programmer nothing.) + + +SPECIALISING INSTANCE DECLARATIONS +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + instance Foo a => Foo [a] where + ... + {-# SPECIALIZE instance Foo [Int] #-} + +The original instance decl creates a dictionary-function +definition: + + dfun.Foo.List :: forall a. Foo a -> Foo [a] + +The SPECIALIZE pragma just makes a specialised copy, just as for +ordinary function definitions: + + dfun.Foo.List@Int :: Foo [Int] + dfun.Foo.List@Int = dfun.Foo.List Int dFooInt + +The information about what instance of the dfun exist gets added to +the dfun's IdInfo in the same way as a user-defined function too. + + +Automatic instance decl specialisation? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can instance decls be specialised automatically? It's tricky. +We could collect call-instance information for each dfun, but +then when we specialised their bodies we'd get new call-instances +for ordinary functions; and when we specialised their bodies, we might get +new call-instances of the dfuns, and so on. This all arises because of +the unrestricted mutual recursion between instance decls and value decls. + +Still, there's no actual problem; it just means that we may not do all +the specialisation we could theoretically do. + +Furthermore, instance decls are usually exported and used non-locally, +so we'll want to compile enough to get those specialisations done. + +Lastly, there's no such thing as a local instance decl, so we can +survive solely by spitting out *usage* information, and then reading that +back in as a pragma when next compiling the file. So for now, +we only specialise instance decls in response to pragmas. + + +SPITTING OUT USAGE INFORMATION +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To spit out usage information we need to traverse the code collecting +call-instance information for all imported (non-prelude?) functions +and data types. Then we equivalence-class it and spit it out. + +This is done at the top-level when all the call instances which escape +must be for imported functions and data types. + +*** Not currently done *** + + +Partial specialisation by pragmas +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What about partial specialisation: + + k :: (Ord a, Eq b) => [a] -> b -> b -> [a] + {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-} + +or even + + {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-} + +Seems quite reasonable. Similar things could be done with instance decls: + + instance (Foo a, Foo b) => Foo (a,b) where + ... + {-# SPECIALIZE instance Foo a => Foo (a,Int) #-} + {-# SPECIALIZE instance Foo b => Foo (Int,b) #-} + +Ho hum. Things are complex enough without this. I pass. + + +Requirements for the simplifier +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The simplifier has to be able to take advantage of the specialisation. + +* When the simplifier finds an application of a polymorphic f, it looks in +f's IdInfo in case there is a suitable instance to call instead. This converts + + f t1 t2 d1 d2 ===> f_t1_t2 + +Note that the dictionaries get eaten up too! + +* Dictionary selection operations on constant dictionaries must be + short-circuited: + + +.sel Int d ===> +Int + +The obvious way to do this is in the same way as other specialised +calls: +.sel has inside it some IdInfo which tells that if it's applied +to the type Int then it should eat a dictionary and transform to +Int. + +In short, dictionary selectors need IdInfo inside them for constant +methods. + +* Exactly the same applies if a superclass dictionary is being + extracted: + + Eq.sel Int d ===> dEqInt + +* Something similar applies to dictionary construction too. Suppose +dfun.Eq.List is the function taking a dictionary for (Eq a) to +one for (Eq [a]). Then we want + + dfun.Eq.List Int d ===> dEq.List_Int + +Where does the Eq [Int] dictionary come from? It is built in +response to a SPECIALIZE pragma on the Eq [a] instance decl. + +In short, dfun Ids need IdInfo with a specialisation for each +constant instance of their instance declaration. + +All this uses a single mechanism: the SpecEnv inside an Id + + +What does the specialisation IdInfo look like? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The SpecEnv of an Id maps a list of types (the template) to an expression + + [Type] |-> Expr + +For example, if f has this RuleInfo: + + [Int, a] -> \d:Ord Int. f' a + +it means that we can replace the call + + f Int t ===> (\d. f' t) + +This chucks one dictionary away and proceeds with the +specialised version of f, namely f'. + + +What can't be done this way? +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is no way, post-typechecker, to get a dictionary for (say) +Eq a from a dictionary for Eq [a]. So if we find + + ==.sel [t] d + +we can't transform to + + eqList (==.sel t d') + +where + eqList :: (a->a->Bool) -> [a] -> [a] -> Bool + +Of course, we currently have no way to automatically derive +eqList, nor to connect it to the Eq [a] instance decl, but you +can imagine that it might somehow be possible. Taking advantage +of this is permanently ruled out. + +Still, this is no great hardship, because we intend to eliminate +overloading altogether anyway! + +A note about non-tyvar dictionaries +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Ids have types like + + forall a,b,c. Eq a -> Ord [a] -> tau + +This seems curious at first, because we usually only have dictionary +args whose types are of the form (C a) where a is a type variable. +But this doesn't hold for the functions arising from instance decls, +which sometimes get arguments with types of form (C (T a)) for some +type constructor T. + +Should we specialise wrt this compound-type dictionary? We used to say +"no", saying: + "This is a heuristic judgement, as indeed is the fact that we + specialise wrt only dictionaries. We choose *not* to specialise + wrt compound dictionaries because at the moment the only place + they show up is in instance decls, where they are simply plugged + into a returned dictionary. So nothing is gained by specialising + wrt them." + +But it is simpler and more uniform to specialise wrt these dicts too; +and in future GHC is likely to support full fledged type signatures +like + f :: Eq [(a,b)] => ... + + +Note [Specialisation and overlapping instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is at tricky case (see a comment in MR !8916): + + module A where + class C a where + meth :: a -> String + instance {-# OVERLAPPABLE #-} C (Maybe a) where + meth _ = "Maybe" + + {-# SPECIALISE f :: Maybe a -> Bool -> String #-} + f :: C a => a -> Bool -> String + f a True = f a False + f a _ = meth a + + module B where + import A + + instance C (Maybe Int) where + meth _ = "Int" + + main = putStrLn $ f (Just 42 :: Maybe Int) True + +Running main without optimisations yields "Int", the correct answer. +Activating optimisations yields "Maybe" due to a rewrite rule in module +A generated by the SPECIALISE pragma: + + RULE "USPEC f" forall a (d :: C a). f @a d = $sf + +In B we get the call (f @(Maybe Int) (d :: C (Maybe Int))), and +that rewrites to $sf, but that isn't really right. + +Overlapping instances mean that `C (Maybe Int)` is not a singleton +type: there two distinct dictionaries that have this type. And that +spells trouble for specialistion, which really asssumes singleton +types. + +For now, we just accept this problem, but it may bite us one day. +One solution would be to decline to expose any specialisation rules +to an importing module -- but that seems a bit drastic. + + +************************************************************************ +* * +\subsubsection{The new specialiser} +* * +************************************************************************ + +Our basic game plan is this. For let(rec) bound function + f :: (C a, D c) => (a,b,c,d) -> Bool + +* Find any specialised calls of f, (f ts ds), where + ts are the type arguments t1 .. t4, and + ds are the dictionary arguments d1 .. d2. + +* Add a new definition for f1 (say): + + f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2 + + Note that we abstract over the unconstrained type arguments. + +* Add the mapping + + [t1,b,t3,d] |-> \d1 d2 -> f1 b d + + to the specialisations of f. This will be used by the + simplifier to replace calls + (f t1 t2 t3 t4) da db + by + (\d1 d1 -> f1 t2 t4) da db + + All the stuff about how many dictionaries to discard, and what types + to apply the specialised function to, are handled by the fact that the + SpecEnv contains a template for the result of the specialisation. + +We don't build *partial* specialisations for f. For example: + + f :: Eq a => a -> a -> Bool + {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-} + +Here, little is gained by making a specialised copy of f. +There's a distinct danger that the specialised version would +first build a dictionary for (Eq b, Eq c), and then select the (==) +method from it! Even if it didn't, not a great deal is saved. + +We do, however, generate polymorphic, but not overloaded, specialisations: + + f :: Eq a => [a] -> b -> b -> b + ... SPECIALISE f :: [Int] -> b -> b -> b ... + +Hence, the invariant is this: + + *** no specialised version is overloaded *** + + +************************************************************************ +* * +\subsubsection{The exported function} +* * +************************************************************************ +-} + +-- | Specialise calls to type-class overloaded functions occurring in a program. +specProgram :: ModGuts -> CoreM ModGuts +specProgram guts@(ModGuts { mg_module = this_mod + , mg_rules = local_rules + , mg_binds = binds }) + = do { dflags <- getDynFlags + ; rule_env <- initRuleEnv guts + -- See Note [Fire rules in the specialiser] + + -- We need to start with a Subst that knows all the things + -- that are in scope, so that the substitution engine doesn't + -- accidentally re-use a unique that's already in use + -- Easiest thing is to do it all at once, as if all the top-level + -- decls were mutually recursive + ; let top_env = SE { se_subst = Core.mkEmptySubst $ + mkInScopeSetBndrs binds + -- mkInScopeSetList $ + -- bindersOfBinds binds + , se_module = this_mod + , se_rules = rule_env + , se_dflags = dflags } + + go [] = return ([], emptyUDs) + go (bind:binds) = do (bind', binds', uds') <- specBind TopLevel top_env bind $ \_ -> + go binds + return (bind' ++ binds', uds') + + -- Specialise the bindings of this module + ; (binds', uds) <- runSpecM (go binds) + + ; (spec_rules, spec_binds) <- specImports top_env uds + + ; return (guts { mg_binds = spec_binds ++ binds' + , mg_rules = spec_rules ++ local_rules }) } + +{- +Note [Wrap bindings returned by specImports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'specImports' returns a set of specialized bindings. However, these are lacking +necessary floated dictionary bindings, which are returned by +UsageDetails(ud_binds). These dictionaries need to be brought into scope with +'wrapDictBinds' before the bindings returned by 'specImports' can be used. See, +for instance, the 'specImports' call in 'specProgram'. + + +Note [Disabling cross-module specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since GHC 7.10 we have performed specialisation of INLINABLE bindings living +in modules outside of the current module. This can sometimes uncover user code +which explodes in size when aggressively optimized. The +-fno-cross-module-specialise option was introduced to allow users to being +bitten by such instances to revert to the pre-7.10 behavior. + +See #10491 +-} + + +{- ********************************************************************* +* * + Specialising imported functions +* * +********************************************************************* -} + +{- Note [Specialising imported functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +specImports specialises imported functions, based on calls in this module. + +When -fspecialise-aggressively is on, we specialise any imported +function for which we have an unfolding. The +-fspecialise-aggressively flag is usually off, because we risk lots of +orphan modules from over-vigorous specialisation. (See Note [Orphans] +in GHC.Core.) However it's not a big deal: anything non-recursive with +an unfolding-template will probably have been inlined already. + +When -fspecialise-aggressively is off, we are more selective about +specialisation (see canSpecImport): + +(1) Without -fspecialise-aggressively, do not specialise + DFunUnfoldings. Note [Do not specialise imported DFuns]. + +(2) Without -fspecialise-aggressively, specialise only imported things + that have a /user-supplied/ INLINE or INLINABLE pragma (hence + isAnyInlinePragma rather than isStableSource). + + In particular, we don't want to specialise workers created by + worker/wrapper (for functions with no pragma) because they won't + specialise usefully, and they generate quite a bit of useless code + bloat. + + Specialise even INLINE things; it hasn't inlined yet, so perhaps + it never will. Moreover it may have calls inside it that we want + to specialise + +Wrinkle (W1): If we specialise an imported Id M.foo, we make a /local/ +binding $sfoo. But specImports may further specialise $sfoo. So we end up +with RULES for both M.foo (imported) and $sfoo (local). Rules for local +Ids should be attached to the Ids themselves (see GHC.HsToCore +Note [Attach rules to local ids]); so we must partition the rules and +attach the local rules. That is done in specImports, via addRulesToId. + +Note [Glom the bindings if imported functions are specialised] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have an imported, *recursive*, INLINABLE function + f :: Eq a => a -> a + f = /\a \d x. ...(f a d)... +In the module being compiled we have + g x = f (x::Int) +Now we'll make a specialised function + f_spec :: Int -> Int + f_spec = \x -> ...(f Int dInt)... + {-# RULE f Int _ = f_spec #-} + g = \x. f Int dInt x +Note that f_spec doesn't look recursive +After rewriting with the RULE, we get + f_spec = \x -> ...(f_spec)... +BUT since f_spec was non-recursive before it'll *stay* non-recursive. +The occurrence analyser never turns a NonRec into a Rec. So we must +make sure that f_spec is recursive. Easiest thing is to make all +the specialisations for imported bindings recursive. +-} + +specImports :: SpecEnv + -> UsageDetails + -> CoreM ([CoreRule], [CoreBind]) +specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls }) + | not $ gopt Opt_CrossModuleSpecialise (se_dflags top_env) + -- See Note [Disabling cross-module specialisation] + = return ([], wrapDictBinds dict_binds []) + + | otherwise + = do { let env_w_dict_bndrs = top_env `bringFloatedDictsIntoScope` dict_binds + ; (_env, spec_rules, spec_binds) <- spec_imports env_w_dict_bndrs [] dict_binds calls + + -- Make a Rec: see Note [Glom the bindings if imported functions are specialised] + -- + -- wrapDictBinds: don't forget to wrap the specialized bindings with + -- bindings for the needed dictionaries. + -- See Note [Wrap bindings returned by specImports] + -- + -- addRulesToId: see Wrinkle (W1) in Note [Specialising imported functions] + -- c.f. GHC.HsToCore.addExportFlagsAndRules + ; let (rules_for_locals, rules_for_imps) = partition isLocalRule spec_rules + local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals + final_binds + | null spec_binds = wrapDictBinds dict_binds [] + | otherwise = [Rec $ mapFst (addRulesToId local_rule_base) $ + flattenBinds $ + wrapDictBinds dict_binds $ + spec_binds] + + ; return (rules_for_imps, final_binds) + } + +-- | Specialise a set of calls to imported bindings +spec_imports :: SpecEnv -- Passed in so that all top-level Ids are in scope + ---In-scope set includes the FloatedDictBinds + -> [Id] -- Stack of imported functions being specialised + -- See Note [specImport call stack] + -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls + -- See Note [Avoiding loops in specImports] + -> CallDetails -- Calls for imported things + -> CoreM ( SpecEnv -- Env contains the new rules + , [CoreRule] -- New rules + , [CoreBind] ) -- Specialised bindings +spec_imports env callers dict_binds calls + = do { let import_calls = dVarEnvElts calls +-- ; debugTraceMsg (text "specImports {" <+> +-- vcat [ text "calls:" <+> ppr import_calls +-- , text "dict_binds:" <+> ppr dict_binds ]) + ; (env, rules, spec_binds) <- go env import_calls +-- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls) + + ; return (env, rules, spec_binds) } + where + go :: SpecEnv -> [CallInfoSet] -> CoreM (SpecEnv, [CoreRule], [CoreBind]) + go env [] = return (env, [], []) + go env (cis : other_calls) + = do { -- debugTraceMsg (text "specImport {" <+> ppr cis) + ; (env, rules1, spec_binds1) <- spec_import env callers dict_binds cis + ; -- debugTraceMsg (text "specImport }" <+> ppr cis) + + ; (env, rules2, spec_binds2) <- go env other_calls + ; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) } + +spec_import :: SpecEnv -- Passed in so that all top-level Ids are in scope + ---In-scope set includes the FloatedDictBinds + -> [Id] -- Stack of imported functions being specialised + -- See Note [specImport call stack] + -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls + -- See Note [Avoiding loops in specImports] + -> CallInfoSet -- Imported function and calls for it + -> CoreM ( SpecEnv + , [CoreRule] -- New rules + , [CoreBind] ) -- Specialised bindings +spec_import env callers dict_binds cis@(CIS fn _) + | isIn "specImport" fn callers + = return (env, [], []) -- No warning. This actually happens all the time + -- when specialising a recursive function, because + -- the RHS of the specialised function contains a recursive + -- call to the original function + + | null good_calls + = return (env, [], []) + + | Just rhs <- canSpecImport dflags fn + = do { -- Get rules from the external package state + -- We keep doing this in case we "page-fault in" + -- more rules as we go along + ; eps_rules <- getExternalRuleBase + ; let rule_env = se_rules env `updExternalPackageRules` eps_rules + +-- ; debugTraceMsg (text "specImport1" <+> vcat +-- [ text "function:" <+> ppr fn +-- , text "good calls:" <+> ppr good_calls +-- , text "existing rules:" <+> ppr (getRules rule_env fn) +-- , text "rhs:" <+> ppr rhs +-- , text "dict_binds:" <+> ppr dict_binds ]) + + ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls }) + <- runSpecM $ specCalls True env (getRules rule_env fn) good_calls fn rhs + + ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] + -- After the rules kick in, via fireRewriteRules, we may get recursion, + -- but we rely on a global GlomBinds to sort that out later + -- See Note [Glom the bindings if imported functions are specialised] + -- Meanwhile, though, bring the binders into scope + + new_subst = se_subst env `Core.extendSubstInScopeList` map fst spec_pairs + new_env = env { se_rules = rule_env `addLocalRules` rules1 + , se_subst = new_subst } + `bringFloatedDictsIntoScope` dict_binds1 + + -- Now specialise any cascaded calls +-- ; debugTraceMsg (text "specImport 2" <+> vcat +-- [ text "function:" <+> ppr fn +-- , text "rules1:" <+> ppr rules1 +-- , text "spec_binds1" <+> ppr spec_binds1 +-- , text "dict_binds1" <+> ppr dict_binds1 +-- , text "new_calls" <+> ppr new_calls ]) + + ; (env, rules2, spec_binds2) + <- spec_imports new_env (fn:callers) + (dict_binds `thenFDBs` dict_binds1) + new_calls + + ; let final_binds = wrapDictBinds dict_binds1 $ + spec_binds2 ++ spec_binds1 + + ; return (env, rules2 ++ rules1, final_binds) } + + | otherwise + = do { tryWarnMissingSpecs dflags callers fn good_calls + ; return (env, [], [])} + + where + dflags = se_dflags env + good_calls = filterCalls cis dict_binds + -- SUPER IMPORTANT! Drop calls that (directly or indirectly) refer to fn + -- See Note [Avoiding loops in specImports] + +canSpecImport :: DynFlags -> Id -> Maybe CoreExpr +canSpecImport dflags fn + | isDataConWrapId fn + = Nothing -- Don't specialise data-con wrappers, even if they + -- have dict args; there is no benefit. + + | CoreUnfolding { uf_tmpl = rhs } <- unf + -- CoreUnfolding: see Note [Specialising imported functions] point (1). + , isAnyInlinePragma (idInlinePragma fn) + -- See Note [Specialising imported functions] point (2). + = Just rhs + + | gopt Opt_SpecialiseAggressively dflags + = maybeUnfoldingTemplate unf + -- With -fspecialise-aggressively, specialise anything + -- with an unfolding, stable or not, DFun or not + + | otherwise = Nothing + where + unf = realIdUnfolding fn -- We want to see the unfolding even for loop breakers + +-- | Returns whether or not to show a missed-spec warning. +-- If -Wall-missed-specializations is on, show the warning. +-- Otherwise, if -Wmissed-specializations is on, only show a warning +-- if there is at least one imported function being specialized, +-- and if all imported functions are marked with an inline pragma +-- Use the most specific warning as the reason. +tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () +-- See Note [Warning about missed specialisations] +tryWarnMissingSpecs dflags callers fn calls_for_fn + | isClassOpId fn = return () -- See Note [Missed specialisation for ClassOps] + | wopt Opt_WarnMissedSpecs dflags + && not (null callers) + && allCallersInlined = doWarn $ WarningWithFlag Opt_WarnMissedSpecs + | wopt Opt_WarnAllMissedSpecs dflags = doWarn $ WarningWithFlag Opt_WarnAllMissedSpecs + | otherwise = return () + where + allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers + diag_opts = initDiagOpts dflags + doWarn reason = + msg (mkMCDiagnostic diag_opts reason Nothing) + (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) + 2 (vcat [ text "when specialising" <+> quotes (ppr caller) + | caller <- callers]) + , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) + , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) + +{- Note [Missed specialisation for ClassOps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #19592 I saw a number of missed specialisation warnings +which were the result of things like: + + case isJumpishInstr @X86.Instr $dInstruction_s7f8 eta3_a78C of { ... + +where isJumpishInstr is part of the Instruction class and defined like +this: + + class Instruction instr where + ... + isJumpishInstr :: instr -> Bool + ... + +isJumpishInstr is a ClassOp which will select the right method +from within the dictionary via our built in rules. See also +Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance. + +We don't give these unfoldings, and as a result the specialiser +complains. But usually this doesn't matter. The simplifier will +apply the rule and we end up with + + case isJumpishInstrImplX86 eta3_a78C of { ... + +Since isJumpishInstrImplX86 is defined for a concrete instance (given +by the dictionary) it is usually already well specialised! +Theoretically the implementation of a method could still be overloaded +over a different type class than what it's a method of. But I wasn't able +to make this go wrong, and SPJ thinks this should be fine as well. + +So I decided to remove the warnings for failed specialisations on ClassOps +alltogether as they do more harm than good. +-} + +{- Note [Do not specialise imported DFuns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Ticket #18223 shows that specialising calls of DFuns is can cause a huge +and entirely unnecessary blowup in program size. Consider a call to + f @[[[[[[[[T]]]]]]]] d1 x +where df :: C a => C [a] + d1 :: C [[[[[[[[T]]]]]]]] = dfC[] @[[[[[[[T]]]]]]] d1 + d2 :: C [[[[[[[T]]]]]]] = dfC[] @[[[[[[T]]]]]] d3 + ... +Now we'll specialise f's RHS, which may give rise to calls to 'g', +also overloaded, which we will specialise, and so on. However, if +we specialise the calls to dfC[], we'll generate specialised copies of +all methods of C, at all types; and the same for C's superclasses. + +And many of these specialised functions will never be called. We are +going to call the specialised 'f', and the specialised 'g', but DFuns +group functions into a tuple, many of whose elements may never be used. + +With deeply-nested types this can lead to a simply overwhelming number +of specialisations: see #18223 for a simple example (from the wild). +I measured the number of specialisations for various numbers of calls +of `flip evalStateT ()`, and got this + + Size after one simplification + #calls #SPEC rules Terms Types + 5 56 3100 10600 + 9 108 13660 77206 + +The real tests case has 60+ calls, which blew GHC out of the water. + +Solution: don't specialise DFuns. The downside is that if we end +up with (h (dfun d)), /and/ we don't specialise 'h', then we won't +pass to 'h' a tuple of specialised functions. + +However, the flag -fspecialise-aggressively (experimental, off by default) +allows DFuns to specialise as well. + +Note [Avoiding loops in specImports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must take great care when specialising instance declarations +(DFuns like $fOrdList) lest we accidentally build a recursive +dictionary. See Note [Avoiding loops (DFuns)]. + +The basic strategy of Note [Avoiding loops (DFuns)] is to use filterCalls +to discard loopy specialisations. But to do that we must ensure +that the in-scope dict-binds (passed to filterCalls) contains +all the needed dictionary bindings. In particular, in the recursive +call to spec_imports in spec_import, we must include the dict-binds +from the parent. Lacking this caused #17151, a really nasty bug. + +Here is what happened. +* Class structure: + Source is a superclass of Mut + Index is a superclass of Source + +* We started with these dict binds + dSource = $fSourcePix @Int $fIndexInt + dIndex = sc_sel dSource + dMut = $fMutPix @Int dIndex + and these calls to specialise + $fMutPix @Int dIndex + $fSourcePix @Int $fIndexInt + +* We specialised the call ($fMutPix @Int dIndex) + ==> new call ($fSourcePix @Int dIndex) + (because Source is a superclass of Mut) + +* We specialised ($fSourcePix @Int dIndex) + ==> produces specialised dict $s$fSourcePix, + a record with dIndex as a field + plus RULE forall d. ($fSourcePix @Int d) = $s$fSourcePix + *** This is the bogus step *** + +* Now we decide not to specialise the call + $fSourcePix @Int $fIndexInt + because we alredy have a RULE that matches it + +* Finally the simplifer rewrites + dSource = $fSourcePix @Int $fIndexInt + ==> dSource = $s$fSourcePix + +Disaster. Now we have + +Rewrite dSource's RHS to $s$fSourcePix Disaster + dSource = $s$fSourcePix + dIndex = sc_sel dSource + $s$fSourcePix = MkSource dIndex ... + +Solution: filterCalls should have stopped the bogus step, +by seeing that dIndex transitively uses $fSourcePix. But +it can only do that if it sees all the dict_binds. Wow. + +-------------- +Here's another example (#13429). Suppose we have + class Monoid v => C v a where ... + +We start with a call + f @ [Integer] @ Integer $fC[]Integer + +Specialising call to 'f' gives dict bindings + $dMonoid_1 :: Monoid [Integer] + $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer + + $dC_1 :: C [Integer] (Node [Integer] Integer) + $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 + +...plus a recursive call to + f @ [Integer] @ (Node [Integer] Integer) $dC_1 + +Specialising that call gives + $dMonoid_2 :: Monoid [Integer] + $dMonoid_2 = M.$p1C @ [Integer] $dC_1 + + $dC_2 :: C [Integer] (Node [Integer] Integer) + $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2 + +Now we have two calls to the imported function + M.$fCvNode :: Monoid v => C v a + M.$fCvNode @v @a m = C m some_fun + +But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2) +for specialisation, else we get: + + $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1 + $dMonoid_2 = M.$p1C @ [Integer] $dC_1 + $s$fCvNode = C $dMonoid_2 ... + RULE M.$fCvNode [Integer] _ _ = $s$fCvNode + +Now use the rule to rewrite the call in the RHS of $dC_1 +and we get a loop! + + +Note [specImport call stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When specialising an imports function 'f', we may get new calls +of an imported function 'g', which we want to specialise in turn, +and similarly specialising 'g' might expose a new call to 'h'. + +We track the stack of enclosing functions. So when specialising 'h' we +have a specImport call stack of [g,f]. We do this for two reasons: +* Note [Warning about missed specialisations] +* Note [Avoiding recursive specialisation] + +Note [Warning about missed specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose + * In module Lib, you carefully mark a function 'foo' INLINABLE + * Import Lib(foo) into another module M + * Call 'foo' at some specialised type in M +Then you jolly well expect it to be specialised in M. But what if +'foo' calls another function 'Lib.bar'. Then you'd like 'bar' to be +specialised too. But if 'bar' is not marked INLINABLE it may well +not be specialised. The warning Opt_WarnMissedSpecs warns about this. + +It's more noisy to warning about a missed specialisation opportunity +for /every/ overloaded imported function, but sometimes useful. That +is what Opt_WarnAllMissedSpecs does. + +ToDo: warn about missed opportunities for local functions. + +Note [Avoiding recursive specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise 'f' we may find new overloaded calls to 'g', 'h' in +'f's RHS. So we want to specialise g,h. But we don't want to +specialise f any more! It's possible that f's RHS might have a +recursive yet-more-specialised call, so we'd diverge in that case. +And if the call is to the same type, one specialisation is enough. +Avoiding this recursive specialisation loop is one reason for the +'callers' stack passed to specImports and specImport. + + +************************************************************************ +* * +\subsubsection{@specExpr@: the main function} +* * +************************************************************************ +-} + +data SpecEnv + = SE { se_subst :: Core.Subst + -- We carry a substitution down: + -- a) we must clone any binding that might float outwards, + -- to avoid name clashes + -- b) we carry a type substitution to use when analysing + -- the RHS of specialised bindings (no type-let!) + + , se_module :: Module + , se_rules :: RuleEnv -- From the home package and this module + , se_dflags :: DynFlags + } + +instance Outputable SpecEnv where + ppr (SE { se_subst = subst }) + = text "SE" <+> braces (text "subst =" <+> ppr subst) + +specVar :: SpecEnv -> InId -> SpecM (OutExpr, UsageDetails) +specVar env@(SE { se_subst = Core.Subst in_scope ids _ _ }) v + | not (isLocalId v) = return (Var v, emptyUDs) + | Just e <- lookupVarEnv ids v = specExpr (zapSubst env) e -- Note (1) + | Just v' <- lookupInScope in_scope v = return (Var v', emptyUDs) + | otherwise = pprPanic "specVar" (ppr v $$ ppr in_scope) + -- c.f. GHC.Core.Subst.lookupIdSubst + -- Note (1): we recurse so we do the lookupInScope thing on any Vars in e + -- probably has little effect, but it's the right thing. + -- We need zapSubst because `e` is an OutExpr + +specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) + +---------------- First the easy cases -------------------- +specExpr env (Var v) = specVar env v +specExpr env (Type ty) = return (Type (substTy env ty), emptyUDs) +specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs) +specExpr _ (Lit lit) = return (Lit lit, emptyUDs) +specExpr env (Cast e co) + = do { (e', uds) <- specExpr env e + ; return ((mkCast e' (substCo env co)), uds) } +specExpr env (Tick tickish body) + = do { (body', uds) <- specExpr env body + ; return (Tick (specTickish env tickish) body', uds) } + +---------------- Applications might generate a call instance -------------------- +specExpr env expr@(App {}) + = do { let (fun_in, args_in) = collectArgs expr + ; (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_call = mkCallUDs env fun_out' args_out' + ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) } + +---------------- Lambda/case require dumping of usage details -------------------- +specExpr env e@(Lam {}) + = specLam env' bndrs' body + where + (bndrs, body) = collectBinders e + (env', bndrs') = substBndrs env bndrs + -- More efficient to collect a group of binders together all at once + -- and we don't want to split a lambda group with dumped bindings + +specExpr env (Case scrut case_bndr ty alts) + = do { (scrut', scrut_uds) <- specExpr env scrut + ; (scrut'', case_bndr', alts', alts_uds) + <- specCase env scrut' case_bndr alts +-- ; pprTrace "specExpr:case" (vcat +-- [ text "scrut" <+> ppr scrut, text "scrut'" <+> ppr scrut' +-- , text "case_bndr'" <+> ppr case_bndr' +-- , text "alts_uds" <+> ppr alts_uds +-- ]) + ; return (Case scrut'' case_bndr' (substTy env ty) alts' + , scrut_uds `thenUDs` alts_uds) } + +---------------- Finally, let is the interesting case -------------------- +specExpr env (Let bind body) + = do { (binds', body', uds) <- specBind NotTopLevel env bind $ \body_env -> + -- pprTrace "specExpr:let" (ppr (se_subst body_env) $$ ppr body) $ + specExpr body_env body + -- All done + ; return (foldr Let body' binds', uds) } + +-- See Note [Specialisation modulo dictionary selectors] +-- Note [ClassOp/DFun selection] +-- Note [Fire rules in the specialiser] +fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr]) +fireRewriteRules env (Var f) args + | Just (rule, expr) <- specLookupRule env f args InitialPhase (getRules (se_rules env) f) + , 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 + -- simplOptExpr needed because lookupRule returns + -- (\x y. rhs) arg1 arg2 + , (fun, args) <- collectArgs expr' + = fireRewriteRules env fun (args++rest_args) +fireRewriteRules _ fun args = (fun, args) + +-------------- +specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails) +-- The binders have been substituted, but the body has not +specLam env bndrs body + | null bndrs + = specExpr env body + | otherwise + = do { (body', uds) <- specExpr env body + ; let (free_uds, dumped_dbs) = dumpUDs bndrs uds + ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) } + +-------------- +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 + +-------------- +specCase :: SpecEnv + -> OutExpr -- Scrutinee, already done + -> InId -> [InAlt] + -> SpecM ( OutExpr -- New scrutinee + , OutId + , [OutAlt] + , UsageDetails) +specCase env scrut' case_bndr [Alt con args rhs] + | -- See Note [Floating dictionaries out of cases] + interestingDict scrut' (idType case_bndr) + , not (isDeadBinder case_bndr && null sc_args') + = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args') + + ; let case_bndr_flt' = case_bndr_flt `addDictUnfolding` scrut' + scrut_bind = mkDB (NonRec case_bndr_flt scrut') + + sc_args_flt' = zipWith addDictUnfolding sc_args_flt sc_rhss + sc_rhss = [ Case (Var case_bndr_flt') case_bndr' (idType sc_arg') + [Alt con args' (Var sc_arg')] + | sc_arg' <- sc_args' ] + cb_set = unitVarSet case_bndr_flt' + sc_binds = [ DB { db_bind = NonRec sc_arg_flt sc_rhs, db_fvs = cb_set } + | (sc_arg_flt, sc_rhs) <- sc_args_flt' `zip` sc_rhss ] + + flt_binds = scrut_bind : sc_binds + + -- Extend the substitution for RHS to map the *original* binders + -- to their floated versions. + mb_sc_flts :: [Maybe DictId] + mb_sc_flts = map (lookupVarEnv clone_env) args' + clone_env = zipVarEnv sc_args' sc_args_flt' + + subst_prs = (case_bndr, Var case_bndr_flt) + : [ (arg, Var sc_flt) + | (arg, Just sc_flt) <- args `zip` mb_sc_flts ] + subst' = se_subst env_rhs + `Core.extendSubstInScopeList` (case_bndr_flt' : sc_args_flt') + `Core.extendIdSubstList` subst_prs + env_rhs' = env_rhs { se_subst = subst' } + + ; (rhs', rhs_uds) <- specExpr env_rhs' rhs + ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds + all_uds = flt_binds `consDictBinds` free_uds + alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs') +-- ; 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) + sc_args' = filter is_flt_sc_arg args' + + clone_me bndr = do { uniq <- getUniqueM + ; return (mkUserLocalOrCoVar occ uniq wght ty loc) } + where + name = idName bndr + wght = idMult bndr + ty = idType bndr + occ = nameOccName name + loc = getSrcSpan name + + arg_set = mkVarSet args' + is_flt_sc_arg var = isId var + && not (isDeadBinder var) + && isDictTy var_ty + && tyCoVarsOfType var_ty `disjointVarSet` arg_set + 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) } + where + (env_alt, case_bndr') = substBndr env case_bndr + spec_alt (Alt con args rhs) + = do { (rhs', uds) <- specExpr env_rhs rhs + ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds +-- ; unless (isNilOL dumped_dbs) $ +-- pprTrace "specAlt" (vcat +-- [text "case_bndr', args" <+> (ppr case_bndr' $$ ppr args) +-- ,text "dumped" <+> ppr dumped_dbs ]) return () + ; return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) } + where + (env_rhs, args') = substBndrs env_alt args + +{- Note [Fire rules in the specialiser] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#21851) + + module A where + f :: Num b => b -> (b, b) + f x = (x + 1, snd (f x)) + {-# SPECIALIZE f :: Int -> (Int, Int) #-} + + module B (g') where + import A + + g :: Num a => a -> a + g x = fst (f x) + {-# NOINLINE[99] g #-} + + h :: Int -> Int + h = g + +Note that `f` has the CPR property, and so will worker/wrapper. + +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 +GHC.Core.Opt.Simplify.Iteration. However, it a bit fragile. + +Moreover consider (test T21851_2): + + module A + f :: (Ord a, Show b) => a -> b -> blah + {-# RULE forall b. f @Int @b = wombat #-} + + wombat :: Show b => Int -> b -> blah + wombat = blah + + module B + import A + g :: forall a. Ord a => blah + g @a = ...g...f @a @Char.... + + h = ....g @Int.... + +Now, in module B, GHC will specialise `g @Int`, which will lead to a +call `f @Int @Char`. If we immediately (in the specialiser) rewrite +that to `womabat @Char`, we have a chance to specialise `wombat`. + +Conclusion: it's treat if the Specialiser fires RULEs itself. +It's not hard to achieve: see `fireRewriteRules`. The only tricky bit is +making sure that we have a reasonably up to date EPS rule base. Currently +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. + +Note [Floating dictionaries out of cases] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + g = \d. case d of { MkD sc ... -> ...(f sc)... } +Naively we can't float d2's binding out of the case expression, +because 'sc' is bound by the case, and that in turn means we can't +specialise f, which seems a pity. + +So we invert the case, by floating out a binding +for 'sc_flt' thus: + sc_flt = case d of { MkD sc ... -> sc } +Now we can float the call instance for 'f'. Indeed this is just +what'll happen if 'sc' was originally bound with a let binding, +but case is more efficient, and necessary with equalities. So it's +good to work with both. + +You might think that this won't make any difference, because the +call instance will only get nuked by the \d. BUT if 'g' itself is +specialised, then transitively we should be able to specialise f. + +In general, given + case e of cb { MkD sc ... -> ...(f sc)... } +we transform to + let cb_flt = e + sc_flt = case cb_flt of { MkD sc ... -> sc } + in + case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... } + +The "_flt" things are the floated binds; we use the current substitution +to substitute sc -> sc_flt in the RHS + +************************************************************************ +* * + Dealing with a binding +* * +************************************************************************ +-} + +bringFloatedDictsIntoScope :: SpecEnv -> FloatedDictBinds -> SpecEnv +bringFloatedDictsIntoScope env (FDB { fdb_bndrs = dx_bndrs }) + = -- pprTrace "brought into scope" (ppr dx_bndrs) $ + env {se_subst=subst'} + where + subst' = se_subst env `Core.extendSubstInScopeSet` dx_bndrs + +specBind :: TopLevelFlag + -> SpecEnv -- At top-level only, this env already has the + -- top level binders in scope + -> InBind + -> (SpecEnv -> SpecM (body, UsageDetails)) -- Process the body + -> SpecM ( [OutBind] -- New bindings + , body -- Body + , UsageDetails) -- And info to pass upstream + +-- Returned UsageDetails: +-- No calls for binders of this bind +specBind top_lvl env (NonRec fn rhs) do_body + = do { (rhs', rhs_uds) <- specExpr env rhs + + ; (body_env1, fn1) <- case top_lvl of + TopLevel -> return (env, fn) + NotTopLevel -> cloneBndrSM env fn + + ; let fn2 | isStableUnfolding (idUnfolding fn1) = fn1 + | otherwise = fn1 `setIdUnfolding` mkSimpleUnfolding defaultUnfoldingOpts rhs' + -- Update the unfolding with the perhaps-simpler or more specialised rhs' + -- This is important: see Note [Update unfolding after specialisation] + -- And in any case cloneBndrSM discards non-Stable unfoldings + + fn3 = zapIdDemandInfo 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. + + body_env2 = body_env1 `extendInScope` fn3 + + ; (body', body_uds) <- do_body body_env2 + + ; (fn4, spec_defns, body_uds1) <- specDefn env body_uds fn3 rhs + + ; let (free_uds, dump_dbs, float_all) = dumpBindUDs [fn4] body_uds1 + all_free_uds = free_uds `thenUDs` rhs_uds + + pairs = spec_defns ++ [(fn4, rhs')] + -- fn4 mentions the spec_defns in its rules, + -- so put the latter first + + final_binds :: [DictBind] + -- See Note [From non-recursive to recursive] + final_binds | not (isNilOL dump_dbs) + , not (null spec_defns) + = [recWithDumpedDicts pairs dump_dbs] + | otherwise + = [mkDB $ NonRec b r | (b,r) <- pairs] + ++ fromOL dump_dbs + + can_float_this_one = exprIsTopLevelBindable rhs (idType fn) + -- exprIsTopLevelBindable: see Note [Care with unlifted bindings] + + ; if float_all && can_float_this_one then + -- Rather than discard the calls mentioning the bound variables + -- we float this (dictionary) binding along with the others + return ([], body', all_free_uds `snocDictBinds` final_binds) + else + -- No call in final_uds mentions bound variables, + -- so we can just leave the binding here + return (map db_bind final_binds, body', all_free_uds) } + + +specBind top_lvl env (Rec pairs) do_body + -- Note [Specialising a recursive group] + = do { let (bndrs,rhss) = unzip pairs + + ; (rec_env, bndrs1) <- case top_lvl of + TopLevel -> return (env, bndrs) + NotTopLevel -> cloneRecBndrsSM env bndrs + + ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rec_env) rhss + ; (body', body_uds) <- do_body rec_env + + ; let scope_uds = body_uds `thenUDs` rhs_uds + -- Includes binds and calls arising from rhss + + ; (bndrs2, spec_defns2, uds2) <- specDefns rec_env scope_uds (bndrs1 `zip` rhss) + -- bndrs2 is like bndrs1, but with RULES added + + ; (bndrs3, spec_defns3, uds3) + <- if null spec_defns2 -- Common case: no specialisation + then return (bndrs2, [], uds2) + else do { -- Specialisation occurred; do it again + (bndrs3, spec_defns3, uds3) + <- specDefns rec_env uds2 (bndrs2 `zip` rhss) + ; return (bndrs3, spec_defns3 ++ spec_defns2, uds3) } + + ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs1 uds3 + final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss') + dumped_dbs + + ; if float_all then + return ([], body', final_uds `snocDictBind` final_bind) + else + return ([db_bind final_bind], body', final_uds) } + + +--------------------------- +specDefns :: SpecEnv + -> UsageDetails -- Info on how it is used in its scope + -> [(OutId,InExpr)] -- The things being bound and their un-processed RHS + -> SpecM ([OutId], -- Original Ids with RULES added + [(OutId,OutExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions + +-- Specialise a list of bindings (the contents of a Rec), but flowing usages +-- upwards binding by binding. Example: { f = ...g ...; g = ...f .... } +-- Then if the input CallDetails has a specialised call for 'g', whose specialisation +-- in turn generates a specialised call for 'f', we catch that in this one sweep. +-- But not vice versa (it's a fixpoint problem). + +specDefns _env uds [] + = return ([], [], uds) +specDefns env uds ((bndr,rhs):pairs) + = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs + ; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs + ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) } + +--------------------------- +specDefn :: SpecEnv + -> UsageDetails -- Info on how it is used in its scope + -> OutId -> InExpr -- The thing being bound and its un-processed RHS + -> SpecM (Id, -- Original Id with added RULES + [(Id,CoreExpr)], -- Extra, specialised bindings + UsageDetails) -- Stuff to fling upwards from the specialised versions + +specDefn env body_uds fn rhs + = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds + rules_for_me = idCoreRules fn + -- Bring into scope the binders from the floated dicts + env_w_dict_bndrs = bringFloatedDictsIntoScope env (ud_binds body_uds) + + ; (rules, spec_defns, spec_uds) <- specCalls False env_w_dict_bndrs + rules_for_me calls_for_me fn rhs + + ; return ( fn `addIdSpecialisations` rules + , spec_defns + , body_uds_without_me `thenUDs` spec_uds) } + -- It's important that the `thenUDs` is this way + -- round, because body_uds_without_me may bind + -- dictionaries that are used in calls_for_me passed + -- to specDefn. So the dictionary bindings in + -- spec_uds may mention dictionaries bound in + -- body_uds_without_me + +--------------------------- +specCalls :: Bool -- True => specialising imported fn + -- False => specialising local fn + -> SpecEnv + -> [CoreRule] -- Existing RULES for the fn + -> [CallInfo] + -> OutId -> InExpr + -> SpecM SpecInfo -- New rules, specialised bindings, and usage details + +-- This function checks existing rules, and does not create +-- duplicate ones. So the caller does not need to do this filtering. +-- See 'already_covered' + +type SpecInfo = ( [CoreRule] -- Specialisation rules + , [(Id,CoreExpr)] -- Specialised definition + , UsageDetails ) -- Usage details from specialised RHSs + +specCalls spec_imp env existing_rules calls_for_me fn rhs + -- The first case is the interesting one + | notNull calls_for_me -- And there are some calls to specialise + && not (isNeverActive (idInlineActivation fn)) + -- Don't specialise NOINLINE things + -- See Note [Auto-specialisation and RULES] + -- + -- Don't specialise OPAQUE things, see Note [OPAQUE pragma]. + -- Since OPAQUE things are always never-active (see + -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for + -- OPAQUE things. + +-- && not (certainlyWillInline (idUnfolding fn)) -- And it's not small +-- See Note [Inline specialisations] for why we do not +-- 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) ]) $ + 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)) + "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) + where + trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ] + + fn_type = idType fn + fn_arity = idArity fn + fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here + inl_prag = idInlinePragma fn + inl_act = inlinePragmaActivation inl_prag + is_local = isLocalId fn + is_dfun = isDFunId fn + dflags = se_dflags env + this_mod = se_module env + -- 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. + + ---------------------------------------------------------- + -- Specialise to one particular call pattern + spec_call :: SpecInfo -- Accumulating parameter + -> CallInfo -- Call instance + -> SpecM SpecInfo + spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) _ci@(CI { ci_key = call_args }) + = -- See Note [Specialising Calls] + do { let all_call_args | is_dfun = saturating_call_args -- See Note [Specialising DFuns] + | 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 + + ; ( useful, rhs_env2, leftover_bndrs + , rule_bndrs, rule_lhs_args + , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args + +-- ; 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 () + + ; if not useful -- No useful specialisation + || already_covered rhs_env2 rules_acc rule_lhs_args + 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 + + -- 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_join_arity | Just orig_join_arity <- isJoinId_maybe fn + = Just (orig_join_arity - join_arity_decr) + | otherwise + = Nothing + + ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity + ; let + -- The rule to put in the function's specialisation is: + -- forall x @b d1' d2'. + -- f x @T1 @b @T2 d1' d2' = f1 x @b + -- See Note [Specialising Calls] + herald | spec_imp = -- Specialising imported fn + text "SPEC/" <> ppr this_mod + | otherwise = -- Specialising local fn + text "SPEC" + + spec_rule = mkSpecRule dflags this_mod True inl_act + herald fn rule_bndrs rule_lhs_args + (mkVarApps (Var spec_fn) spec_bndrs) + + simpl_opts = initSimpleOpts dflags + + -------------------------------------- + -- Add a suitable unfolding; see Note [Inline specialisations] + -- The wrap_unf_body applies the original unfolding to the specialised + -- arguments, not forgetting to wrap the dx_binds around the outside (#22358) + wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds + spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body + rule_lhs_args fn_unf + + spec_inl_prag + | not is_local -- See Note [Specialising imported functions] + , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal + = neverInlinePragma + | otherwise + = inl_prag + + -------------------------------------- + -- 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_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr) + `setInlinePragma` spec_inl_prag + `setIdUnfolding` spec_unf + `asJoinId_maybe` spec_join_arity + + _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type + , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty + , ppr rhs_bndrs, ppr call_args + , ppr spec_rule + ] + + ; -- 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 + ) } } + +-- 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 + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) +specLookupRule env fn args phase rules + = lookupRule ropts in_scope_env is_active fn args rules + where + dflags = se_dflags env + in_scope = getSubstInScope (se_subst env) + in_scope_env = ISE in_scope (whenActiveUnfoldingFun is_active) + ropts = initRuleOpts dflags + is_active = isActive phase + +{- Note [Specialising DFuns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +DFuns have a special sort of unfolding (DFunUnfolding), and these are +hard to specialise a DFunUnfolding to give another DFunUnfolding +unless the DFun is fully applied (#18120). So, in the case of DFunIds +we simply extend the CallKey with trailing UnspecTypes/UnspecArgs, +so that we'll generate a rule that completely saturates the DFun. + +There is an ASSERT that checks this, in the DFunUnfolding case of +GHC.Core.Unfold.Make.specUnfolding. + +Note [Specialisation Must Preserve Sharing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a function: + + f :: forall a. Eq a => a -> blah + f = + if expensive + then f1 + else f2 + +As written, all calls to 'f' will share 'expensive'. But if we specialise 'f' +at 'Int', eg: + + $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2) + + RULE "SPEC f" + forall (d :: Eq Int). + f Int _ = $sfIntf + +We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes! + +To avoid this, we only generate specialisations for functions whose arity is +enough to bind all of the arguments we need to specialise. This ensures our +specialised functions don't do any work before receiving all of their dicts, +and thus avoids the 'f' case above. + +Note [Specialisations Must Be Lifted] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a function 'f': + + f = forall a. Eq a => Array# a + +used like + + case x of + True -> ...f @Int dEqInt... + False -> 0 + +Naively, we might generate an (expensive) specialisation + + $sfInt :: Array# Int + +even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to +the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to +preserve laziness. + +Note [Care with unlifted bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#22998) + f x = let x::ByteArray# = + n::Natural = NB x + in wombat @192827 (n |> co) +where + co :: Natural ~ KnownNat 192827 + wombat :: forall (n:Nat). KnownNat n => blah + +Left to itself, the specialiser would float the bindings for `x` and `n` to top +level, so we can specialise `wombat`. But we can't have a top-level ByteArray# +(see Note [Core letrec invariant] in GHC.Core). Boo. + +This is pretty exotic, so we take a simple way out: in specBind (the NonRec +case) do not float the binding itself unless it satisfies exprIsTopLevelBindable. +This is conservative: maybe the RHS of `x` has a free var that would stop it +floating to top level anyway; but that is hard to spot (since we don't know what +the non-top-level in-scope binders are) and rare (since the binding must satisfy +Note [Core let-can-float invariant] in GHC.Core). + + +Note [Specialising Calls] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a function with a complicated type: + + f :: forall a b c. Int -> Eq a => Show b => c -> Blah + f @a @b @c i dEqA dShowA x = blah + +and suppose it is called at: + + f 7 @T1 @T2 @T3 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 ] + +Why are 'a' and 'b' identified as 'SpecType', while 'c' is 'UnspecType'? +Because we must specialise the function on type variables that appear +free in its *dictionary* arguments; but not on type variables that do not +appear in any dictionaries, i.e. are fully polymorphic. + +Because this call has dictionaries applied, we'd like to specialise +the call on any type argument that appears free in those dictionaries. +In this case, those are [a :-> T1, b :-> T2]. + +We also need to substitute the dictionary binders with their +specialised dictionaries. The simplest substitution would be +[dEqA :-> dEqT1, dShowA :-> $dfShow dShowT2], but this duplicates +work, since `$dfShow dShowT2` is a function application. Therefore, we +also want to *float the dictionary out* (via bindAuxiliaryDict), +creating a new dict binding + + dShow1 = $dfShow dShowT2 + +and the substitution [dEqA :-> dEqT1, dShowA :-> dShow1]. + +With the substitutions in hand, we can generate a specialised function: + + $sf :: forall c. Int -> c -> Blah + $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah) + +Note that the substitution is applied to the whole thing. This is +convenient, but just slightly fragile. Notably: + * There had better be no name clashes in a/b/c + +We must construct a rewrite rule: + + RULE "SPEC f @T1 @T2 _" + forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2). + f @T1 @T2 @c i d1 d2 = $sf @c i + +In the rule, d1 and d2 are just wildcards, not used in the RHS. Note +additionally that 'x' isn't captured by this rule --- we bind only +enough etas in order to capture all of the *specialised* arguments. + +Note [Drop dead args from specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When specialising a function, it’s possible some of the arguments may +actually be dead. For example, consider: + + f :: forall a. () -> Show a => a -> String + f x y = show y ++ "!" + +We might generate the following CallInfo for `f @Int`: + + [SpecType Int, UnspecArg, SpecDict $dShowInt, UnspecArg] + +Normally we’d include both the x and y arguments in the +specialisation, since we’re not specialising on either of them. But +that’s silly, since x is actually unused! So we might as well drop it +in the specialisation: + + $sf :: Int -> String + $sf y = show y ++ "!" + + {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-} + +This doesn’t save us much, since the arg would be removed later by +worker/wrapper, anyway, but it’s easy to do. + +Wrinkles + +* Note that we only drop dead arguments if: + 1. We don’t specialise on them. + 2. They come before an argument we do specialise on. + Doing the latter would require eta-expanding the RULE, which could + make it match less often, so it’s not worth it. Doing the former could + be more useful --- it would stop us from generating pointless + specialisations --- but it’s more involved to implement and unclear if + it actually provides much benefit in practice. + +* If the function has a stable unfolding, specHeader has to come up with + arguments to pass to that stable unfolding, when building the stable + unfolding of the specialised function: this is the last field in specHeader's + big result tuple. + + The right thing to do is to produce a LitRubbish; it should rapidly + disappear. Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let. + +Note [Specialisation modulo dictionary selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #19644, we discovered that the ClassOp/DFun rules from +Note [ClassOp/DFun selection] inhibit transitive specialisation. +Example, inspired by T17966: + + class C a where + m :: Show b => a -> b -> String + dummy :: a -> () -- Force a datatype dictionary representation + + instance C Int where + m a b = show a ++ show b + dummy _ = () + + f :: (C a, Show b) => a -> b -> String + f a b = m a b ++ "!" + {-# INLINABLE[0] f #-} + + main = putStrLn (f (42::Int) (True::Bool)) + +Here, we specialise `f` at `Int` and `Bool`, giving + + $dC = $fCInt + $dShow = GHC.Show.$fShowBool + $sf (a::Int) (b::Bool) = + ... (m @Int $dC @Bool $dShow a b) ... + +Here `m` is just a DictSel, so there is (apparently) nothing to specialise! +However, the next Simplifier run will expose the rewritten instance method: + + ... $fCInt_$cm @Bool $fShowBool a b ... + +where $fCInt_$cm is the instance method for `m` in `instance C Int`: + + $fCInt_$cm :: forall b. Show b => Int -> b -> String + $fCInt_$cm b d x y = show @Int $dShowInt x ++ show @b d y + +We want to specialise this! How? By doing the method-selection rewrite in +the Specialiser. Hence + +1. In the App case of 'specExpr', try to apply the ClassOp/DFun rule on the + head of the application, repeatedly, via 'fireRewriteRules'. +2. Attach an unfolding to freshly-bound dictionary ids such as `$dC` and + `$dShow` in `bindAuxiliaryDict`, so that we can exploit the unfolding + in 'fireRewriteRules' to do the ClassOp/DFun rewrite. + +NB: Without (2), (1) would be pointless, because 'lookupRule' wouldn't be able +to look into the RHS of `$dC` to see the DFun. + +Note [Zap occ info in rule binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we generate a specialisation RULE, we need to drop occurrence +info on the binders. If we don’t, things go wrong when we specialise a +function like + + f :: forall a. () -> Show a => a -> String + f x y = show y ++ "!" + +since we’ll generate a RULE like + + RULE "SPEC f @Int" forall x [Occ=Dead]. + f @Int x $dShow = $sf + +and Core Lint complains, even though x only appears on the LHS (due to +Note [Drop dead args from specialisations]). + +Why is that a Lint error? Because the arguments on the LHS of a rule +are syntactically expressions, not patterns, so Lint treats the +appearance of x as a use rather than a binding. Fortunately, the +solution is simple: we just make sure to zap the occ info before +using ids as wildcard binders in a rule. + +Note [Account for casts in binding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: Eq a => a -> IO () + {-# INLINABLE f + StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g + #-} + f = ... + +In f's stable unfolding we have done some modest simplification which +has pushed the cast to the outside. (I wonder if this is the Right +Thing, but it's what happens now; see GHC.Core.Opt.Simplify.Utils Note [Casts and +lambdas].) Now that stable unfolding must be specialised, so we want +to push the cast back inside. It would be terrible if the cast +defeated specialisation! Hence the use of collectBindersPushingCo. + +Note [Evidence foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose (#12212) that we are specialising + 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). + f Int Int d g = f_spec +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 + * exprsFreeIdsList returns the Ids bound by the args, + which won't include g + +You might wonder if this will match as often, but the simplifier replaces +complicated Refl coercions with Refl pretty aggressively. + +Note [Orphans and auto-generated rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise an INLINABLE function, or when we have +-fspecialise-aggressively, we auto-generate RULES that are orphans. +We don't want to warn about these, or we'd generate a lot of warnings. +Thus, we only warn about user-specified orphan rules. + +Indeed, we don't even treat the module as an orphan module if it has +auto-generated *rule* orphans. Orphan modules are read every time we +compile, so they are pretty obtrusive and slow down every compilation, +even non-optimised ones. (Reason: for type class instances it's a +type correctness issue.) But specialisation rules are strictly for +*optimisation* only so it's fine not to read the interface. + +What this means is that a SPEC rules from auto-specialisation in +module M will be used in other modules only if M.hi has been read for +some other reason, which is actually pretty likely. + +Note [From non-recursive to recursive] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Even in the non-recursive case, if any dict-binds depend on 'fn' we might +have built a recursive knot + + f a d x = + MkUD { ud_binds = NonRec d7 (MkD ..f..) + , ud_calls = ...(f T d7)... } + +The we generate + + Rec { fs x = [T/a, d7/d] + f a d x = + RULE f T _ = fs + d7 = ...f... } + +Here the recursion is only through the RULE. + +However we definitely should /not/ make the Rec in this wildly common +case: + d = ... + MkUD { ud_binds = NonRec d7 (...d...) + , ud_calls = ...(f T d7)... } + +Here we want simply to add d to the floats, giving + MkUD { ud_binds = NonRec d (...) + NonRec d7 (...d...) + , ud_calls = ...(f T d7)... } + +In general, we need only make this Rec if + - there are some specialisations (spec_binds non-empty) + - there are some dict_binds that depend on f (dump_dbs non-empty) + +Note [Avoiding loops (DFuns)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When specialising /dictionary functions/ we must be very careful to +avoid building loops. Here is an example that bit us badly, on +several distinct occasions. + +Here is one: #3591 + class Eq a => C a + instance Eq [a] => C [a] + +This translates to + dfun :: Eq [a] -> C [a] + dfun a d = MkD a d (meth d) + + d4 :: Eq [T] = + d2 :: C [T] = dfun T d4 + d1 :: Eq [T] = $p1 d2 + d3 :: C [T] = dfun T d1 + +None of these definitions is recursive. What happened was that we +generated a specialisation: + RULE forall d. dfun T d = dT :: C [T] + dT = (MkD a d (meth d)) [T/a, d1/d] + = MkD T d1 (meth d1) + +But now we use the RULE on the RHS of d2, to get + d2 = dT = MkD d1 (meth d1) + d1 = $p1 d2 + +and now d1 is bottom! The problem is that when specialising 'dfun' we +should first dump "below" the binding all floated dictionary bindings +that mention 'dfun' itself. So d2 and d3 (and hence d1) must be +placed below 'dfun', and thus unavailable to it when specialising +'dfun'. That in turn means that the call (dfun T d1) must be +discarded. On the other hand, the call (dfun T d4) is fine, assuming +d4 doesn't mention dfun. + +Solution: + Discard all calls that mention dictionaries that depend + (directly or indirectly) on the dfun we are specialising. + This is done by 'filterCalls' + +Note [Avoiding loops (non-DFuns)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The whole Note [Avoiding loops (DFuns)] things applies only to DFuns. +It's important /not/ to apply filterCalls to non-DFuns. For example: + + class C a where { foo,bar :: [a] -> [a] } + + instance C Int where + foo x = r_bar x + bar xs = reverse xs + + r_bar :: C a => [a] -> [a] + r_bar xs = bar (xs ++ xs) + +That translates to: + + r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) + + Rec { $fCInt :: C Int = MkC foo_help reverse + foo_help (xs::[Int]) = r_bar Int $fCInt xs } + +The call (r_bar $fCInt) mentions $fCInt, + which mentions foo_help, + which mentions r_bar + +But we DO want to specialise r_bar at Int: + Rec { $fCInt :: C Int = MkC foo_help reverse + foo_help (xs::[Int]) = r_bar Int $fCInt xs + + r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs) + RULE r_bar Int _ = r_bar_Int + + r_bar_Int xs = bar Int $fCInt (xs ++ xs) + } + +Note that, because of its RULE, r_bar joins the recursive +group. (In this case it'll unravel a short moment later.) +See test simplCore/should_compile/T19599a. + +Another example is #19599, which looked like this: + + class (Show a, Enum a) => MyShow a where + myShow :: a -> String + + myShow_impl :: MyShow a => a -> String + + foo :: Int -> String + foo = myShow_impl @Int $fMyShowInt + + Rec { $fMyShowInt = MkMyShowD $fEnumInt $fShowInt $cmyShow + ; $cmyShow = myShow_impl @Int $fMyShowInt } + +Here, we really do want to specialise `myShow_impl @Int $fMyShowInt`. + + +Note [Specialising a recursive group] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let rec { f x = ...g x'... + ; g y = ...f y'.... } + in f 'a' +Here we specialise 'f' at Char; but that is very likely to lead to +a specialisation of 'g' at Char. We must do the latter, else the +whole point of specialisation is lost. + +But we do not want to keep iterating to a fixpoint, because in the +presence of polymorphic recursion we might generate an infinite number +of specialisations. + +So we use the following heuristic: + * Arrange the rec block in dependency order, so far as possible + (the occurrence analyser already does this) + + * Specialise it much like a sequence of lets + + * Then go through the block a second time, feeding call-info from + the RHSs back in the bottom, as it were + +In effect, the ordering maxmimises the effectiveness of each sweep, +and we do just two sweeps. This should catch almost every case of +monomorphic recursion -- the exception could be a very knotted-up +recursion with multiple cycles tied up together. + +This plan is implemented in the Rec case of specBindItself. + +Note [Specialisations already covered] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We obviously don't want to generate two specialisations for the same +argument pattern. There are two 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 + +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 + +Note [Auto-specialisation and RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + g :: Num a => a -> a + g = ... + + f :: (Int -> Int) -> Int + f w = ... + {-# RULE f g = 0 #-} + +Suppose that auto-specialisation makes a specialised version of +g::Int->Int. That version won't appear in the LHS of the RULE for f. +So if the specialisation rule fires too early, the rule for f may +never fire. + +It might be possible to add new rules, to "complete" the rewrite system. +Thus when adding + RULE forall d. g Int d = g_spec +also add + RULE f g_spec = 0 + +But that's a bit complicated. For now we ask the programmer's help, +by *copying the INLINE activation pragma* to the auto-specialised +rule. So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule +will also not be active until phase 2. And that's what programmers +should jolly well do anyway, even aside from specialisation, to ensure +that g doesn't inline too early. + +This in turn means that the RULE would never fire for a NOINLINE +thing so not much point in generating a specialisation at all. + +Note [Specialisation shape] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only specialise a function if it has visible top-level lambdas +corresponding to its overloading. E.g. if + f :: forall a. Eq a => .... +then its body must look like + f = /\a. \d. ... + +Reason: when specialising the body for a call (f ty dexp), we want to +substitute dexp for d, and pick up specialised calls in the body of f. + +We do allow casts, however; see Note [Account for casts in binding]. + +This doesn't always work. One example I came across was this: + newtype Gen a = MkGen{ unGen :: Int -> a } + + choose :: Eq a => a -> Gen a + choose n = MkGen (\r -> n) + + oneof = choose (1::Int) + +It's a silly example, but we get + choose = /\a. g `cast` co +where choose doesn't have any dict arguments. Thus far I have not +tried to fix this (wait till there's a real example). + +Mind you, then 'choose' will be inlined (since RHS is trivial) so +it doesn't matter. This comes up with single-method classes + + class C a where { op :: a -> a } + instance C a => C [a] where .... +==> + $fCList :: C a => C [a] + $fCList = $copList |> (...coercion>...) + ....(uses of $fCList at particular types)... + +So we suppress the WARN if the rhs is trivial. + +Note [Inline specialisations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is what we do with the InlinePragma of the original function + + * Activation/RuleMatchInfo: both inherited from the original function + + * InlineSpec: inherit from original function + + * Unfolding: transfer a StableUnfolding iff it is UnfWhen + See GHC.Core.Unfold.Make.specUnfolding + and its Note [Specialising unfoldings] + +InlineSpec: you might wonder why we specialise INLINE functions at all. +After all they should be inlined, right? Two reasons: + + * Even INLINE functions are sometimes not inlined, when they aren't + applied to interesting arguments. But perhaps the type arguments + alone are enough to specialise (even though the args are too boring + to trigger inlining), and it's certainly better to call the + specialised version. + + * The RHS of an INLINE function might call another overloaded function, + and we'd like to generate a specialised version of that function too. + This actually happens a lot. Consider + replicateM_ :: (Monad m) => Int -> m a -> m () + {-# INLINABLE replicateM_ #-} + replicateM_ d x ma = ... + The strictness analyser may transform to + replicateM_ :: (Monad m) => Int -> m a -> m () + {-# INLINE replicateM_ #-} + replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma + + $wreplicateM_ :: (Monad m) => Int# -> m a -> m () + {-# INLINABLE $wreplicateM_ #-} + $wreplicateM_ = ... + Now an importing module has a specialised call to replicateM_, say + (replicateM_ dMonadIO). We certainly want to specialise $wreplicateM_! + This particular example had a huge effect on the call to replicateM_ + in nofib/shootout/n-body. +-} + +{- ********************************************************************* +* * + SpecArg, and specHeader +* * +********************************************************************* -} + +-- | An argument that we might want to specialise. +-- See Note [Specialising Calls] for the nitty gritty details. +data SpecArg + = + -- | Type arguments that should be specialised, due to appearing + -- free in the type of a 'SpecDict'. + SpecType Type + + -- | Type arguments that should remain polymorphic. + | UnspecType + + -- | Dictionaries that should be specialised. mkCallUDs ensures + -- that only "interesting" dictionary arguments get a SpecDict; + -- see Note [Interesting dictionary arguments] + | SpecDict DictExpr + + -- | Value arguments that should not be specialised. + | 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 + +isSpecDict :: SpecArg -> Bool +isSpecDict (SpecDict {}) = True +isSpecDict _ = False + +-- | Given binders from an original function 'f', and the 'SpecArg's +-- corresponding to its usage, compute everything necessary to build +-- a specialisation. +-- +-- We will use the running example from Note [Specialising Calls]: +-- +-- f :: forall a b c. Int -> Eq a => Show b => c -> Blah +-- f @a @b @c i dEqA dShowB x = blah +-- +-- Suppose we decide to specialise it at the following pattern: +-- +-- [ SpecType T1, SpecType T2, UnspecType, UnspecArg +-- , SpecDict dEqT1, SpecDict ($dfShow dShowT2), UnspecArg ] +-- +-- We'd eventually like to build the RULE +-- +-- RULE "SPEC f @T1 @T2 _" +-- forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2). +-- f @T1 @T2 @c i d1 d2 = $sf @c i +-- +-- and the specialisation '$sf' +-- +-- $sf :: forall c. Int -> c -> Blah +-- $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowB :-> dShow1] (\@c i x -> blah) +-- +-- where dShow1 is a floated binding created by bindAuxiliaryDict. +-- +-- The cases for 'specHeader' below are presented in the same order as this +-- running example. The result of 'specHeader' for this example is as follows: +-- +-- ( -- Returned arguments +-- env + [a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowB :-> dShow1] +-- , [x] +-- +-- -- RULE helpers +-- , [c, i, d1, d2] +-- , [T1, T2, c, i, d1, d2] +-- +-- -- Specialised function helpers +-- , [c, i, x] +-- , [dShow1 = $dfShow dShowT2] +-- , [T1, T2, c, i, dEqT1, dShow1] +-- ) +specHeader + :: SpecEnv + -> [InBndr] -- The 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 + + -- RULE helpers + , [OutBndr] -- Binders for the RULE + , [OutExpr] -- 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" + ) + +-- 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 + ) + } + +-- 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 + ) + } + +-- 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) + +-- 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. +-- +-- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is +-- 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 + ) + } + +-- If we run out of binders, stop immediately +-- See Note [Specialisation Must Preserve Sharing] +specHeader env [] _ = pure (False, env, [], [], [], [], [], []) + +-- 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 + + +-- | Binds a dictionary argument to a fresh name, to preserve sharing +bindAuxiliaryDict + :: SpecEnv + -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression + -> ( SpecEnv -- 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 + + -- 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) + + | otherwise -- Non-trivial dictionary arg; make an auxiliary binding + = let fresh_dict_id' = fresh_dict_id `addDictUnfolding` dict_expr + + 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') + +addDictUnfolding :: Id -> CoreExpr -> Id +-- Add unfolding for freshly-bound Ids: see Note [Make the new dictionaries interesting] +-- and Note [Specialisation modulo dictionary selectors] +addDictUnfolding id rhs + = id `setIdUnfolding` mkSimpleUnfolding defaultUnfoldingOpts rhs + +{- +Note [Make the new dictionaries interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Important! We're going to substitute dx_id1 for d +and we want it to look "interesting", else we won't gather *any* +consequential calls. E.g. + f d = ...g d.... +If we specialise f for a call (f (dfun dNumInt)), we'll get +a consequent call (g d') with an auxiliary definition + d' = df dNumInt +We want that consequent call to look interesting; so we add an unfolding +in the dictionary Id. +-} + + +{- ********************************************************************* +* * + UsageDetails and suchlike +* * +********************************************************************* -} + +data UsageDetails + = MkUD { ud_binds :: !FloatedDictBinds + , ud_calls :: !CallDetails } + -- INVARIANT: suppose bs = fdb_bndrs ud_binds + -- Then 'calls' may *mention* 'bs', + -- but there should be no calls *for* bs + +data FloatedDictBinds -- See Note [Floated dictionary bindings] + = FDB { fdb_binds :: !(OrdList DictBind) + -- The order is important; + -- in ds1 `appOL` ds2, bindings in ds2 can depend on those in ds1 + + , fdb_bndrs :: !IdSet + } -- ^ The binders of 'fdb_binds'. + -- Caches a superset of the expression + -- `mkVarSet (bindersOfDictBinds fdb_binds))` + -- for later addition to an InScopeSet + +-- | A 'DictBind' is a binding along with a cached set containing its free +-- variables (both type variables and dictionaries). We need this set +-- in splitDictBinds, when filtering bindings to decide which are +-- captured by a binder +data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet } + +bindersOfDictBind :: DictBind -> [Id] +bindersOfDictBind = bindersOf . db_bind + +bindersOfDictBinds :: Foldable f => f DictBind -> [Id] +bindersOfDictBinds = bindersOfBinds . foldr ((:) . db_bind) [] + +{- Note [Floated dictionary bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We float out dictionary bindings for the reasons described under +"Dictionary floating" above. But not /just/ dictionary bindings. +Consider + + f :: Eq a => blah + f a d = rhs + + $c== :: T -> T -> Bool + $c== x y = ... + + $df :: Eq T + $df = Eq $c== ... + + gurgle = ...(f @T $df)... + +We gather the call info for (f @T $df), and we don't want to drop it +when we come across the binding for $df. So we add $df to the floats +and continue. But then we have to add $c== to the floats, and so on. +These all float above the binding for 'f', and now we can +successfully specialise 'f'. + +So the DictBinds in (ud_binds :: OrdList DictBind) may contain +non-dictionary bindings too. + +Note [Specialising polymorphic dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + class M a where { foo :: a -> Int } + + instance M (ST s) where ... + -- dMST :: forall s. M (ST s) + + wimwam :: forall a. M a => a -> Int + wimwam = /\a \(d::M a). body + + f :: ST s -> Int + f = /\s \(x::ST s). wimwam @(ST s) (dMST @s) dx + 1 + +We'd like to specialise wimwam at (ST s), thus + $swimwam :: forall s. ST s -> Int + $swimwam = /\s. body[ST s/a, (dMST @s)/d] + + RULE forall s (d :: M (ST s)). + wimwam @(ST s) d = $swimwam @s + +Here are the moving parts: + +(MP1) We must /not/ dump the CallInfo + CIS wimwam (CI { ci_key = [@(ST s), dMST @s] + , ci_fvs = {dMST} }) + when we come to the /\s. Instead, we simply let it continue to float + upwards. Hence ci_fvs is an IdSet, listing the /Ids/ that + are free in the call, but not the /TyVars/. Hence using specArgFreeIds + in singleCall. + + NB to be fully kosher we should explicitly quantifying the CallInfo + over 's', but we don't bother. This would matter if there was an + enclosing binding of the same 's', which I don't expect to happen. + +(MP2) When we come to specialise the call, we must remember to quantify + over 's'. That is done in the SpecType case of specHeader, where + we add 's' (called qvars) to the binders of the RULE and the specialised + 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))) + 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`. + +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` +above, and failed to specialise a call in its body like wimwam. +Without the pragma, the original call to `insertWith` was completely +monomorpic, and specialised in one go. + +Wrinkles. + +* See Note [Weird special case for SpecDict] + +* With -XOverlappingInstances you might worry about this: + class C a where ... + instance C (Maybe Int) where ... -- $df1 :: C (Maybe Int) + instance C (Maybe a) where ... -- $df2 :: forall a. C (Maybe a) + + f :: C a => blah + f = rhs + + g = /\a. ...(f @(Maybe a) ($df2 a))... + h = ...f @(Maybe Int) $df1 + + There are two calls to f, but with different evidence. This patch will + combine them into one. But it's OK: this code will never arise unless you + use -XIncoherentInstances. Even with -XOverlappingInstances, GHC tries hard + to keep dictionaries as singleton types. But that goes out of the window + with -XIncoherentInstances -- and that is true even with ordianry type-class + specialisation (at least if any inlining has taken place). + + GHC makes very few guarantees when you use -XIncoherentInstances, and its + not worth crippling the normal case for the incoherent corner. (The best + thing might be to switch off specialisation altogether if incoherence is + involved... but incoherence is a property of an instance, not a class, so + it's a hard test to make.) + + But see Note [Specialisation and overlapping instances]. + +Note [Weird special case for SpecDict] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are trying to specialise for this this call: + $wsplit @T (mkD @k @(a::k) :: C T) +where + mkD :: forall k (a::k). C T +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 + + RULE "SPEC" forall (d :: C T). $wsplit @T d = $s$wsplit + +but then in the body of $s$wsplit what will we use for the dictionary +evidence? We can't use (mkD @k @(a::k)) because k and a aren't in scope. +We could zap `k` to (Any @Type) and `a` to (Any @(Any @Type)), but that +is a lot of hard work for a very strange case. + +So we simply refrain from specialising in this case; hence the guard + allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d) +in the SpecDict cased of specHeader. + +How did this strange polymorphic mkD arise in the first place? +From GHC.Core.Opt.Utils.abstractFloats, which was abstracting +over too many type variables. But that too is now fixed; +see Note [Which type variables to abstract over] in that module. +-} + +instance Outputable DictBind where + ppr (DB { db_bind = bind, db_fvs = fvs }) + = text "DB" <+> braces (sep [ text "fvs: " <+> ppr fvs + , text "bind:" <+> ppr bind ]) + +instance Outputable UsageDetails where + ppr (MkUD { ud_binds = dbs, ud_calls = calls }) + = text "MkUD" <+> braces (sep (punctuate comma + [text "binds" <+> equals <+> ppr dbs, + text "calls" <+> equals <+> ppr calls])) + +instance Outputable FloatedDictBinds where + ppr (FDB { fdb_binds = binds }) = ppr binds + +emptyUDs :: UsageDetails +emptyUDs = MkUD { ud_binds = emptyFDBs, ud_calls = emptyDVarEnv } + + +emptyFDBs :: FloatedDictBinds +emptyFDBs = FDB { fdb_binds = nilOL, fdb_bndrs = emptyVarSet } + +------------------------------------------------------------ +type CallDetails = DIdEnv CallInfoSet + -- The order of specialized binds and rules depends on how we linearize + -- CallDetails, so to get determinism we must use a deterministic set here. + -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM + +data CallInfoSet = CIS Id (Bag CallInfo) + -- 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 + +data CallInfo + = CI { ci_key :: [SpecArg] -- All arguments + , ci_fvs :: IdSet -- Free Ids of the ci_key call + -- /not/ including the main id itself, of course + -- NB: excluding tyvars: + -- See Note [Specialising polymorphic dictionaries] + } + +type DictExpr = CoreExpr + +ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet +ciSetFilter p (CIS id a) = CIS id (filterBag p a) + +instance Outputable CallInfoSet where + ppr (CIS fn map) = hang (text "CIS" <+> ppr fn) + 2 (ppr map) + +pprCallInfo :: Id -> CallInfo -> SDoc +pprCallInfo fn (CI { ci_key = key }) + = ppr fn <+> ppr key + +instance Outputable CallInfo where + ppr (CI { ci_key = key, ci_fvs = _fvs }) + = text "CI" <> braces (sep (map ppr key)) + +unionCalls :: CallDetails -> CallDetails -> CallDetails +unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2 + +unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet +unionCallInfoSet (CIS f calls1) (CIS _ calls2) = + CIS f (calls1 `unionBags` calls2) + +callDetailsFVs :: CallDetails -> VarSet +callDetailsFVs calls = + nonDetStrictFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls + -- It's OK to use nonDetStrictFoldUDFM here because we forget the ordering + -- immediately by converting to a nondeterministic set. + +callInfoFVs :: CallInfoSet -> VarSet +callInfoFVs (CIS _ call_info) = + foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info + +getTheta :: [PiTyBinder] -> [PredType] +getTheta = fmap piTyBinderType . filter isInvisiblePiTyBinder . filter isAnonPiTyBinder + + +------------------------------------------------------------ +singleCall :: Id -> [SpecArg] -> UsageDetails +singleCall id args + = MkUD {ud_binds = emptyFDBs, + ud_calls = unitDVarEnv id $ CIS id $ + unitBag (CI { ci_key = args + , ci_fvs = call_fvs }) } + where + call_fvs = foldr (unionVarSet . specArgFreeIds) emptyVarSet args + -- specArgFreeIds: we specifically look for free Ids, not TyVars + -- see (MP1) in Note [Specialising polymorphic dictionaries] + -- + -- We don't include the 'id' itself. + +mkCallUDs :: SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails +mkCallUDs env fun args + | (_, Var f) <- stripTicksTop tickishFloatable fun -- See Note [Ticks on applications] + = -- pprTraceWith "mkCallUDs" (\res -> vcat [ ppr f, ppr args, ppr res ]) $ + mkCallUDs' env f args + | otherwise + = emptyUDs + +mkCallUDs' :: SpecEnv -> Id -> [OutExpr] -> UsageDetails +mkCallUDs' env f args + | wantCallsFor env f -- We want it, and... + , not (null ci_key) -- this call site has a useful specialisation + = -- pprTrace "mkCallUDs: keeping" _trace_doc + singleCall f ci_key + + | otherwise -- See also Note [Specialisations already covered] + = -- pprTrace "mkCallUDs: discarding" _trace_doc + emptyUDs + + where + _trace_doc = vcat [ppr f, ppr args, ppr ci_key] + pis = fst $ splitPiTys $ idType f + constrained_tyvars = tyCoVarsOfTypes $ getTheta pis + + 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 + + mk_spec_arg :: OutExpr -> PiTyBinder -> SpecArg + mk_spec_arg arg (Named bndr) + | binderVar bndr `elemVarSet` constrained_tyvars + = case arg of + Type ty -> SpecType ty + _ -> pprPanic "ci_key" $ ppr arg + | otherwise = UnspecType + + -- 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) + | isInvisibleFunArg af + , interestingDict arg (scaledThing pred) + -- See Note [Interesting dictionary arguments] + = SpecDict arg + + | otherwise = UnspecArg + +{- +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 + + App (Tick _ f) e + +we need to descend below the tick to find what the real function being +applied is. + +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 [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, + +* 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. + +Note [Update unfolding after specialisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#21848) + + wombat :: Show b => Int -> b -> String + wombat a b | a>0 = wombat (a-1) b + | otherwise = show a ++ wombat a b + + class C a where + meth :: Show b => a -> b -> String + dummy :: a -> () -- Force a datatype dictionary representation + + instance C Int where + meth = wombat + dummy _ = () + + class C a => D a -- D has C as a superclass + instance D Int + + f :: (D a, Show b) => a -> b -> String + {-# INLINABLE[0] f #-} + f a b = meth a b ++ "!" ++ meth a b + +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 +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`. + +We deliver on this idea by updating the unfolding for the binder +in the NonRec case of specBind. (This is too exotic to trouble with +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}) + = MkUD { ud_binds = db1 `thenFDBs` db2 + , ud_calls = calls1 `unionCalls` calls2 } + +thenFDBs :: FloatedDictBinds -> FloatedDictBinds -> FloatedDictBinds +-- Combine FloatedDictBinds +-- In (dbs1 `thenFDBs` dbs2), dbs2 may mention dbs1 but not vice versa +thenFDBs (FDB { fdb_binds = dbs1, fdb_bndrs = bs1 }) + (FDB { fdb_binds = dbs2, fdb_bndrs = bs2 }) + = FDB { fdb_binds = dbs1 `appOL` dbs2 + , fdb_bndrs = bs1 `unionVarSet` bs2 } + +----------------------------- +_dictBindBndrs :: OrdList DictBind -> [Id] +_dictBindBndrs dbs = foldr ((++) . bindersOf . db_bind) [] dbs + +-- | Construct a 'DictBind' from a 'CoreBind' +mkDB :: CoreBind -> DictBind +mkDB bind = DB { db_bind = bind, db_fvs = bind_fvs bind } + +-- | Identify the free variables of a 'CoreBind' +bind_fvs :: CoreBind -> VarSet +bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs) +bind_fvs (Rec prs) = rhs_fvs `delVarSetList` (map fst prs) + where + rhs_fvs = unionVarSets (map pair_fvs prs) + +pair_fvs :: (Id, CoreExpr) -> VarSet +pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs + `unionVarSet` idFreeVars bndr + -- idFreeVars: don't forget variables mentioned in + -- the rules of the bndr. C.f. OccAnal.addRuleUsage + -- Also tyvars mentioned in its type; they may not appear + -- in the RHS + -- type T a = Int + -- x :: T a = 3 + where + interesting :: InterestingVarFun + interesting v = isLocalVar v || (isId v && isDFunId v) + -- Very important: include DFunIds /even/ if it is imported + -- Reason: See Note [Avoiding loops in specImports], the #13429 + -- example involving an imported dfun. We must know + -- whether a dictionary binding depends on an imported + -- DFun in case we try to specialise that imported DFun + +-- | Flatten a set of "dumped" 'DictBind's, and some other binding +-- pairs, into a single recursive binding. +recWithDumpedDicts :: [(Id,CoreExpr)] -> OrdList DictBind -> DictBind +recWithDumpedDicts pairs dbs + = DB { db_bind = Rec bindings + , db_fvs = fvs `delVarSetList` map fst bindings } + where + (bindings, fvs) = foldr add ([], emptyVarSet) + (dbs `snocOL` mkDB (Rec pairs)) + add (DB { db_bind = bind, db_fvs = fvs }) (prs_acc, fvs_acc) + = case bind of + NonRec b r -> ((b,r) : prs_acc, fvs') + Rec prs1 -> (prs1 ++ prs_acc, fvs') + where + fvs' = fvs_acc `unionVarSet` fvs + +snocDictBind :: UsageDetails -> DictBind -> UsageDetails +snocDictBind uds@MkUD{ud_binds= FDB { fdb_binds = dbs, fdb_bndrs = bs }} db + = uds { ud_binds = FDB { fdb_binds = dbs `snocOL` db + , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } } + +snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails +-- Add ud_binds to the tail end of the bindings in uds +snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs + = uds { ud_binds = FDB { fdb_binds = binds `appOL` (toOL dbs) + , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } } + +consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails +consDictBinds dbs uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}} + = uds { ud_binds = FDB{ fdb_binds = toOL dbs `appOL` binds + , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } } + +wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind] +wrapDictBinds (FDB { fdb_binds = dbs }) binds + = foldr add binds dbs + where + add (DB { db_bind = bind }) binds = bind : binds + +wrapDictBindsE :: OrdList DictBind -> CoreExpr -> CoreExpr +wrapDictBindsE dbs expr + = foldr add expr dbs + where + add (DB { db_bind = bind }) expr = Let bind expr + +---------------------- +dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind) +-- 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) $ + (free_uds, dump_dbs) + where + free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls } + bndr_set = mkVarSet bndrs + (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set + free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor + deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be + -- no calls for any of the dicts in dump_dbs + +dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind, Bool) +-- Used at a let(rec) binding. +-- We return a boolean indicating whether the binding itself is mentioned, +-- directly or indirectly, by any of the ud_calls; in that case we want to +-- float the binding itself; +-- See Note [Floated dictionary bindings] +dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) + = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs $$ ppr float_all) $ + (free_uds, dump_dbs, float_all) + where + free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } + bndr_set = mkVarSet bndrs + (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set + free_calls = deleteCallsFor bndrs orig_calls + float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls + +callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo]) +callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls } + = -- pprTrace ("callsForMe") + -- (vcat [ppr fn, + -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), + -- text "Orig calls =" <+> ppr orig_calls, + -- text "Calls for me =" <+> ppr calls_for_me]) $ + (uds_without_me, calls_for_me) + where + uds_without_me = uds { ud_calls = delDVarEnv orig_calls fn } + 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)]) +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)] + where + de_dupd_calls = remove_dups call_bag + + dump_set = foldl' go (unitVarSet fn) dbs + -- This dump-set could also be computed by splitDictBinds + -- (_,_,dump_set) = splitDictBinds dbs {fn} + -- But this variant is shorter + + go so_far (DB { db_bind = bind, db_fvs = fvs }) + | fvs `intersectsVarSet` so_far + = extendVarSetList so_far (bindersOf bind) + | otherwise = so_far + + ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set + +remove_dups :: 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 + where + add :: CallInfo -> [CallInfo] -> [CallInfo] + add ci [] = [ci] + add ci1 (ci2:cis) | ci2 `beats_or_same` ci1 = ci2:cis + | ci1 `beats_or_same` ci2 = ci1:cis + | otherwise = ci2 : add ci1 cis + +beats_or_same :: CallInfo -> CallInfo -> Bool +beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 }) + = go args1 args2 + where + go [] _ = True + go (arg1:args1) (arg2:args2) = go_arg arg1 arg2 && go args1 args2 + go (_:_) [] = False + + go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2) + go_arg UnspecType UnspecType = True + go_arg (SpecDict {}) (SpecDict {}) = True + go_arg UnspecArg UnspecArg = True + go_arg _ _ = False + +---------------------- +splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, OrdList DictBind, IdSet) +-- splitDictBinds dbs bndrs returns +-- (free_dbs, dump_dbs, dump_set) +-- where +-- * dump_dbs depends, transitively on bndrs +-- * free_dbs does not depend on bndrs +-- * dump_set = bndrs `union` bndrs(dump_dbs) +splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set + = (FDB { fdb_binds = free_dbs + , fdb_bndrs = bs `minusVarSet` dump_set } + , dump_dbs, dump_set) + where + (free_dbs, dump_dbs, dump_set) + = foldl' split_db (nilOL, nilOL, bndr_set) dbs + -- Important that it's foldl' not foldr; + -- we're accumulating the set of dumped ids in dump_set + + split_db (free_dbs, dump_dbs, dump_idset) db + | DB { db_bind = bind, db_fvs = fvs } <- db + , dump_idset `intersectsVarSet` fvs -- Dump it + = (free_dbs, dump_dbs `snocOL` db, + extendVarSetList dump_idset (bindersOf bind)) + + | otherwise -- Don't dump it + = (free_dbs `snocOL` db, dump_dbs, dump_idset) + + +---------------------- +deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails +-- Remove calls mentioning any Id in bndrs +-- NB: The call is allowed to mention TyVars in bndrs +-- Note [Specialising polymorphic dictionaries] +-- ci_fvs are just the free /Ids/ +deleteCallsMentioning bndrs calls + = mapDVarEnv (ciSetFilter keep_call) calls + where + keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bndrs + +deleteCallsFor :: [Id] -> CallDetails -> CallDetails +-- Remove calls *for* bndrs +deleteCallsFor bndrs calls = delDVarEnvList calls bndrs + +{- +************************************************************************ +* * +\subsubsection{Boring helper functions} +* * +************************************************************************ +-} + +type SpecM a = UniqSM a + +runSpecM :: SpecM a -> CoreM a +runSpecM thing_inside + = do { us <- getUniqueSupplyM + ; return (initUs_ us thing_inside) } + +mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails) +mapAndCombineSM _ [] = return ([], emptyUDs) +mapAndCombineSM f (x:xs) = do (y, uds1) <- f x + (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 } + +extendInScope :: SpecEnv -> OutId -> SpecEnv +extendInScope env@(SE { se_subst = subst }) bndr + = env { se_subst = subst `Core.extendSubstInScope` bndr } + +zapSubst :: SpecEnv -> SpecEnv +zapSubst env@(SE { se_subst = subst }) + = env { se_subst = Core.zapSubst subst } + +substTy :: SpecEnv -> Type -> Type +substTy env ty = substTyUnchecked (se_subst env) ty + +substCo :: SpecEnv -> Coercion -> Coercion +substCo env co = Core.substCo (se_subst env) co + +substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr) +substBndr env bs = case Core.substBndr (se_subst env) bs of + (subst', bs') -> (env { se_subst = subst' }, bs') + +substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr]) +substBndrs env bs = case Core.substBndrs (se_subst env) bs of + (subst', bs') -> (env { se_subst = subst' }, bs') + +cloneBndrSM :: SpecEnv -> Id -> SpecM (SpecEnv, Id) +-- Clone the binders of the bind; return new bind with the cloned binders +-- Return the substitution to use for RHSs, and the one to use for the body +-- Discards non-Stable unfoldings +cloneBndrSM env@(SE { se_subst = subst }) bndr + = do { us <- getUniqueSupplyM + ; let (subst', bndr') = Core.cloneIdBndr subst us bndr + ; return (env { se_subst = subst' }, bndr') } + +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' } + ; 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 :: Id -> Type -> Maybe JoinArity -> SpecM Id + -- Give the new Id a similar occurrence name to the old one +newSpecIdSM old_id new_ty join_arity_maybe + = do { uniq <- getUniqueM + ; let name = idName old_id + new_occ = mkSpecOcc (nameOccName name) + new_id = mkUserLocal new_occ uniq ManyTy new_ty (getSrcSpan name) + `asJoinId_maybe` join_arity_maybe + ; return new_id } {- Old (but interesting) stuff about unboxed bindings 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 @@ -54,20 +54,23 @@ import GHC.Prelude -import GHC.Types.Var import GHC.Core import GHC.Core.Utils import GHC.Core.Type import GHC.Core.Coercion +import GHC.Core.TyCo.Compare( eqType ) + +import GHC.Types.Var import GHC.Types.Id import GHC.Types.Name import GHC.Types.Var.Env import GHC.Types.Unique.Supply -import GHC.Utils.Misc import GHC.Types.Unique.FM import GHC.Types.Var.Set import GHC.Types.Unique import GHC.Types.Unique.Set + +import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -420,13 +423,13 @@ shadow_rhs = mkLams shadow_lam_bndrs local_body -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs - rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq Many (exprType rec_body) + rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq ManyTy (exprType rec_body) -- rec_body_bndr = sat_worker -- See Note [Shadow binding]; make a SysLocal shadow_bndr = mkSysLocal (occNameFS (getOccName binder)) (idUnique binder) - Many + ManyTy (exprType shadow_rhs) isStaticValue :: Staticness App -> Bool diff --git a/GHC/Core/Opt/Stats.hs b/GHC/Core/Opt/Stats.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Opt/Stats.hs @@ -0,0 +1,330 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +-} + +{-# LANGUAGE DerivingVia #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +module GHC.Core.Opt.Stats ( + SimplCount, doSimplTick, doFreeSimplTick, simplCountN, + pprSimplCount, plusSimplCount, zeroSimplCount, + isZeroSimplCount, hasDetailedCounts, Tick(..) + ) where + +import GHC.Prelude + +import GHC.Types.Var +import GHC.Types.Error + +import GHC.Utils.Outputable as Outputable + +import GHC.Data.FastString + +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Ord +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Map.Strict as MapStrict +import GHC.Utils.Panic (throwGhcException, GhcException(..)) + +getVerboseSimplStats :: (Bool -> SDoc) -> SDoc +getVerboseSimplStats = getPprDebug -- For now, anyway + +zeroSimplCount :: Bool -- ^ -ddump-simpl-stats + -> SimplCount +isZeroSimplCount :: SimplCount -> Bool +hasDetailedCounts :: SimplCount -> Bool +pprSimplCount :: SimplCount -> SDoc +doSimplTick :: Int -- ^ History size of the elaborate counter + -> Tick -> SimplCount -> SimplCount +doFreeSimplTick :: Tick -> SimplCount -> SimplCount +plusSimplCount :: SimplCount -> SimplCount -> SimplCount + +data SimplCount + = VerySimplCount !Int -- Used when don't want detailed stats + + | SimplCount { + ticks :: !Int, -- Total ticks + details :: !TickCounts, -- How many of each type + + n_log :: !Int, -- N + log1 :: [Tick], -- Last N events; <= opt_HistorySize, + -- most recent first + log2 :: [Tick] -- Last opt_HistorySize events before that + -- Having log1, log2 lets us accumulate the + -- recent history reasonably efficiently + } + +type TickCounts = Map Tick Int + +simplCountN :: SimplCount -> Int +simplCountN (VerySimplCount n) = n +simplCountN (SimplCount { ticks = n }) = n + +zeroSimplCount dump_simpl_stats + -- This is where we decide whether to do + -- the VerySimpl version or the full-stats version + | dump_simpl_stats + = SimplCount {ticks = 0, details = Map.empty, + n_log = 0, log1 = [], log2 = []} + | otherwise + = VerySimplCount 0 + +isZeroSimplCount (VerySimplCount n) = n==0 +isZeroSimplCount (SimplCount { ticks = n }) = n==0 + +hasDetailedCounts (VerySimplCount {}) = False +hasDetailedCounts (SimplCount {}) = True + +doFreeSimplTick tick sc@SimplCount { details = dts } + = sc { details = dts `addTick` tick } +doFreeSimplTick _ sc = sc + +doSimplTick history_size tick + sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) + | nl >= history_size = sc1 { n_log = 1, log1 = [tick], log2 = l1 } + | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } + where + sc1 = sc { ticks = tks+1, details = dts `addTick` tick } + +doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) + + +addTick :: TickCounts -> Tick -> TickCounts +addTick fm tick = MapStrict.insertWith (+) tick 1 fm + +plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) + sc2@(SimplCount { ticks = tks2, details = dts2 }) + = log_base { ticks = tks1 + tks2 + , details = MapStrict.unionWith (+) dts1 dts2 } + where + -- A hackish way of getting recent log info + log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 + | null (log2 sc2) = sc2 { log2 = log1 sc1 } + | otherwise = sc2 + +plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) +plusSimplCount lhs rhs = + throwGhcException . PprProgramError "plusSimplCount" $ vcat + [ text "lhs" + , pprSimplCount lhs + , text "rhs" + , pprSimplCount rhs + ] + -- We use one or the other consistently + +pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n +pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) + = vcat [text "Total ticks: " <+> int tks, + blankLine, + pprTickCounts dts, + getVerboseSimplStats $ \dbg -> if dbg + then + vcat [blankLine, + text "Log (most recent first)", + nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] + else Outputable.empty + ] + +{- Note [Which transformations are innocuous] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one point (Jun 18) I wondered if some transformations (ticks) +might be "innocuous", in the sense that they do not unlock a later +transformation that does not occur in the same pass. If so, we could +refrain from bumping the overall tick-count for such innocuous +transformations, and perhaps terminate the simplifier one pass +earlier. + +But alas I found that virtually nothing was innocuous! This Note +just records what I learned, in case anyone wants to try again. + +These transformations are not innocuous: + +*** NB: I think these ones could be made innocuous + EtaExpansion + LetFloatFromLet + +LetFloatFromLet + x = K (let z = e2 in Just z) + prepareRhs transforms to + x2 = let z=e2 in Just z + x = K xs + And now more let-floating can happen in the + next pass, on x2 + +PreInlineUnconditionally + Example in spectral/cichelli/Auxil + hinsert = ...let lo = e in + let j = ...lo... in + case x of + False -> () + True -> case lo of I# lo' -> + ...j... + When we PreInlineUnconditionally j, lo's occ-info changes to once, + so it can be PreInlineUnconditionally in the next pass, and a + cascade of further things can happen. + +PostInlineUnconditionally + let x = e in + let y = ...x.. in + case .. of { A -> ...x...y... + B -> ...x...y... } + Current postinlineUnconditinaly will inline y, and then x; sigh. + + But PostInlineUnconditionally might also unlock subsequent + transformations for the same reason as PreInlineUnconditionally, + so it's probably not innocuous anyway. + +KnownBranch, BetaReduction: + May drop chunks of code, and thereby enable PreInlineUnconditionally + for some let-binding which now occurs once + +EtaExpansion: + Example in imaginary/digits-of-e1 + fail = \void. e where e :: IO () + --> etaExpandRhs + fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) + --> Next iteration of simplify + fail1 = \void. \s. (e |> g) s + fail = fail1 |> Void# -> sym g + And now inline 'fail' + +CaseMerge: + case x of y { + DEFAULT -> case y of z { pi -> ei } + alts2 } + ---> CaseMerge + case x of { pi -> let z = y in ei + ; alts2 } + The "let z=y" case-binder-swap gets dealt with in the next pass +-} + +pprTickCounts :: Map Tick Int -> SDoc +pprTickCounts counts + = vcat (map pprTickGroup groups) + where + groups :: [NonEmpty (Tick, Int)] -- Each group shares a common tag + -- toList returns common tags adjacent + groups = NE.groupWith (tickToTag . fst) (Map.toList counts) + +pprTickGroup :: NonEmpty (Tick, Int) -> SDoc +pprTickGroup group@((tick1,_) :| _) + = hang (int (sum (fmap snd group)) <+> pprTickType tick1) + 2 (vcat [ int n <+> pprTickCts tick + -- flip as we want largest first + | (tick,n) <- sortOn (Down . snd) (NE.toList group)]) + +data Tick -- See Note [Which transformations are innocuous] + = PreInlineUnconditionally Id + | PostInlineUnconditionally Id + + | UnfoldingDone Id + | RuleFired FastString -- Rule name + + | LetFloatFromLet + | EtaExpansion Id -- LHS binder + | EtaReduction Id -- Binder on outer lambda + | BetaReduction Id -- Lambda binder + + + | CaseOfCase Id -- Bndr on *inner* case + | KnownBranch Id -- Case binder + | CaseMerge Id -- Binder on outer case + | AltMerge Id -- Case binder + | CaseElim Id -- Case binder + | CaseIdentity Id -- Case binder + | FillInCaseDefault Id -- Case binder + + | SimplifierDone -- Ticked at each iteration of the simplifier + +instance Outputable Tick where + ppr tick = pprTickType tick <+> pprTickCts tick + +instance Eq Tick where + a == b = case a `cmpTick` b of + EQ -> True + _ -> False + +instance Ord Tick where + compare = cmpTick + +tickToTag :: Tick -> Int +tickToTag (PreInlineUnconditionally _) = 0 +tickToTag (PostInlineUnconditionally _) = 1 +tickToTag (UnfoldingDone _) = 2 +tickToTag (RuleFired _) = 3 +tickToTag LetFloatFromLet = 4 +tickToTag (EtaExpansion _) = 5 +tickToTag (EtaReduction _) = 6 +tickToTag (BetaReduction _) = 7 +tickToTag (CaseOfCase _) = 8 +tickToTag (KnownBranch _) = 9 +tickToTag (CaseMerge _) = 10 +tickToTag (CaseElim _) = 11 +tickToTag (CaseIdentity _) = 12 +tickToTag (FillInCaseDefault _) = 13 +tickToTag SimplifierDone = 16 +tickToTag (AltMerge _) = 17 + +pprTickType :: Tick -> SDoc +pprTickType (PreInlineUnconditionally _) = text "PreInlineUnconditionally" +pprTickType (PostInlineUnconditionally _)= text "PostInlineUnconditionally" +pprTickType (UnfoldingDone _) = text "UnfoldingDone" +pprTickType (RuleFired _) = text "RuleFired" +pprTickType LetFloatFromLet = text "LetFloatFromLet" +pprTickType (EtaExpansion _) = text "EtaExpansion" +pprTickType (EtaReduction _) = text "EtaReduction" +pprTickType (BetaReduction _) = text "BetaReduction" +pprTickType (CaseOfCase _) = text "CaseOfCase" +pprTickType (KnownBranch _) = text "KnownBranch" +pprTickType (CaseMerge _) = text "CaseMerge" +pprTickType (AltMerge _) = text "AltMerge" +pprTickType (CaseElim _) = text "CaseElim" +pprTickType (CaseIdentity _) = text "CaseIdentity" +pprTickType (FillInCaseDefault _) = text "FillInCaseDefault" +pprTickType SimplifierDone = text "SimplifierDone" + +pprTickCts :: Tick -> SDoc +pprTickCts (PreInlineUnconditionally v) = ppr v +pprTickCts (PostInlineUnconditionally v)= ppr v +pprTickCts (UnfoldingDone v) = ppr v +pprTickCts (RuleFired v) = ppr v +pprTickCts LetFloatFromLet = Outputable.empty +pprTickCts (EtaExpansion v) = ppr v +pprTickCts (EtaReduction v) = ppr v +pprTickCts (BetaReduction v) = ppr v +pprTickCts (CaseOfCase v) = ppr v +pprTickCts (KnownBranch v) = ppr v +pprTickCts (CaseMerge v) = ppr v +pprTickCts (AltMerge v) = ppr v +pprTickCts (CaseElim v) = ppr v +pprTickCts (CaseIdentity v) = ppr v +pprTickCts (FillInCaseDefault v) = ppr v +pprTickCts _ = Outputable.empty + +cmpTick :: Tick -> Tick -> Ordering +cmpTick a b = case (tickToTag a `compare` tickToTag b) of + GT -> GT + EQ -> cmpEqTick a b + LT -> LT + +cmpEqTick :: Tick -> Tick -> Ordering +cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b +cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b +cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b +cmpEqTick (RuleFired a) (RuleFired b) = a `uniqCompareFS` b +cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b +cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b +cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b +cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b +cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b +cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b +cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b +cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b +cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b +cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b +cmpEqTick _ _ = EQ 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 @@ -5,18 +5,19 @@ -} -module GHC.Core.Opt.WorkWrap ( wwTopBinds ) where +module GHC.Core.Opt.WorkWrap + ( WwOpts (..) + , wwTopBinds + ) +where import GHC.Prelude -import GHC.Driver.Session - import GHC.Core import GHC.Core.Unfold.Make import GHC.Core.Utils ( exprType, exprIsHNF ) import GHC.Core.Type import GHC.Core.Opt.WorkWrap.Utils -import GHC.Core.FamInstEnv import GHC.Core.SimpleOpt import GHC.Types.Var @@ -34,8 +35,6 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Monad -import GHC.Utils.Trace -import GHC.Unit.Types import GHC.Core.DataCon {- @@ -66,14 +65,12 @@ \end{enumerate} -} -wwTopBinds :: Module -> DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram +wwTopBinds :: WwOpts -> UniqSupply -> CoreProgram -> CoreProgram -wwTopBinds this_mod dflags fam_envs us top_binds +wwTopBinds ww_opts us top_binds = initUs_ us $ do top_binds' <- mapM (wwBind ww_opts) top_binds return (concat top_binds') - where - ww_opts = initWwOpts this_mod dflags fam_envs {- ************************************************************************ @@ -197,20 +194,48 @@ This comes up in practice (#6056). -Solution: do the w/w for strictness analysis, but transfer the Stable -unfolding to the *worker*. So we will get something like this: +Solution: - {-# INLINE[2] f #-} +* Do the w/w for strictness analysis, even for INLINABLE functions + +* Transfer the Stable unfolding to the *worker*. How do we "transfer + the unfolding"? Easy: by using the old one, wrapped in work_fn! See + GHC.Core.Unfold.Make.mkWorkerUnfolding. + +* We use the /original, user-specified/ function's InlineSpec pragma + for both the wrapper and the worker (see `mkStrWrapperInlinePrag`). + So if f is INLINEABLE, both worker and wrapper will get an InlineSpec + of (Inlinable "blah"). + + It's important that both get this, because the specialiser uses + the existence of a /user-specified/ INLINE/INLINABLE pragma to + drive specialisation of imported functions. See GHC.Core.Opt.Specialise + Note [Specialising imported functions] + +* Remember, the subsequent inlining behaviour of the wrapper is expressed by + (a) the stable unfolding + (b) the unfolding guidance of UnfWhen + (c) the inl_act activation (see Note [Wrapper activation] + +For our {-# INLINEABLE f #-} example above, we will get something a +bit like like this: + + {-# Has stable unfolding, active in phase 2; + plus InlineSpec = INLINEABLE #-} f :: Ord a => [a] -> Int -> a f d x y = case y of I# y' -> fw d x y' - {-# INLINABLE[2] fw #-} + {-# Has stable unfolding, plus InlineSpec = INLINEABLE #-} fw :: Ord a => [a] -> Int# -> a fw d x y' = let y = I# y' in ...f... -How do we "transfer the unfolding"? Easy: by using the old one, wrapped -in work_fn! See GHC.Core.Unfold.Make.mkWorkerUnfolding. +(Historical note: we used to always give the wrapper an INLINE pragma, +but CSE will not happen if there is a user-specified pragma, but +should happen for w/w’ed things (#14186). But now we simply propagate +any user-defined pragma info, so we'll defeat CSE (rightly) only when +there is a user-supplied INLINE/INLINEABLE pragma.) + Note [No worker/wrapper for record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We sometimes generate a lot of record selectors, and generally the @@ -488,7 +513,7 @@ about INLINE things here. -What if `foo` has no specialiations, is worker/wrappered (with the +What if `foo` has no specialisations, is worker/wrappered (with the wrapper inlining very early), and exported; and then in an importing module we have {-# SPECIALISE foo : ... #-}? @@ -498,19 +523,6 @@ in which case we don't unpack dictionaries for the worker; see see Note [Do not unbox class dictionaries].) -Note [Wrapper NoUserInlinePrag] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We use NoUserInlinePrag on the wrapper, to say that there is no -user-specified inline pragma. (The worker inherits that; see Note -[Worker/wrapper for INLINABLE functions].) The wrapper has no pragma -given by the user. - -(Historical note: we used to give the wrapper an INLINE pragma, but -CSE will not happen if there is a user-specified pragma, but should -happen for w/w’ed things (#14186). We don't need a pragma, because -everything we needs is expressed by (a) the stable unfolding and (b) -the inl_act activation.) - Note [Drop absent bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#19824): @@ -647,7 +659,7 @@ in p `seq` (v,v) I think we'll give `f` the strictness signature ``, where the -`M` sayd that we'll evaluate the first component of the pair at most +`M` says that we'll evaluate the first component of the pair at most once. Why? Because the RHS of the thunk `v` is evaluated at most once. @@ -682,10 +694,11 @@ Note [Don't eta expand in w/w] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A binding where the manifestArity of the RHS is less than idArity of the binder -means GHC.Core.Opt.Arity didn't eta expand that binding. When this happens, it does so -for a reason (see Note [exprArity invariant] in GHC.Core.Opt.Arity) and we probably have -a PAP, cast or trivial expression as RHS. +A binding where the manifestArity of the RHS is less than idArity of +the binder means GHC.Core.Opt.Arity didn't eta expand that binding +When this happens, it does so for a reason (see Note [Arity invariants for bindings] +in GHC.Core.Opt.Arity) and we probably have a PAP, cast or trivial expression +as RHS. Below is a historical account of what happened when w/w still did eta expansion. Nowadays, it doesn't do that, but will simply w/w for the wrong arity, unleashing @@ -746,11 +759,7 @@ --------------------- splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)] splitFun ww_opts fn_id rhs - | not (wrap_dmds `lengthIs` count isId arg_vars) - -- See Note [Don't eta expand in w/w] - = return [(fn_id, rhs)] - - | otherwise + | Just (arg_vars, body) <- collectNValBinders_maybe (length wrap_dmds) rhs = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info))) "splitFun" (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $ @@ -773,10 +782,13 @@ -> do { work_uniq <- getUniqueM ; return (mkWWBindPair ww_opts fn_id fn_info arg_vars body work_uniq div stuff) } } + + | otherwise -- See Note [Don't eta expand in w/w] + = return [(fn_id, rhs)] + where uf_opts = so_uf_opts (wo_simple_opts ww_opts) fn_info = idInfo fn_id - (arg_vars, body) = collectBinders rhs (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info) @@ -874,17 +886,23 @@ fn_rules = ruleInfoRules (ruleInfo fn_info) mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma --- See Note [Wrapper activation] -mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) rules +mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl + , inl_act = fn_act + , inl_rule = rule_info }) rules = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag] , inl_sat = Nothing + + , inl_inline = fn_inl + -- See Note [Worker/wrapper for INLINABLE functions] + , inl_act = activeAfter wrapper_phase + -- See Note [Wrapper activation] + , inl_rule = rule_info } -- RuleMatchInfo is (and must be) unaffected where -- See Note [Wrapper activation] wrapper_phase = foldr (laterPhase . get_rule_phase) earliest_inline_phase rules - earliest_inline_phase = beginPhase act `laterPhase` nextPhase InitialPhase + earliest_inline_phase = beginPhase fn_act `laterPhase` nextPhase InitialPhase -- laterPhase (nextPhase InitialPhase) is a temporary hack -- to inline no earlier than phase 2. I got regressions in -- 'mate', due to changes in full laziness due to Note [Case @@ -906,15 +924,15 @@ Example: -- Original function - f [Demand=] :: (a,a) -> a + f [Demand=] :: (a,a) -> a f = \p -> ... -- Wrapper - f [Demand=] :: a -> a -> a + f [Demand=] :: a -> a -> a f = \p -> case p of (a,b) -> $wf a b -- Worker - $wf [Demand=] :: Int -> Int + $wf [Demand=] :: Int -> Int $wf = \a b -> ... We need to check whether the original function is called once, with @@ -923,7 +941,7 @@ the original function. The demand on the worker is then calculated using mkWorkerDemand, and always of -the form [Demand=] +the form [Demand=] Note [Thunk splitting] ~~~~~~~~~~~~~~~~~~~~~~ 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 @@ -8,22 +8,19 @@ {-# LANGUAGE ViewPatterns #-} module GHC.Core.Opt.WorkWrap.Utils - ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one + ( WwOpts(..), mkWwBodies, mkWWstr, mkWWstr_one , needsVoidWorkerArg , DataConPatContext(..) - , UnboxingDecision(..), wantToUnboxArg + , UnboxingDecision(..), canUnboxArg , findTypeShape, IsRecDataConResult(..), isRecDataCon , mkAbsentFiller , isWorkerSmallEnough, dubiousDataConInstArgTys - , isGoodWorker, badWorker , goodWorker + , boringSplit , usefulSplit ) where import GHC.Prelude -import GHC.Driver.Session -import GHC.Driver.Config (initSimpleOpts) - import GHC.Core import GHC.Core.Utils import GHC.Core.DataCon @@ -59,7 +56,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Trace import Control.Applicative ( (<|>) ) import Control.Monad ( zipWithM ) @@ -139,25 +135,18 @@ data WwOpts = MkWwOpts - { wo_fam_envs :: !FamInstEnvs - , wo_simple_opts :: !SimpleOpts - , wo_cpr_anal :: !Bool - - -- Used for absent argument error message - , wo_module :: !Module - , wo_unlift_strict :: !Bool -- Generate workers even if the only effect is some args - -- get passed unlifted. - -- See Note [WW for calling convention] - } - -initWwOpts :: Module -> DynFlags -> FamInstEnvs -> WwOpts -initWwOpts this_mod dflags fam_envs = MkWwOpts - { wo_fam_envs = fam_envs - , wo_simple_opts = initSimpleOpts dflags - , wo_cpr_anal = gopt Opt_CprAnal dflags - , wo_module = this_mod - , wo_unlift_strict = gopt Opt_WorkerWrapperUnlift dflags - } + { -- | Environment of type/data family instances + wo_fam_envs :: !FamInstEnvs + , -- | Options for the "Simple optimiser" + wo_simple_opts :: !SimpleOpts + , -- | Whether to enable "Constructed Product Result" analysis. + -- (Originally from DOI: 10.1017/S0956796803004751) + wo_cpr_anal :: !Bool + , -- | Used for absent argument error message + wo_module :: !Module + , -- | Generate workers even if the only effect is some args get passed + -- unlifted. See Note [WW for calling convention] + wo_unlift_strict :: !Bool } type WwResult = ([Demand], -- Demands for worker (value) args @@ -229,19 +218,20 @@ 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' = GHC.Core.Subst.substTy subst res_ty - init_cbv_marks = map (const NotMarkedStrict) cloned_arg_vars + res_ty' = substTyUnchecked subst res_ty + init_str_marks = map (const NotMarkedStrict) cloned_arg_vars - ; (useful1, work_args_cbv, wrap_fn_str, fn_args) - <- mkWWstr opts cloned_arg_vars init_cbv_marks + ; (useful1, work_args_str, wrap_fn_str, fn_args) + <- -- pprTrace "mkWWbodies" (ppr fun_id $$ ppr (arg_vars `zip` cloned_arg_vars) $$ ppr demands) $ + mkWWstr opts cloned_arg_vars init_str_marks - ; let (work_args, work_marks) = unzip work_args_cbv + ; let (work_args, work_marks) = unzip work_args_str -- Do CPR w/w. See Note [Always do CPR w/w] ; (useful2, wrap_fn_cpr, work_fn_cpr) <- mkWWcpr_entry opts res_ty' res_cpr - ; let (work_lam_args, work_call_args, work_call_cbv) + ; let (work_lam_args, work_call_args, work_call_str) | needsVoidWorkerArg fun_id arg_vars work_args = addVoidWorkerArg work_args work_marks | otherwise @@ -252,9 +242,9 @@ -- See Note [Join points and beta-redexes] wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work -- See Note [Call-by-value for worker args] - work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_cbv) + work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_str) worker_body = mkLams work_lam_args . work_seq_str_flds . work_fn_cpr . call_rhs - worker_args_dmds= [(idDemandInfo v) | v <- work_call_args, isId v] + worker_args_dmds= [ idDemandInfo v | v <- work_call_args, isId v] ; if ((useful1 && not only_one_void_argument) || useful2) then return (Just (worker_args_dmds, length work_call_args, @@ -575,7 +565,7 @@ saw a type variable in the worker shadowing an outer term-variable binding. We avoid the issue by freshening the argument variables from the original fun -RHS through 'cloneBndrs', which will also take care of subsitution in binder +RHS through 'cloneBndrs', which will also take care of substitution in binder types. Fortunately, it's sufficient to pick the FVs of the arg vars as in-scope set, so that we don't need to do a FV traversal over the whole body of the original function. @@ -605,86 +595,79 @@ -- -- * @dc @exs flds :: T tys@ -- * @co :: T tys ~ ty@ -data DataConPatContext +-- +-- 's' will be 'Demand' or 'Cpr'. +data DataConPatContext s = DataConPatContext { dcpc_dc :: !DataCon , dcpc_tc_args :: ![Type] , dcpc_co :: !Coercion + , dcpc_args :: ![s] } -- | Describes the outer shape of an argument to be unboxed or left as-is -- Depending on how @s@ is instantiated (e.g., 'Demand' or 'Cpr'). -data UnboxingDecision s - = StopUnboxing - -- ^ We ran out of strictness info. Leave untouched. - | DropAbsent - -- ^ The argument/field was absent. Drop it. - | Unbox !DataConPatContext [s] - -- ^ The argument is used strictly or the returned product was constructed, so - -- unbox it. - -- The 'DataConPatContext' carries the bits necessary for - -- instantiation with 'dataConRepInstPat'. - -- The @[s]@ carries the bits of information with which we can continue - -- unboxing, e.g. @s@ will be 'Demand' or 'Cpr'. - | Unlift - -- ^ The argument can't be unboxed, but we want it to be passed evaluated to the worker. +data UnboxingDecision unboxing_info + = DontUnbox -- ^ We ran out of strictness info. Leave untouched. + | DoUnbox !unboxing_info -- ^ The argument is used strictly or the + -- returned product was constructed, so unbox it. + | DropAbsent -- ^ The argument/field was absent. Drop it. --- Do we want to create workers just for unlifting? -wwForUnlifting :: WwOpts -> Bool -wwForUnlifting !opts +instance Outputable i => Outputable (UnboxingDecision i) where + ppr DontUnbox = text "DontUnbox" + ppr DropAbsent = text "DropAbsent" + ppr (DoUnbox i) = text "DoUnbox" <> braces (ppr i) + +-- | Do we want to create workers just for unlifting? +wwUseForUnlifting :: WwOpts -> WwUse +wwUseForUnlifting !opts -- Always unlift if possible - | wo_unlift_strict opts = goodWorker + | wo_unlift_strict opts = usefulSplit -- Don't unlift it would cause additional W/W splits. - | otherwise = badWorker - -badWorker :: Bool -badWorker = False + | otherwise = boringSplit -goodWorker :: Bool -goodWorker = True +-- | Is the worker/wrapper split profitable? +type WwUse = Bool -isGoodWorker :: Bool -> Bool -isGoodWorker = id +-- | WW split not profitable +boringSplit :: WwUse +boringSplit = False +-- | WW split profitable +usefulSplit :: WwUse +usefulSplit = True -- | Unwraps the 'Boxity' decision encoded in the given 'SubDemand' and returns -- a 'DataConPatContext' as well the nested demands on fields of the 'DataCon' -- to unbox. -wantToUnboxArg - :: Bool -- ^ Consider unlifting - -> FamInstEnvs - -> Type -- ^ Type of the argument - -> Demand -- ^ How the arg was used - -> UnboxingDecision Demand +canUnboxArg + :: FamInstEnvs + -> Type -- ^ Type of the argument + -> Demand -- ^ How the arg was used + -> UnboxingDecision (DataConPatContext Demand) -- See Note [Which types are unboxed?] -wantToUnboxArg do_unlifting fam_envs ty dmd@(n :* sd) +canUnboxArg fam_envs ty (n :* sd) | isAbs n = DropAbsent + -- From here we are strict and not absent | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty , Just dc <- tyConSingleAlgDataCon_maybe tc , let arity = dataConRepArity dc - , Just (Unboxed, ds) <- viewProd arity sd -- See Note [Boxity analysis] - -- NB: No strictness or evaluatedness checks for unboxing here. - -- That is done by 'finaliseArgBoxities'! - = Unbox (DataConPatContext dc tc_args co) ds - - -- See Note [CBV Function Ids] - | do_unlifting - , isStrUsedDmd dmd - , not (isFunTy ty) - , not (isUnliftedType ty) -- Already unlifted! - -- NB: function arguments have a fixed RuntimeRep, so it's OK to call isUnliftedType here - = Unlift + , Just (Unboxed, dmds) <- viewProd arity sd -- See Note [Boxity analysis] + , dmds `lengthIs` dataConRepArity dc + = DoUnbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co, dcpc_args = dmds }) | otherwise - = StopUnboxing + = DontUnbox -- | Unboxing strategy for constructed results. -wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr +canUnboxResult :: FamInstEnvs -> Type -> Cpr + -> UnboxingDecision (DataConPatContext Cpr) -- See Note [Which types are unboxed?] -wantToUnboxResult fam_envs ty cpr +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 @@ -699,20 +682,21 @@ -- Deactivates CPR worker/wrapper splits on constructors with non-linear -- arguments, for the moment, because they require unboxed tuple with variable -- multiplicity fields. - = Unbox (DataConPatContext dc tc_args co) arg_cprs + = DoUnbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co, dcpc_args = arg_cprs }) | otherwise - = StopUnboxing + = DontUnbox where -- See Note [non-algebraic or open body type warning] - open_body_ty_warning = warnPprTrace True "wantToUnboxResult: non-algebraic or open body type" (ppr ty) Nothing + open_body_ty_warning = warnPprTrace True "canUnboxResult: non-algebraic or open body type" (ppr ty) Nothing isLinear :: Scaled a -> Bool isLinear (Scaled w _ ) = case w of - One -> True - _ -> False + OneTy -> True + _ -> False {- Note [Which types are unboxed?] @@ -723,7 +707,7 @@ * is an algebraic data type (not a newtype) * is not recursive (as per 'isRecDataCon') * has a single constructor (thus is a "product") - * that may bind existentials + * that may bind existentials (#18982) We can transform > data D a = forall b. D a b > f (D @ex a b) = e @@ -748,8 +732,8 @@ to > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #) -The respective tests are in 'wantToUnboxArg' and -'wantToUnboxResult', respectively. +The respective tests are in 'canUnboxArg' and +'canUnboxResult', respectively. Note that the data constructor /can/ have evidence arguments: equality constraints, type classes etc. So it can be GADT. These evidence @@ -780,7 +764,7 @@ other cases where something went avoidably wrong. This warning also triggers for the stream fusion library within `text`. -We can'easily W/W constructed results like `Stream` because we have no simple +We can't easily W/W constructed results like `Stream` because we have no simple way to express existential types in the worker's type signature. Note [WW for calling convention] @@ -804,17 +788,20 @@ Performing W/W might not always be a win. In particular it's easy to break (badly written, but common) rule frameworks by doing additional W/W splits. -See #20364 for a more detailed explaination. +See #20364 for a more detailed explanation. Hence we have the following strategies with different trade-offs: + A) Never do W/W *just* for unlifting of arguments. + Very conservative - doesn't break any rules - Lot's of performance left on the table + B) Do W/W on just about anything where it might be beneficial. - + Exploits pretty much every oppertunity for unlifting. + + Exploits pretty much every opportunity for unlifting. - A bit of compile time/code size cost for all the wrappers. - Can break rules which would otherwise fire. See #20364. + C) Unlift *any* (non-boot exported) functions arguments if they are strict. That is instead of creating a Worker with the new calling convention we change the calling convention of the binding itself. @@ -824,7 +811,7 @@ - Requires either: ~ Eta-expansion at *all* call sites in order to generate an impedance matcher function. Leading to massive code bloat. - Essentially we end up creating a imprompto wrapper function + Essentially we end up creating a impromptu wrapper function wherever we wouldn't inline the wrapper with a W/W approach. ~ There is the option of achieving this without eta-expansion if we instead expand the partial application code to check for demands on the calling convention and @@ -835,12 +822,61 @@ Currently we use the first approach A) by default, with a flag that allows users to fall back to the more aggressive approach B). + I also tried the third approach C) using eta-expansion at call sites to avoid modifying the PAP-handling code which wasn't fruitful. See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5614#note_389903. We could still try to do C) in the future by having PAP calls which will evaluate the required arguments 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] + +Note [Worker/wrapper for strict arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = case x of + [] -> blah + (y:ys) -> f ys + +Clearly `f` is strict, but its argument is not a product type, so by default +we don't worker/wrapper it. But it is arguably valuable to do so. We could +do this: + + f x = case x of xx { DEFAULT -> $wf xx } + $wf xx = case xx of + [] -> blah + (y:ys) -> f ys + +Now the worker `$wf` knows that its argument `xx` will be evaluated +and properly tagged, so the code for the `case xx` does not need to do +an "eval" (see `GHC.StgToCmm.Expr.cgCase`). A call (f (a:as)) will +have the wrapper inlined, and will drop the `case x`, so no eval +happens at all. + +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`). + +Is this a win? Not always: +* It can cause slight codesize increases. This is since we push evals to every + call sites which there might be many. And the evals will only disappear at + call sites where we already known that the argument is evaluated. + +* It will also cause many more functions to get a worker/wrapper split + which can play badly with rules (see Ticket #20364). In particular + if you depend on rules firing on functions marked as NOINLINE + without marking use sites of these functions as INLINE or INLINEABLE + then things will break. + But if you want a function to match in a RULE, it is /in any case/ good practice to + have a `INLINE[1]` or `NOINLNE[1]` pragma, to ensure that it doesn't inline until + the rule has had a chance to fire. + +So there is a flag, `-fworker-wrapper-cbv`, to control whether we do +w/w on strict arguments (internally `Opt_WorkerWrapperUnlift`). The +flag is off by default. The choice is made in +GHC.Core.Opt.WorkWrape.Utils.wwUseForUnlifting + +See also `Note [WW for calling convention]` in GHC.Core.Opt.WorkWrap.Utils -} {- @@ -854,8 +890,8 @@ mkWWstr :: WwOpts -> [Var] -- Wrapper args; have their demand info on them -- *Includes type variables* - -> [StrictnessMark] -- cbv info for arguments - -> UniqSM (Bool, -- Will this result in a useful worker + -> [StrictnessMark] -- Strictness-mark info for arguments + -> UniqSM (WwUse, -- Will this result in a useful worker [(Var,StrictnessMark)], -- Worker args/their call-by-value semantics. CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call -- and without its lambdas @@ -863,20 +899,19 @@ [CoreExpr]) -- Reboxed args for the call to the -- original RHS. Corresponds one-to-one -- with the wrapper arg vars -mkWWstr opts args cbv_info - = go args cbv_info +mkWWstr opts args str_marks + = -- pprTrace "mkWWstr" (ppr args) $ + go args str_marks where - go_one arg cbv = mkWWstr_one opts arg cbv - - go [] _ = return (badWorker, [], nop_fn, []) - go (arg : args) (cbv:cbvs) - = do { (useful1, args1, wrap_fn1, wrap_arg) <- go_one arg cbv - ; (useful2, args2, wrap_fn2, wrap_args) <- go args cbvs - ; return ( useful1 || useful2 - , args1 ++ args2 - , wrap_fn1 . wrap_fn2 - , wrap_arg:wrap_args ) } - go _ _ = panic "mkWWstr: Impossible - cbv/arg length missmatch" + go [] _ = return (boringSplit, [], nop_fn, []) + go (arg : args) (str:strs) + = do { (useful1, args1, wrap_fn1, wrap_arg) <- mkWWstr_one opts arg str + ; (useful2, args2, wrap_fn2, wrap_args) <- go args strs + ; return ( useful1 || useful2 + , args1 ++ args2 + , wrap_fn1 . wrap_fn2 + , wrap_arg:wrap_args ) } + go _ _ = panic "mkWWstr: Impossible - str/arg length mismatch" ---------------------- -- mkWWstr_one wrap_var = (useful, work_args, wrap_fn, wrap_arg) @@ -888,65 +923,78 @@ mkWWstr_one :: WwOpts -> Var -> StrictnessMark - -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr) -mkWWstr_one opts arg banged = - case wantToUnboxArg True fam_envs arg_ty arg_dmd of + -> UniqSM (WwUse, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr) +mkWWstr_one opts arg str_mark = + -- pprTrace "mkWWstr_one" (ppr arg <+> (if isId arg then ppr arg_ty $$ ppr arg_dmd else text "type arg")) $ + case canUnboxArg fam_envs arg_ty arg_dmd of _ | isTyVar arg -> do_nothing DropAbsent - | Just absent_filler <- mkAbsentFiller opts arg banged - -- Absent case. Dropt the argument from the worker. + | Just absent_filler <- mkAbsentFiller opts arg str_mark + -- Absent case. Drop the argument from the worker. -- We can't always handle absence for arbitrary -- unlifted types, so we need to choose just the cases we can -- (that's what mkAbsentFiller does) - -> return (goodWorker, [], nop_fn, absent_filler) + -> return (usefulSplit, [], nop_fn, absent_filler) + | otherwise -> do_nothing - Unbox dcpc ds -> unbox_one_arg opts arg ds dcpc banged + DoUnbox dcpc -> -- pprTrace "mkWWstr_one:1" (ppr (dcpc_dc dcpc) <+> ppr (dcpc_tc_args dcpc) $$ ppr (dcpc_args dcpc)) $ + unbox_one_arg opts arg dcpc - Unlift -> return ( wwForUnlifting opts - , [(arg, MarkedStrict)] - , nop_fn - , varToCoreExpr arg) + DontUnbox + | isStrictDmd arg_dmd || isMarkedStrict str_mark + , wwUseForUnlifting opts -- See Note [CBV Function Ids] + , not (isFunTy arg_ty) + , not (isUnliftedType arg_ty) -- Already unlifted! + -- NB: function arguments have a fixed RuntimeRep, + -- so it's OK to call isUnliftedType here + -> return (usefulSplit, [(arg, MarkedStrict)], nop_fn, varToCoreExpr arg ) - _ -> do_nothing -- Other cases, like StopUnboxing + | otherwise -> do_nothing where fam_envs = wo_fam_envs opts arg_ty = idType arg arg_dmd = idDemandInfo arg - -- Type args don't get cbv marks - arg_cbv = if isTyVar arg then NotMarkedStrict else banged - - do_nothing = return (badWorker, [(arg,arg_cbv)], nop_fn, varToCoreExpr arg) + arg_str | isTyVar arg = NotMarkedStrict -- Type args don't get strictness marks + | otherwise = str_mark + do_nothing = return (boringSplit, [(arg,arg_str)], nop_fn, varToCoreExpr arg) unbox_one_arg :: WwOpts - -> Var - -> [Demand] - -> DataConPatContext - -> StrictnessMark - -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr) -unbox_one_arg opts arg_var ds - DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args - , dcpc_co = co } - _marked_cbv + -> Var -> DataConPatContext Demand + -> UniqSM (WwUse, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr) +unbox_one_arg opts arg_var + DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co, dcpc_args = ds } = do { pat_bndrs_uniqs <- getUniquesM ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc + -- Create new arguments we get when unboxing dc - (ex_tvs', arg_ids) = - dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg_var) dc tc_args + (ex_tvs', arg_ids) = dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) + pat_bndrs_uniqs (idMult arg_var) dc tc_args con_str_marks = dataConRepStrictness dc - -- Apply str info to new args. Also remove OtherCon unfoldings so they 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 + + -- Apply str info to new args. Also remove OtherCon unfoldings so they + -- 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 + unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var) dc (ex_tvs' ++ arg_ids') - -- Mark arguments coming out of strict fields so we can make the worker strict on those - -- argumnets later. seq them later. See Note [Call-by-value for worker args] - strict_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks - ; (_sub_args_quality, worker_args, wrap_fn, wrap_args) <- mkWWstr opts (ex_tvs' ++ arg_ids') strict_marks + + -- Mark arguments coming out of strict fields so we can seq them in the worker + -- See Note [Call-by-value for worker args] + all_str_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks + + ; (nested_useful, worker_args, wrap_fn, wrap_args) + <- mkWWstr opts (ex_tvs' ++ arg_ids') all_str_marks + ; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co - ; return (goodWorker, worker_args, unbox_fn . wrap_fn, wrap_arg) } - -- Don't pass the arg, rebox instead + -- See Note [Unboxing through unboxed tuples] + ; return $ if isUnboxedTupleDataCon dc && not nested_useful + then (boringSplit, [(arg_var,NotMarkedStrict)], nop_fn, varToCoreExpr arg_var) + else (usefulSplit, worker_args, unbox_fn . wrap_fn, wrap_arg) } -- | Tries to find a suitable absent filler to bind the given absent identifier -- to. See Note [Absent fillers]. @@ -988,7 +1036,7 @@ {- Note [Worker/wrapper for Strictness and Absence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The worker/wrapper transformation, mkWWstr_one, takes concrete action -based on the 'UnboxingDescision' returned by 'wantToUnboxArg'. +based on the 'UnboxingDecision' returned by 'canUnboxArg'. The latter takes into account several possibilities to decide if the function is worthy for splitting: @@ -1002,7 +1050,7 @@ 2. If the argument is evaluated strictly (or known to be eval'd), we can take a view into the product demand ('viewProd'). In accordance - with Note [Boxity analysis], 'wantToUnboxArg' will say 'Unbox'. + with Note [Boxity analysis], 'canUnboxArg' will say 'DoUnbox'. 'mkWWstr_one' then follows suit it and recurses into the fields of the product demand. For example @@ -1024,7 +1072,7 @@ $gw c a b = if c then a else b 2a But do /not/ unbox if Boxity Analysis said "Boxed". - In this case, 'wantToUnboxArg' returns 'StopUnboxing'. + In this case, 'canUnboxArg' returns 'DontUnbox'. Otherwise we risk decomposing and reboxing a massive tuple which is barely used. Example: @@ -1045,7 +1093,7 @@ 3. In all other cases (e.g., lazy, used demand and not eval'd), 'finaliseArgBoxities' will have cleared the Boxity flag to 'Boxed' (see Note [Finalising boxity for demand signatures] in GHC.Core.Opt.DmdAnal) - and 'wantToUnboxArg' returns 'StopUnboxing' so that 'mkWWstr_one' + and 'canUnboxArg' returns 'DontUnbox' so that 'mkWWstr_one' stops unboxing. Note [Worker/wrapper for bottoming functions] @@ -1161,7 +1209,7 @@ NB from Andreas: But I think using an error thunk there would be dodgy no matter what for example if we decide to pass the argument to the bottoming function cbv. As we might do if the function in question is a worker. - See Note [CBV Function Ids] in GHC.CoreToStg.Prep. So I just left the strictness check + See Note [CBV Function Ids] in GHC.Types.Id.Info. So I just left the strictness check in place on top of threading through the marks from the constructor. It's a *really* cheap and easy check to make anyway. @@ -1196,6 +1244,26 @@ because `MkT` is strict in its Int# argument, so we get an absentError exception when we shouldn't. Very annoying! +Note [Unboxing through unboxed tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We should not to a worker/wrapper split just for unboxing the components of +an unboxed tuple (in the result *or* argument, #22388). Consider + boring_res x y = (# y, x #) +It's entirely pointless to split for the constructed unboxed pair to + $wboring_res x y = (# y, x #) + boring_res = case $wboring_res x y of (# a, b #) -> (# a, b #) +`boring_res` will immediately simplify to an alias for `$wboring_res`! + +Similarly, the unboxed tuple might occur in argument position + boring_arg (# x, y, z #) = (# z, x, y #) +It's entirely pointless to "unbox" the triple + $wboring_arg x y z = (# z, x, y #) + boring_arg (# x, y, z #) = $wboring_arg x y z +because after unarisation, `boring_arg` is just an alias for `$wboring_arg`. + +Conclusion: Only consider unboxing an unboxed tuple useful when we will +also unbox its components. That is governed by the `usefulSplit` mechanism. + ************************************************************************ * * Type scrutiny that is specific to demand analysis @@ -1204,16 +1272,25 @@ -} -- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that --- the 'DataCon' may not have existentials. The lack of cloning the existentials --- compared to 'dataConInstExAndArgVars' makes this function \"dubious\"; --- only use it where type variables aren't substituted for! +-- the 'DataCon' may not have existentials. The lack of cloning the +-- existentials this function \"dubious\"; only use it where type variables +-- aren't substituted for! Why may the data con bind existentials? +-- See Note [Which types are unboxed?] dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type] dubiousDataConInstArgTys dc tc_args = arg_tys where - univ_tvs = dataConUnivTyVars dc - ex_tvs = dataConExTyCoVars dc - subst = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs - arg_tys = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc) + univ_tvs = dataConUnivTyVars dc + ex_tvs = dataConExTyCoVars dc + univ_subst = zipTvSubst univ_tvs tc_args + (full_subst, _) = substTyVarBndrs univ_subst ex_tvs + arg_tys = map (substTy full_subst . scaledThing) $ + dataConRepArgTys dc + -- NB: use substTyVarBndrs on ex_tvs to ensure that we + -- substitute in their kinds. For example (#22849) + -- Consider data T a where + -- MkT :: forall k (t::k->*) (ix::k). t ix -> T @k a + -- Then dubiousDataConInstArgTys MkT [Type, Foo] should return + -- [Foo (ix::Type)], not [Foo (ix::k)]! findTypeShape :: FamInstEnvs -> Type -> TypeShape -- Uncover the arrow and product shape of a type @@ -1227,7 +1304,7 @@ -- to look deep into such products -- see #18034 where go rec_tc ty - | Just (_, _, res) <- splitFunTy_maybe ty + | Just (_, _, _, res) <- splitFunTy_maybe ty = TsFun (go rec_tc res) | Just (tc, tc_args) <- splitTyConApp_maybe ty @@ -1291,7 +1368,7 @@ -- through one of @dc@'s fields (so surely non-recursive). -- * @NonRecursiveOrUnsure@ when @fuel /= Infinity@ -- and @fuel@ expansions of nested data TyCons were not enough to prove --- non-recursivenss, nor arrive at an occurrence of @tc@ thus proving +-- non-recursiveness, nor arrive at an occurrence of @tc@ thus proving -- recursiveness. (So not sure if non-recursive.) -- * @NonRecursiveOrUnsure@ when we hit an abstract TyCon (one without -- visible DataCons), such as those imported from .hs-boot files. @@ -1377,12 +1454,12 @@ :: WwOpts -> Type -- function body -> Cpr -- CPR analysis results - -> UniqSM (Bool, -- Is w/w'ing useful? + -> UniqSM (WwUse, -- Is w/w'ing useful? CoreExpr -> CoreExpr, -- New wrapper. 'nop_fn' if not useful CoreExpr -> CoreExpr) -- New worker. 'nop_fn' if not useful -- ^ Entrypoint to CPR W/W. See Note [Worker/wrapper for CPR] for an overview. mkWWcpr_entry opts body_ty body_cpr - | not (wo_cpr_anal opts) = return (badWorker, nop_fn, nop_fn) + | not (wo_cpr_anal opts) = return (boringSplit, nop_fn, nop_fn) | otherwise = do -- Part (1) res_bndr <- mk_res_bndr body_ty @@ -1399,8 +1476,8 @@ let wrap_fn = unbox_transit_tup rebuilt_result -- 3 2 work_fn body = bind_res_bndr body (work_unpack_res transit_tup) -- 1 2 3 return $ if not useful - then (badWorker, nop_fn, nop_fn) - else (goodWorker, wrap_fn, work_fn) + then (boringSplit, nop_fn, nop_fn) + else (usefulSplit, wrap_fn, work_fn) -- | Part (1) of Note [Worker/wrapper for CPR]. mk_res_bndr :: Type -> UniqSM Id @@ -1412,20 +1489,20 @@ -- | What part (2) of Note [Worker/wrapper for CPR] collects. -- --- 1. A Bool capturing whether the transformation did anything useful. +-- 1. A 'WwUse' capturing whether the split does anything useful. -- 2. The list of transit variables (see the Note). -- 3. The result builder expression for the wrapper. The original case binder if not useful. -- 4. The result unpacking expression for the worker. 'nop_fn' if not useful. -type CprWwResultOne = (Bool, OrdList Var, CoreExpr , CoreExpr -> CoreExpr) -type CprWwResultMany = (Bool, OrdList Var, [CoreExpr], CoreExpr -> CoreExpr) +type CprWwResultOne = (WwUse, OrdList Var, CoreExpr , CoreExpr -> CoreExpr) +type CprWwResultMany = (WwUse, OrdList Var, [CoreExpr], CoreExpr -> CoreExpr) mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResultMany mkWWcpr _opts vars [] = -- special case: No CPRs means all top (for example from FlatConCpr), -- hence stop WW. - return (badWorker, toOL vars, map varToCoreExpr vars, nop_fn) + return (boringSplit, toOL vars, map varToCoreExpr vars, nop_fn) mkWWcpr opts vars cprs = do - -- No existentials in 'vars'. 'wantToUnboxResult' should have checked that. + -- No existentials in 'vars'. 'canUnboxResult' should have checked that. massertPpr (not (any isTyVar vars)) (ppr vars $$ ppr cprs) massertPpr (equalLength vars cprs) (ppr vars $$ ppr cprs) (usefuls, varss, rebuilt_results, work_unpack_ress) <- @@ -1439,17 +1516,17 @@ -- ^ See if we want to unbox the result and hand off to 'unbox_one_result'. mkWWcpr_one opts res_bndr cpr | assert (not (isTyVar res_bndr) ) True - , Unbox dcpc arg_cprs <- wantToUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr - = unbox_one_result opts res_bndr arg_cprs dcpc + , DoUnbox dcpc <- canUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr + = unbox_one_result opts res_bndr dcpc | otherwise - = return (badWorker, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn) + = return (boringSplit, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn) unbox_one_result - :: WwOpts -> Id -> [Cpr] -> DataConPatContext -> UniqSM CprWwResultOne + :: WwOpts -> Id -> DataConPatContext Cpr -> UniqSM CprWwResultOne -- ^ Implements the main bits of part (2) of Note [Worker/wrapper for CPR] -unbox_one_result opts res_bndr arg_cprs +unbox_one_result opts res_bndr DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args - , dcpc_co = co } = do + , dcpc_co = co, dcpc_args = arg_cprs } = do -- unboxer (free in `res_bndr`): | builder (where builds what was -- ( case res_bndr of (i, j) -> ) | bound to i) -- ( case i of I# a -> ) | @@ -1458,7 +1535,7 @@ pat_bndrs_uniqs <- getUniquesM let (_exs, arg_ids) = dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args - massert (null _exs) -- Should have been caught by wantToUnboxResult + massert (null _exs) -- Should have been caught by canUnboxResult (nested_useful, transit_vars, con_args, work_unbox_res) <- mkWWcpr opts arg_ids arg_cprs @@ -1468,11 +1545,10 @@ -- this_work_unbox_res alt = (case res_bndr |> co of C a b -> [a,b]) this_work_unbox_res = mkUnpackCase (Var res_bndr) co cprCaseBndrMult dc arg_ids - -- Don't try to WW an unboxed tuple return type when there's nothing inside - -- to unbox further. + -- See Note [Unboxing through unboxed tuples] return $ if isUnboxedTupleDataCon dc && not nested_useful - then ( badWorker, unitOL res_bndr, Var res_bndr, nop_fn ) - else ( goodWorker + then ( boringSplit, unitOL res_bndr, Var res_bndr, nop_fn ) + else ( usefulSplit , transit_vars , rebuilt_result , this_work_unbox_res . work_unbox_res @@ -1506,7 +1582,7 @@ (DataAlt tup_con) vars build_res , ubx_tup_app ) where - ubx_tup_app = mkCoreUbxTup (map idType vars) (map varToCoreExpr vars) + ubx_tup_app = mkCoreUnboxedTuple (map varToCoreExpr vars) tup_con = tupleDataCon Unboxed (length vars) -- See also Note [Linear types and CPR] case_bndr = mkWildValBinder cprCaseBndrMult (exprType ubx_tup_app) @@ -1595,7 +1671,7 @@ We want `$wh :: Int# -> [Int]`. We'd get `$wh :: Int# -> (# [Int] #)`. -By considering vars as unlifted that satsify 'exprIsHNF', we catch (3). +By considering vars as unlifted that satisfy 'exprIsHNF', we catch (3). Why not check for 'exprOkForSpeculation'? Quite perplexingly, evaluated vars are not ok-for-spec, see Note [exprOkForSpeculation and evaluated variables]. For (1) and (2) we would have to look at the term. WW only looks at the @@ -1607,7 +1683,7 @@ Remark on linearity: in both the case of the wrapper and the worker, we build a linear case to unpack constructed products. All the multiplicity information is kept in the constructors (both C and (#, #)). -In particular (#,#) is parametrised by the multiplicity of its fields. +In particular (#,#) is parameterised by the multiplicity of its fields. Specifically, in this instance, the multiplicity of the fields of (#,#) is chosen to be the same as those of C. @@ -1635,7 +1711,7 @@ -- | The multiplicity of a case binder unboxing a constructed result. -- See Note [Linear types and CPR] cprCaseBndrMult :: Mult -cprCaseBndrMult = One +cprCaseBndrMult = OneTy ww_prefix :: FastString ww_prefix = fsLit "ww" diff --git a/GHC/Core/PatSyn.hs b/GHC/Core/PatSyn.hs --- a/GHC/Core/PatSyn.hs +++ b/GHC/Core/PatSyn.hs @@ -38,6 +38,8 @@ import GHC.Utils.Outputable import GHC.Utils.Panic +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + import qualified Data.Data as Data import Data.Function import Data.List (find) @@ -376,7 +378,7 @@ -- | Build a new pattern synonym mkPatSyn :: Name -> Bool -- ^ Is the pattern synonym declared infix? - -> ([InvisTVBinder], ThetaType) -- ^ Universially-quantified type + -> ([InvisTVBinder], ThetaType) -- ^ Universally-quantified type -- variables and required dicts -> ([InvisTVBinder], ThetaType) -- ^ Existentially-quantified type -- variables and provided dicts @@ -387,7 +389,7 @@ -> [FieldLabel] -- ^ Names of fields for -- a record pattern synonym -> PatSyn - -- NB: The univ and ex vars are both in TyBinder form and TyVar form for + -- NB: The univ and ex vars are both in PiTyVarBinder form and TyVar form for -- convenience. All the TyBinders should be Named! mkPatSyn name declared_infix (univ_tvs, req_theta) @@ -506,6 +508,6 @@ , pprType sigma_ty ] where sigma_ty = mkInvisForAllTys ex_tvs $ - mkInvisFunTysMany prov_theta $ + mkInvisFunTys prov_theta $ mkVisFunTysMany orig_args orig_res_ty insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) diff --git a/GHC/Core/Ppr.hs b/GHC/Core/Ppr.hs --- a/GHC/Core/Ppr.hs +++ b/GHC/Core/Ppr.hs @@ -315,8 +315,10 @@ ppr_expr add_par (Tick tickish expr) = sdocOption sdocSuppressTicks $ \case - True -> ppr_expr add_par expr - False -> add_par (sep [ppr tickish, pprCoreExpr expr]) + -- Only hide non-runtime relevant ticks. + True + | not (tickishIsCode tickish) -> ppr_expr add_par expr + _ -> add_par (sep [ppr tickish, pprCoreExpr expr]) pprCoreAlt :: OutputableBndr a => Alt a -> SDoc pprCoreAlt (Alt con args rhs) @@ -615,11 +617,6 @@ brackets (hsep (map int cs)), int size, int discount ] - -instance Outputable UnfoldingSource where - ppr InlineCompulsory = text "Compulsory" - ppr InlineStable = text "InlineStable" - ppr InlineRhs = text "" instance Outputable Unfolding where ppr NoUnfolding = text "No unfolding" diff --git a/GHC/Core/Ppr.hs-boot b/GHC/Core/Ppr.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/Ppr.hs-boot @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module GHC.Core.Ppr where + +import {-# SOURCE #-} GHC.Core +import {-# SOURCE #-} GHC.Types.Var (Var) +import GHC.Utils.Outputable (OutputableBndr, Outputable) + +instance OutputableBndr b => Outputable (Expr b) + +instance OutputableBndr Var diff --git a/GHC/Core/Predicate.hs b/GHC/Core/Predicate.hs --- a/GHC/Core/Predicate.hs +++ b/GHC/Core/Predicate.hs @@ -19,7 +19,7 @@ mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, -- Class predicates - mkClassPred, isDictTy, + mkClassPred, isDictTy, typeDeterminesValue, isClassPred, isEqPredClass, isCTupleClass, getClassPredTys, getClassPredTys_maybe, classMethodTy, classMethodInstTy, @@ -102,6 +102,10 @@ isDictTy :: Type -> Bool isDictTy = isClassPred +typeDeterminesValue :: Type -> Bool +-- See Note [Type determines value] +typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty) + getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) getClassPredTys ty = case getClassPredTys_maybe ty of Just (clas, tys) -> (clas, tys) @@ -132,6 +136,19 @@ = funResultTy $ piResultTys (varType sel_id) arg_tys +{- Note [Type determines value] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Only specialise on non-impicit-parameter predicates, because these +are the ones whose *type* determines their *value*. In particular, +with implicit params, the type args *don't* say what the value of the +implicit param is! See #7101. + +So we treat implicit params just like ordinary arguments for the +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. +-} + -- --------------------- Equality predicates --------------------------------- -- | A choice of equality relation. This is separate from the type 'Role' @@ -225,7 +242,6 @@ isCTupleClass :: Class -> Bool isCTupleClass cls = isTupleTyCon (classTyCon cls) - {- ********************************************************************* * * diff --git a/GHC/Core/Reduction.hs b/GHC/Core/Reduction.hs --- a/GHC/Core/Reduction.hs +++ b/GHC/Core/Reduction.hs @@ -35,14 +35,16 @@ import GHC.Core.Type import GHC.Data.Pair ( Pair(Pair) ) +import GHC.Data.List.Infinite ( Infinite (..) ) +import qualified GHC.Data.List.Infinite as Inf -import GHC.Types.Var ( setTyVarKind ) +import GHC.Types.Var ( VarBndr(..), setTyVarKind ) import GHC.Types.Var.Env ( mkInScopeSet ) import GHC.Types.Var.Set ( TyCoVarSet ) import GHC.Utils.Misc ( HasDebugCallStack, equalLength ) import GHC.Utils.Outputable -import GHC.Utils.Panic ( assertPpr, panic ) +import GHC.Utils.Panic ( assertPpr ) {- %************************************************************************ @@ -349,25 +351,25 @@ -- -- Combines 'mkFunCo' and 'mkFunTy'. mkFunRedn :: Role - -> AnonArgFlag + -> FunTyFlag -> ReductionN -- ^ multiplicity reduction -> Reduction -- ^ argument reduction -> Reduction -- ^ result reduction -> Reduction -mkFunRedn r vis +mkFunRedn r af (Reduction w_co w_ty) (Reduction arg_co arg_ty) (Reduction res_co res_ty) = mkReduction - (mkFunCo r w_co arg_co res_co) - (mkFunTy vis w_ty arg_ty res_ty) + (mkFunCo1 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, -- from a kind 'Reduction' and a body 'Reduction'. -- -- Combines 'mkForAllCo' and 'mkForAllTy'. -mkForAllRedn :: ArgFlag +mkForAllRedn :: ForAllTyFlag -> TyVar -> ReductionN -- ^ kind reduction -> Reduction -- ^ body reduction @@ -375,7 +377,7 @@ mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty) = mkReduction (mkForAllCo tv1 h co) - (mkForAllTy tv2 vis ty) + (mkForAllTy (Bndr tv2 vis) ty) where tv2 = setTyVarKind tv1 ki' {-# INLINE mkForAllRedn #-} @@ -784,11 +786,11 @@ -- This function is only called in two locations, so the amount of code duplication -- should be rather reasonable despite the size of the function. simplifyArgsWorker :: HasDebugCallStack - => [TyCoBinder] -> Kind + => [PiTyBinder] -> Kind -- the binders & result kind (not a Π-type) of the function applied to the args -- list of binders can be shorter or longer than the list of args -> TyCoVarSet -- free vars of the args - -> [Role] -- list of roles, r + -> Infinite Role-- list of roles, r -> [Reduction] -- rewritten type arguments, arg_i -- each comes with the coercion used to rewrite it, -- arg_co_i :: ty_i ~ arg_i @@ -810,10 +812,10 @@ orig_lc = emptyLiftingContext $ mkInScopeSet orig_fvs go :: LiftingContext -- mapping from tyvars to rewriting coercions - -> [TyCoBinder] -- Unsubsted binders of function's kind - -> Kind -- Unsubsted result kind of function (not a Pi-type) - -> [Role] -- Roles at which to rewrite these ... - -> [Reduction] -- rewritten arguments, with their rewriting coercions + -> [PiTyBinder] -- Unsubsted binders of function's kind + -> Kind -- Unsubsted result kind of function (not a Pi-type) + -> Infinite Role -- Roles at which to rewrite these ... + -> [Reduction] -- rewritten arguments, with their rewriting coercions -> ArgsReductions go !lc binders inner_ki _ [] -- The !lc makes the function strict in the lifting context @@ -826,10 +828,10 @@ kind_co | noFreeVarsOfType final_kind = MRefl | otherwise = MCo $ liftCoSubst Nominal lc final_kind - go lc (binder:binders) inner_ki (role:roles) (arg_redn:arg_redns) + go lc (binder:binders) inner_ki (Inf role roles) (arg_redn:arg_redns) = -- We rewrite an argument ty with arg_redn = Reduction arg_co arg -- By Note [Rewriting] in GHC.Tc.Solver.Rewrite invariant (F2), - -- tcTypeKind(ty) = tcTypeKind(arg). + -- typeKind(ty) = typeKind(arg). -- However, it is possible that arg will be used as an argument to a function -- whose kind is different, if earlier arguments have been rewritten. -- We thus need to compose the reduction with a kind coercion to ensure @@ -837,11 +839,11 @@ -- -- The bangs here have been observed to improve performance -- significantly in optimized builds; see #18502 - let !kind_co = liftCoSubst Nominal lc (tyCoBinderType binder) + let !kind_co = liftCoSubst Nominal lc (piTyBinderType binder) !(Reduction casted_co casted_xi) = mkCoherenceRightRedn role arg_redn kind_co -- now, extend the lifting context with the new binding - !new_lc | Just tv <- tyCoBinderVar_maybe binder + !new_lc | Just tv <- namedPiTyBinder_maybe binder = extendLiftingContextAndInScope lc tv casted_co | otherwise = lc @@ -859,7 +861,7 @@ (arg_cos, res_co) = decomposePiCos co1 co1_kind unrewritten_tys casted_args = assertPpr (equalLength arg_redns arg_cos) (ppr arg_redns $$ ppr arg_cos) - $ zipWith3 mkCoherenceRightRedn roles arg_redns arg_cos + $ zipWith3 mkCoherenceRightRedn (Inf.toList roles) arg_redns arg_cos -- In general decomposePiCos can return fewer cos than tys, -- but not here; because we're well typed, there will be enough -- binders. Note that decomposePiCos does substitutions, so even @@ -874,19 +876,3 @@ = go zapped_lc bndrs new_inner roles casted_args in ArgsReductions redns_out (res_co `mkTransMCoR` res_co_out) - - go _ _ _ _ _ = panic - "simplifyArgsWorker wandered into deeper water than usual" - -- This debug information is commented out because leaving it in - -- causes a ~2% increase in allocations in T9872d. - -- That's independent of the analogous case in rewrite_args_fast - -- in GHC.Tc.Solver.Rewrite: - -- each of these causes a 2% increase on its own, so commenting them - -- both out gives a 4% decrease in T9872d. - {- - - (vcat [ppr orig_binders, - ppr orig_inner_ki, - ppr (take 10 orig_roles), -- often infinite! - ppr orig_tys]) - -} diff --git a/GHC/Core/RoughMap.hs b/GHC/Core/RoughMap.hs --- a/GHC/Core/RoughMap.hs +++ b/GHC/Core/RoughMap.hs @@ -13,6 +13,9 @@ , RoughMatchLookupTc(..) , typeToRoughMatchLookupTc , roughMatchTcToLookup + , roughMatchTcs + , roughMatchTcsLookup + , instanceCantMatch -- * RoughMap , RoughMap @@ -37,11 +40,10 @@ import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Name.Env +import GHC.Builtin.Types.Prim( cONSTRAINTTyConName, tYPETyConName ) import Control.Monad (join) import Data.Data (Data) -import GHC.Utils.Misc -import Data.Bifunctor import GHC.Utils.Panic {- @@ -106,8 +108,12 @@ KnownTc Int, KnownTc Char]`. This explains the third clause of the mightMatch specification in Note [Simple Matching Semantics]. -As soon as the the lookup key runs out, the remaining instances might match. +As soon as the lookup key runs out, the remaining instances might match. +This only matters for the data-family case of a FamInstEnv (see Note [Over-saturated matches] +in GHC.Core.FamInstEnv; it's irrelevantfor ClsInstEnv and for type-family instances. +But we use RoughMaps for all cases, so we are conservative. + Note [Matching a RoughMap] ~~~~~~~~~~~~~~~~~~~~~~~~~~ The /lookup key/ into a rough map (RoughMatchLookupTc) is slightly @@ -135,6 +141,7 @@ doesn't match with any of the KnownTC instances so we can discard them all. For example: Show a[sk] or Show (a[sk] b[sk]). One place constraints like this arise is when typechecking derived instances. + 2. The head of the application is a known type family. For example: F a[sk]. The application of F is stuck, and because F is a type family it won't match any KnownTC instance so it's safe to discard @@ -149,7 +156,7 @@ The potential matches is likely to be much smaller than the bag of potential unifiers due to the reasoning about rigid type variables described in Note [Matching a RoughMap]. On the other hand, the instances captured by the RML_NoKnownTC case can still potentially unify -with any instance (depending on the substituion of said rigid variable) so they can't be discounted +with any instance (depending on the substitution of said rigid variable) so they can't be discounted from the list of potential unifiers. This is achieved by the RML_NoKnownTC case continuing the lookup for unifiers by replacing RML_NoKnownTC with RML_LookupOtherTC. @@ -180,7 +187,7 @@ mightMatch [] [] = True -- A perfectly sized match might match mightMatch key [] = True -- A shorter lookup key matches everything mightMatch [] (_:_) = True -- If the lookup key is longer, then still might match - -- Note [RoughMatch and beta reduction] + -- Note [RoughMap and beta reduction] mightMatch (k:ks) (lk:lks) = = case (k,lk) of -- Standard case, matching on a specific known TyCon. @@ -222,20 +229,59 @@ -} +{- ********************************************************************* +* * + Rough matching +* * +********************************************************************* -} + +{- Note [Rough matching in class and family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + instance C (Maybe [Tree a]) Bool +and suppose we are looking up + C Bool Bool + +We can very quickly rule the instance out, because the first +argument is headed by Maybe, whereas in the constraint we are looking +up has first argument headed by Bool. These "headed by" TyCons are +called the "rough match TyCons" of the constraint or instance. +They are used for a quick filter, to check when an instance cannot +possibly match. + +The main motivation is to avoid sucking in whole instance +declarations that are utterly useless. See GHC.Core.InstEnv +Note [ClsInst laziness and the rough-match fields]. + +INVARIANT: a rough-match TyCons `tc` is always a real, generative tycon, +like Maybe or Either, including a newtype or a data family, both of +which are generative. It replies True to `isGenerativeTyCon tc Nominal`. + +But it is never + - A type synonym + E.g. Int and (S Bool) might match + if (S Bool) is a synonym for Int + + - A type family (#19336) + E.g. (Just a) and (F a) might match if (F a) reduces to (Just a) + albeit perhaps only after 'a' is instantiated. +-} + + -- Key for insertion into a RoughMap data RoughMatchTc - = RM_KnownTc Name -- INVARIANT: Name refers to a TyCon tc that responds - -- true to `isGenerativeTyCon tc Nominal`. See - -- Note [Rough matching in class and family instances] - | RM_WildCard -- e.g. type variable at the head + = RM_KnownTc Name -- INVARIANT: Name refers to a TyCon tc that responds + -- true to `isGenerativeTyCon tc Nominal`. See + -- Note [Rough matching in class and family instances] + | RM_WildCard -- e.g. type variable at the head deriving( Data ) -- Key for lookup into a RoughMap -- See Note [Matching a RoughMap] data RoughMatchLookupTc = RML_KnownTc Name -- ^ The position only matches the specified KnownTc - | RML_NoKnownTc -- ^ The position definitely doesn't match any KnownTc - | RML_WildCard -- ^ The position can match anything + | RML_NoKnownTc -- ^ The position definitely doesn't match any KnownTc + | RML_WildCard -- ^ The position can match anything deriving ( Data ) instance Outputable RoughMatchLookupTc where @@ -243,31 +289,55 @@ ppr RML_NoKnownTc = text "RML_NoKnownTC" ppr RML_WildCard = text "_" -roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc -roughMatchTcToLookup (RM_KnownTc n) = RML_KnownTc n -roughMatchTcToLookup RM_WildCard = RML_WildCard - instance Outputable RoughMatchTc where ppr (RM_KnownTc nm) = text "KnownTc" <+> ppr nm ppr RM_WildCard = text "OtherTc" +instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool +-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot +-- possibly be instantiated to actual, nor vice versa; +-- False is non-committal +instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as +instanceCantMatch _ _ = False -- Safe + +itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool +itemCantMatch (RM_KnownTc t) (RM_KnownTc a) = t /= a +itemCantMatch _ _ = False + +roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc +roughMatchTcToLookup (RM_KnownTc n) = RML_KnownTc n +roughMatchTcToLookup RM_WildCard = RML_WildCard + isRoughWildcard :: RoughMatchTc -> Bool isRoughWildcard RM_WildCard = True isRoughWildcard (RM_KnownTc {}) = False +roughMatchTcs :: [Type] -> [RoughMatchTc] +roughMatchTcs tys = map typeToRoughMatchTc tys + +roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc] +roughMatchTcsLookup tys = map typeToRoughMatchLookupTc tys + typeToRoughMatchLookupTc :: Type -> RoughMatchLookupTc typeToRoughMatchLookupTc ty - | Just (ty', _) <- splitCastTy_maybe ty = typeToRoughMatchLookupTc ty' - | otherwise = - case splitAppTys ty of + -- Expand synonyms first, as explained in Note [Rough matching in class and family instances]. + -- Failing to do so led to #22985. + | Just ty' <- coreView ty + = typeToRoughMatchLookupTc ty' + | CastTy ty' _ <- ty + = typeToRoughMatchLookupTc ty' + | otherwise + = case splitAppTys ty of -- Case 1: Head of application is a type variable, does not match any KnownTc. (TyVarTy {}, _) -> RML_NoKnownTc + (TyConApp tc _, _) -- Case 2: Head of application is a known type constructor, hence KnownTc. - | not (isTypeFamilyTyCon tc) -> RML_KnownTc $! tyConName tc + | not (isTypeFamilyTyCon tc) -> RML_KnownTc $! roughMatchTyConName tc -- Case 3: Head is a type family so it's stuck and therefore doesn't match -- any KnownTc | isTypeFamilyTyCon tc -> RML_NoKnownTc + -- Fallthrough: Otherwise, anything might match this position _ -> RML_WildCard @@ -275,11 +345,23 @@ typeToRoughMatchTc ty | Just (ty', _) <- splitCastTy_maybe ty = typeToRoughMatchTc ty' | Just (tc,_) <- splitTyConApp_maybe ty - , not (isTypeFamilyTyCon tc) = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) - RM_KnownTc $! tyConName tc + , not (isTypeFamilyTyCon tc) = RM_KnownTc $! roughMatchTyConName tc -- See Note [Rough matching in class and family instances] | otherwise = RM_WildCard +roughMatchTyConName :: TyCon -> Name +roughMatchTyConName tc + | tc_name == cONSTRAINTTyConName + = tYPETyConName -- TYPE and CONSTRAINT are not apart, so they must use + -- the same rough-map key. We arbitrarily use TYPE. + -- See Note [Type and Constraint are not apart] + -- wrinkle (W1) in GHC.Builtin.Types.Prim + | otherwise + = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) tc_name + where + tc_name = tyConName tc + + -- | Trie of @[RoughMatchTc]@ -- -- *Examples* @@ -288,15 +370,21 @@ -- insert [OtherTc] 2 -- lookup [OtherTc] == [1,2] -- @ -data RoughMap a = RM { rm_empty :: Bag a - , rm_known :: DNameEnv (RoughMap a) - -- See Note [InstEnv determinism] in GHC.Core.InstEnv - , rm_unknown :: RoughMap a } - | RMEmpty -- an optimised (finite) form of emptyRM - -- invariant: Empty RoughMaps are always represented with RMEmpty +data RoughMap a + = RMEmpty -- An optimised (finite) form of emptyRM + -- Invariant: Empty RoughMaps are always represented with RMEmpty - deriving (Functor) + | RM { rm_empty :: Bag a + -- Keyed by an empty [RoughMapTc] + , rm_known :: DNameEnv (RoughMap a) + -- Keyed by (RM_KnownTc tc : rm_tcs) + -- DNameEnv: see Note [InstEnv determinism] in GHC.Core.InstEnv + + , rm_wild :: RoughMap a } + -- Keyed by (RM_WildCard : rm_tcs) + deriving (Functor) + instance Outputable a => Outputable (RoughMap a) where ppr (RM empty known unknown) = vcat [text "RM" @@ -315,7 +403,7 @@ -- | N.B. Returns a 'Bag' for matches, which allows us to avoid rebuilding all of the lists -- we find in 'rm_empty', which would otherwise be necessary due to '++' if we --- returned a list. We use a list for unifiers becuase the tail is computed lazily and +-- returned a list. We use a list for unifiers because the tail is computed lazily and -- we often only care about the first couple of potential unifiers. Constructing a -- bag forces the tail which performs much too much work. -- @@ -323,28 +411,37 @@ -- See Note [Matches vs Unifiers] lookupRM' :: [RoughMatchLookupTc] -> RoughMap a -> (Bag a -- Potential matches , [a]) -- Potential unifiers -lookupRM' _ RMEmpty = (emptyBag, []) --- See Note [Simple Matching Semantics] about why we return everything when the lookup --- key runs out. -lookupRM' [] rm = let m = elemsRM rm - in (listToBag m, m) +lookupRM' _ RMEmpty -- The RoughMap is empty + = (emptyBag, []) + +lookupRM' [] rm -- See Note [Simple Matching Semantics] about why + = (listToBag m, m) -- we return everything when the lookup key runs out + where + m = elemsRM rm + lookupRM' (RML_KnownTc tc : tcs) rm = - let (common_m, common_u) = lookupRM' tcs (rm_unknown rm) + let (common_m, common_u) = lookupRM' tcs (rm_wild rm) (m, u) = maybe (emptyBag, []) (lookupRM' tcs) (lookupDNameEnv (rm_known rm) tc) - in (rm_empty rm `unionBags` common_m `unionBags` m + in ( rm_empty rm `unionBags` common_m `unionBags` m , bagToList (rm_empty rm) ++ common_u ++ u) --- A RML_NoKnownTC does **not** match any KnownTC but can unify -lookupRM' (RML_NoKnownTc : tcs) rm = - let (u_m, _u_u) = lookupRM' tcs (rm_unknown rm) - in (rm_empty rm `unionBags` u_m -- Definitely don't match +-- A RML_NoKnownTC does **not** match any KnownTC but can unify +lookupRM' (RML_NoKnownTc : tcs) rm = + let (u_m, _u_u) = lookupRM' tcs (rm_wild rm) + in ( rm_empty rm `unionBags` u_m -- Definitely don't match , snd $ lookupRM' (RML_WildCard : tcs) rm) -- But could unify.. lookupRM' (RML_WildCard : tcs) rm = - let (m, u) = bimap unionManyBags concat (mapAndUnzip (lookupRM' tcs) (eltsDNameEnv $ rm_known rm)) - (u_m, u_u) = lookupRM' tcs (rm_unknown rm) - in (rm_empty rm `unionBags` u_m `unionBags` m - , bagToList (rm_empty rm) ++ u_u ++ u) +-- pprTrace "RM wild" (ppr tcs $$ ppr (eltsDNameEnv (rm_known rm))) $ + let (m, u) = foldDNameEnv add_one (emptyBag, []) (rm_known rm) + (u_m, u_u) = lookupRM' tcs (rm_wild rm) + in ( rm_empty rm `unionBags` u_m `unionBags` m + , bagToList (rm_empty rm) ++ u_u ++ u ) + where + add_one :: RoughMap a -> (Bag a, [a]) -> (Bag a, [a]) + add_one rm ~(m2, u2) = (m1 `unionBags` m2, u1 ++ u2) + where + (m1,u1) = lookupRM' tcs rm unionRM :: RoughMap a -> RoughMap a -> RoughMap a unionRM RMEmpty a = a @@ -352,7 +449,7 @@ unionRM a b = RM { rm_empty = rm_empty a `unionBags` rm_empty b , rm_known = plusDNameEnv_C unionRM (rm_known a) (rm_known b) - , rm_unknown = rm_unknown a `unionRM` rm_unknown b + , rm_wild = rm_wild a `unionRM` rm_wild b } @@ -360,17 +457,19 @@ insertRM k v RMEmpty = insertRM k v $ RM { rm_empty = emptyBag , rm_known = emptyDNameEnv - , rm_unknown = emptyRM } + , rm_wild = emptyRM } insertRM [] v rm@(RM {}) = -- See Note [Simple Matching Semantics] rm { rm_empty = v `consBag` rm_empty rm } + insertRM (RM_KnownTc k : ks) v rm@(RM {}) = rm { rm_known = alterDNameEnv f (rm_known rm) k } where f Nothing = Just $ (insertRM ks v emptyRM) f (Just m) = Just $ (insertRM ks v m) + insertRM (RM_WildCard : ks) v rm@(RM {}) = - rm { rm_unknown = insertRM ks v (rm_unknown rm) } + rm { rm_wild = insertRM ks v (rm_wild rm) } filterRM :: (a -> Bool) -> RoughMap a -> RoughMap a filterRM _ RMEmpty = RMEmpty @@ -378,7 +477,7 @@ normalise $ RM { rm_empty = filterBag pred (rm_empty rm), rm_known = mapDNameEnv (filterRM pred) (rm_known rm), - rm_unknown = filterRM pred (rm_unknown rm) + rm_wild = filterRM pred (rm_wild rm) } -- | Place a 'RoughMap' in normal form, turning all empty 'RM's into @@ -399,13 +498,13 @@ normalise $ RM { rm_empty = filterBag pred (rm_empty rm), rm_known = alterDNameEnv (join . fmap (dropEmpty . filterMatchingRM pred tcs)) (rm_known rm) tc, - rm_unknown = filterMatchingRM pred tcs (rm_unknown rm) + rm_wild = filterMatchingRM pred tcs (rm_wild rm) } filterMatchingRM pred (RM_WildCard : tcs) rm = normalise $ RM { rm_empty = filterBag pred (rm_empty rm), rm_known = mapDNameEnv (filterMatchingRM pred tcs) (rm_known rm), - rm_unknown = filterMatchingRM pred tcs (rm_unknown rm) + rm_wild = filterMatchingRM pred tcs (rm_wild rm) } dropEmpty :: RoughMap a -> Maybe (RoughMap a) @@ -421,7 +520,7 @@ -- N.B. local worker ensures that the loop can be specialised to the fold -- function. go z RMEmpty = z - go z (RM{ rm_unknown = unk, rm_known = known, rm_empty = empty}) = + go z (RM{ rm_wild = unk, rm_known = known, rm_empty = empty}) = foldr f (foldDNameEnv @@ -442,7 +541,7 @@ f (nonDetStrictFoldDNameEnv (flip go) - (go z (rm_unknown rm)) + (go z (rm_wild rm)) (rm_known rm) ) (rm_empty rm) diff --git a/GHC/Core/Rules.hs b/GHC/Core/Rules.hs --- a/GHC/Core/Rules.hs +++ b/GHC/Core/Rules.hs @@ -8,49 +8,60 @@ -- | Functions for collecting together and applying rewrite rules to a module. -- The 'CoreRule' datatype itself is declared elsewhere. module GHC.Core.Rules ( - -- ** Constructing + -- ** Looking up rules + lookupRule, + + -- ** RuleBase, RuleEnv + RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv, + updExternalPackageRules, addLocalRules, updLocalRules, emptyRuleBase, mkRuleBase, extendRuleBaseList, - pprRuleBase, extendRuleEnv, + pprRuleBase, -- ** Checking rule applications ruleCheckProgram, -- ** Manipulating 'RuleInfo' rules extendRuleInfo, addRuleInfo, - addIdSpecialisations, + addIdSpecialisations, addRulesToId, + -- ** RuleBase and RuleEnv + -- * Misc. CoreRule helpers rulesOfBinds, getRules, pprRulesForUser, - lookupRule, mkRule, roughTopNames, initRuleOpts + -- * Making rules + mkRule, mkSpecRule, roughTopNames + ) where import GHC.Prelude -import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ ) -import GHC.Driver.Flags - -import GHC.Unit.Types ( primUnitId, bignumUnitId ) import GHC.Unit.Module ( Module ) import GHC.Unit.Module.Env +import GHC.Unit.Module.ModGuts( ModGuts(..) ) +import GHC.Unit.Module.Deps( Dependencies(..) ) +import GHC.Driver.Session( 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, exprFreeVarsList ) + , rulesFreeVarsDSet, exprsOrphNames ) import GHC.Core.Utils ( exprType, mkTick, mkTicks , stripTicksTopT, stripTicksTopE , isJoinBind, mkCastMCo ) import GHC.Core.Ppr ( pprRules ) import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Core.Type as Type - ( Type, TCvSubst, extendTvSubst, extendCvSubst - , mkEmptyTCvSubst, substTy, getTyVar_maybe ) + ( Type, extendTvSubst, extendCvSubst + , substTy, getTyVar_maybe ) +import GHC.Core.TyCo.Ppr( pprParendType ) import GHC.Core.Coercion as Coercion import GHC.Core.Tidy ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr ) -import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) +import GHC.Core.Opt.Arity( etaExpandToJoinPointRule ) import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types ( anyTypeOfKind ) @@ -63,6 +74,7 @@ import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) import GHC.Types.Name.Set import GHC.Types.Name.Env +import GHC.Types.Name.Occurrence( occNameFS ) import GHC.Types.Unique.FM import GHC.Types.Tickish import GHC.Types.Basic @@ -72,7 +84,6 @@ import GHC.Data.Bag import GHC.Utils.Misc as Utils -import GHC.Utils.Trace import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) @@ -130,7 +141,7 @@ * At the moment (c) is carried in a reader-monad way by the GHC.Core.Opt.Monad. The HomePackageTable doesn't have a single RuleBase because technically we should only be able to "see" rules "below" this module; so we - generate a RuleBase for (c) by combing rules from all the modules + generate a RuleBase for (c) by combining rules from all the modules "below" us. That's why we can't just select the home-package RuleBase from HscEnv. @@ -147,7 +158,7 @@ In a single simplifier run new rules can be added into the EPS so it matters to keep an up-to-date view of which rules have been loaded. For examples of - where this went wrong and caused cryptic performance regressions seee + where this went wrong and caused cryptic performance regressions see T19790 and !6735. @@ -157,33 +168,18 @@ * * ************************************************************************ -A @CoreRule@ holds details of one rule for an @Id@, which +A CoreRule holds details of one rule for an Id, which includes its specialisations. -For example, if a rule for @f@ contains the mapping: -\begin{verbatim} - forall a b d. [Type (List a), Type b, Var d] ===> f' a b -\end{verbatim} +For example, if a rule for f is + RULE "f" forall @a @b d. f @(List a) @b d = f' a b + then when we find an application of f to matching types, we simply replace it by the matching RHS: -\begin{verbatim} f (List Int) Bool dict ===> f' Int Bool -\end{verbatim} All the stuff about how many dictionaries to discard, and what types to apply the specialised function to, are handled by the fact that the Rule contains a template for the result of the specialisation. - -There is one more exciting case, which is dealt with in exactly the same -way. If the specialised value is unboxed then it is lifted at its -definition site and unlifted at its uses. For example: - - pi :: forall a. Num a => a - -might have a specialisation - - [Int#] ===> (case pi' of Lift pi# -> pi#) - -where pi' :: Lift Int# is the specialised version of pi. -} mkRule :: Module -> Bool -> Bool -> RuleName -> Activation @@ -191,18 +187,13 @@ -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being -- compiled. See also 'GHC.Core.CoreRule' mkRule this_mod is_auto is_local name act fn bndrs args rhs - = Rule { ru_name = name - , ru_act = act - , ru_fn = fn - , ru_bndrs = bndrs - , ru_args = args - , ru_rhs = occurAnalyseExpr rhs - -- See Note [OccInfo in unfoldings and rules] - , ru_rough = roughTopNames args - , ru_origin = this_mod - , ru_orphan = orph - , ru_auto = is_auto - , ru_local = is_local } + = Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs, ru_args = args, + ru_rhs = rhs, + ru_rough = roughTopNames args, + ru_origin = this_mod, + ru_orphan = orph, + ru_auto = is_auto, ru_local = is_local } where -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv -- A rule is an orphan only if none of the variables @@ -217,6 +208,40 @@ orph = chooseOrphanAnchor local_lhs_names -------------- +mkSpecRule :: DynFlags -> Module -> Bool -> Activation -> SDoc + -> 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 + where + rule = mkRule this_mod is_auto is_local + rule_name + inl_act -- Note [Auto-specialisation and RULES] + (idName fn) + bndrs args rhs + + is_local = isLocalId fn + rule_name = mkSpecRuleName dflags herald fn args + +mkSpecRuleName :: DynFlags -> SDoc -> Id -> [CoreExpr] -> FastString +mkSpecRuleName dflags herald fn args + = mkFastString $ showSDoc dflags $ + herald <+> ftext (occNameFS (getOccName fn)) + -- This name ends up in interface files, so use occNameFS. + -- Otherwise uniques end up there, making builds + -- less deterministic (See #4012 comment:61 ff) + <+> hsep (mapMaybe ppr_call_key_ty args) + where + ppr_call_key_ty :: CoreExpr -> Maybe SDoc + ppr_call_key_ty (Type ty) = case getTyVar_maybe ty of + Just {} -> Just (text "@_") + Nothing -> Just $ char '@' <> pprParendType ty + ppr_call_key_ty _ = Nothing + + +-------------- roughTopNames :: [CoreExpr] -> [Maybe Name] -- ^ Find the \"top\" free names of several expressions. -- Such names are either: @@ -316,16 +341,118 @@ = setIdSpecialisation id $ extendRuleInfo (idSpecialisation id) rules +addRulesToId :: RuleBase -> Id -> Id +-- Add rules in the RuleBase to the rules in the Id +addRulesToId rule_base bndr + | Just rules <- lookupNameEnv rule_base (idName bndr) + = bndr `addIdSpecialisations` rules + | otherwise + = bndr + -- | Gather all the rules for locally bound identifiers from the supplied bindings rulesOfBinds :: [CoreBind] -> [CoreRule] rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds + +{- +************************************************************************ +* * + RuleBase +* * +************************************************************************ +-} + +-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules +type RuleBase = NameEnv [CoreRule] + -- The rules are unordered; + -- we sort out any overlaps on lookup + +emptyRuleBase :: RuleBase +emptyRuleBase = emptyNameEnv + +mkRuleBase :: [CoreRule] -> RuleBase +mkRuleBase rules = extendRuleBaseList emptyRuleBase rules + +extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldl' extendRuleBase rule_base new_guys + +extendRuleBase :: RuleBase -> CoreRule -> RuleBase +extendRuleBase rule_base rule + = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule + +pprRuleBase :: RuleBase -> SDoc +pprRuleBase rules = pprUFM rules $ \rss -> + vcat [ pprRules (tidyRules emptyTidyEnv rs) + | rs <- rss ] + +-- | A full rule environment which we can apply rules from. Like a 'RuleBase', +-- but it also includes the set of visible orphans we use to filter out orphan +-- rules which are not visible (even though we can see them...) +-- See Note [Orphans] in GHC.Core +data RuleEnv + = RuleEnv { re_local_rules :: !RuleBase -- Rules from this module + , re_home_rules :: !RuleBase -- Rule from the home package + -- (excl this module) + , re_eps_rules :: !RuleBase -- Rules from other packages + -- see Note [External package rules] + , re_visible_orphs :: !ModuleSet + } + +mkRuleEnv :: ModGuts -> RuleBase -> RuleBase -> RuleEnv +mkRuleEnv (ModGuts { mg_module = this_mod + , mg_deps = deps + , mg_rules = local_rules }) + eps_rules hpt_rules + = RuleEnv { re_local_rules = mkRuleBase local_rules + , re_home_rules = hpt_rules + , re_eps_rules = eps_rules + , re_visible_orphs = mkModuleSet vis_orphs } + where + vis_orphs = this_mod : dep_orphs deps + +updExternalPackageRules :: RuleEnv -> RuleBase -> RuleEnv +-- Completely over-ride the external rules in RuleEnv +updExternalPackageRules rule_env eps_rules + = rule_env { re_eps_rules = eps_rules } + +updLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv +-- Completely over-ride the local rules in RuleEnv +updLocalRules rule_env local_rules + = rule_env { re_local_rules = mkRuleBase local_rules } + +addLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv +-- Add new local rules +addLocalRules rule_env rules + = rule_env { re_local_rules = extendRuleBaseList (re_local_rules rule_env) rules } + +emptyRuleEnv :: RuleEnv +emptyRuleEnv = RuleEnv { re_local_rules = emptyNameEnv + , re_home_rules = emptyNameEnv + , re_eps_rules = emptyNameEnv + , re_visible_orphs = emptyModuleSet } + 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_base = rule_base, re_visible_orphs = orphs }) fn - = idCoreRules fn ++ concatMap imp_rules rule_base +getRules (RuleEnv { re_local_rules = local_rules + , re_home_rules = home_rules + , re_eps_rules = eps_rules + , 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 + where - imp_rules rb = filter (ruleIsVisible orphs) (lookupNameEnv rb (idName fn) `orElse` []) + fn_name = idName fn + find_visible rb = filter (ruleIsVisible orphs) (get rb) + get rb = lookupNameEnv rb fn_name `orElse` [] ruleIsVisible :: ModuleSet -> CoreRule -> Bool ruleIsVisible _ BuiltinRule{} = True @@ -351,37 +478,28 @@ in the module defining the Id (when it's a LocalId), but the rules are kept in the global RuleBase - -************************************************************************ -* * - RuleBase -* * -************************************************************************ --} - --- RuleBase itself is defined in GHC.Core, along with CoreRule - -emptyRuleBase :: RuleBase -emptyRuleBase = emptyNameEnv + Note [External package rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Note [Overall plumbing for rules], it is explained that the final +RuleBase which we must consider is combined from 4 different sources. -mkRuleBase :: [CoreRule] -> RuleBase -mkRuleBase rules = extendRuleBaseList emptyRuleBase rules +During simplifier runs, the fourth source of rules is constantly being updated +as new interfaces are loaded into the EPS. Therefore just before we check to see +if any rules match we get the EPS RuleBase and combine it with the existing RuleBase +and then perform exactly 1 lookup into the new map. -extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase -extendRuleBaseList rule_base new_guys - = foldl' extendRuleBase rule_base new_guys +It is more efficient to avoid combining the environments and store the uncombined +environments as we can instead perform 1 lookup into each environment and then combine +the results. -extendRuleBase :: RuleBase -> CoreRule -> RuleBase -extendRuleBase rule_base rule - = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule +Essentially we use the identity: -extendRuleEnv :: RuleEnv -> RuleBase -> RuleEnv -extendRuleEnv (RuleEnv rules orphs) rb = (RuleEnv (rb:rules) orphs) +> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2) +> = lookupNameEnv n rb1 ++ lookupNameEnv n rb2 -pprRuleBase :: RuleBase -> SDoc -pprRuleBase rules = pprUFM rules $ \rss -> - vcat [ pprRules (tidyRules emptyTidyEnv rs) - | rs <- rss ] +The latter being more efficient as we don't construct an intermediate +map. +-} {- ************************************************************************ @@ -404,7 +522,7 @@ -- See Note [Extra args in the target] -- See comments on matchRule -lookupRule opts rule_env@(in_scope,_) is_active fn args rules +lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules = -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $ case go [] rules of [] -> Nothing @@ -456,31 +574,42 @@ (fn,args) = target isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool --- This tests if one rule is more specific than another --- We take the view that a BuiltinRule is less specific than --- anything else, because we want user-define rules to "win" --- In particular, class ops have a built-in rule, but we --- any user-specific rules to win --- eg (#4397) --- truncate :: (RealFrac a, Integral b) => a -> b --- {-# RULES "truncate/Double->Int" truncate = double2Int #-} --- double2Int :: Double -> Int --- We want the specific RULE to beat the built-in class-op rule +-- The call (rule1 `isMoreSpecific` 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 (full_in_scope, id_unfolding_fun) + = isJust (matchN in_scope_env rule_name2 bndrs2 args2 args1 rhs2) where - id_unfolding_fun _ = NoUnfolding -- Don't expand in templates full_in_scope = in_scope `extendInScopeSetList` bndrs1 + in_scope_env = ISE full_in_scope noUnfoldingFun + -- noUnfoldingFun: don't expand in templates noBlackList :: Activation -> Bool noBlackList _ = False -- Nothing is black listed -{- Note [Extra args in the target] +{- Note [isMoreSpecific] +~~~~~~~~~~~~~~~~~~~~~~~~ +The call (rule1 `isMoreSpecific` rule2) +sees if rule2 can be instantiated to look like rule1. + +Wrinkle: + +* We take the view that a BuiltinRule is less specific than + anything else, because we want user-defined rules to "win" + In particular, class ops have a built-in rule, but we + prefer any user-specific rules to win: + eg (#4397) + truncate :: (RealFrac a, Integral b) => a -> b + {-# RULES "truncate/Double->Int" truncate = double2Int #-} + double2Int :: Double -> Int + We want the specific RULE to beat the built-in class-op rule + +Note [Extra args in the target] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we find a matching rule, we return (Just (rule, rhs)), /but/ the rule firing has only consumed as many of the input args @@ -528,11 +657,14 @@ -- [f,map g x] -- tpl_args -- map (f.g) x) -- rhs -- --- Then the call: matchRule the_rule [e1,map e2 e3] +-- Then the expression +-- map e1 (map e2 e3) e4 +-- results in a call to +-- matchRule the_rule [e1,map e2 e3,e4] -- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) -- --- Any 'surplus' arguments in the input are simply put on the end --- of the output. +-- NB: The 'surplus' argument e4 in the input is simply dropped. +-- See Note [Extra args in the target] matchRule opts rule_env _is_active fn args _rough_args (BuiltinRule { ru_try = match_fn }) @@ -549,18 +681,6 @@ | otherwise = matchN rule_env rule_name tpl_vars tpl_args args rhs --- | 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 - } - - --------------------------------------- matchN :: InScopeEnv -> RuleName -> [Var] -> [CoreExpr] @@ -576,10 +696,10 @@ -- trailing ones, returning the result of applying the rule to a prefix -- of the actual arguments. -matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs +matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) - (mkEmptyTCvSubst in_scope) $ + (mkEmptySubst in_scope) $ tmpl_vars `zip` tmpl_vars1 bind_wrapper = rs_binds rule_subst -- Floated bindings; see Note [Matching lets] @@ -594,7 +714,7 @@ , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) , rv_unf = id_unf } - lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr) + lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr) -- Need to return a RuleSubst solely for the benefit of mk_fake_ty lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tcv_subst (tmpl_var, tmpl_var1) @@ -629,7 +749,28 @@ , text "LHS args:" <+> ppr tmpl_es , text "Actual args:" <+> ppr target_es ] +---------------------- +match_exprs :: RuleMatchEnv -> RuleSubst + -> [CoreExpr] -- Templates + -> [CoreExpr] -- Targets + -> Maybe RuleSubst +-- If the targets are longer than templates, succeed, simply ignoring +-- the leftover targets. This matters in the call in matchN. +-- +-- Precondition: corresponding elements of es1 and es2 have the same +-- type, assuming earlier elements match. +-- Example: f :: forall v. v -> blah +-- match_exprs [Type a, y::a] [Type Int, 3] +-- Then, after matching Type a against Type Int, +-- the type of (y::a) matches that of (3::Int) +match_exprs _ subst [] _ + = Just subst +match_exprs renv subst (e1:es1) (e2:es2) + = do { subst' <- match renv subst e1 e2 MRefl + ; match_exprs renv subst' es1 es2 } +match_exprs _ _ _ _ = Nothing + {- Note [Unbound RULE binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It can be the case that the binder in a rule is not actually @@ -740,7 +881,7 @@ -} rvInScopeEnv :: RuleMatchEnv -> InScopeEnv -rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) +rvInScopeEnv renv = ISE (rnInScopeSet (rv_lcl renv)) (rv_unf renv) -- * The domain of the TvSubstEnv and IdSubstEnv are the template -- variables passed into the match. @@ -762,28 +903,7 @@ emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv , rs_binds = \e -> e, rs_bndrs = [] } ----------------------- -match_exprs :: RuleMatchEnv -> RuleSubst - -> [CoreExpr] -- Templates - -> [CoreExpr] -- Targets - -> Maybe RuleSubst --- If the targets are longer than templates, succeed, simply ignoring --- the leftover targets. This matters in the call in matchN. --- --- Precondition: corresponding elements of es1 and es2 have the same --- type, assumuing earlier elements match --- Example: f :: forall v. v -> blah --- match_exprs [Type a, y::a] [Type Int, 3] --- Then, after matching Type a against Type Int, --- the type of (y::a) matches that of (3::Int) -match_exprs _ subst [] _ - = Just subst -match_exprs renv subst (e1:es1) (e2:es2) - = do { subst' <- match renv subst e1 e2 MRefl - ; match_exprs renv subst' es1 es2 } -match_exprs _ _ _ _ = Nothing - {- Note [Casts in the target] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As far as possible we don't want casts in the target to get in the way of @@ -950,7 +1070,7 @@ -- 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' --- we agressively ensure that if MCo is reflective, it really is MRefl. +-- we aggressively ensure that if MCo is reflective, it really is MRefl. match renv subst (App f1 a1) (App f2 a2) MRefl = do { subst' <- match renv subst f1 f2 MRefl ; match renv subst' a1 a2 MRefl } @@ -1129,7 +1249,7 @@ and we really want to spot that the co/sym-co cancels out. Hence * We keep an invariant that the MCoercion is always MRefl - if the MCoercion is reflextve + if the MCoercion is reflexive * We maintain this invariant via the call to checkReflexiveMCo in the Cast case of 'match'. -} @@ -1242,7 +1362,9 @@ match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) v1' e2 - | any (inRnEnvR rn_env) (exprFreeVarsList e2) + -- anyInRnEnvR is lazy in the 2nd arg which allows us to avoid computing fvs + -- 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) @@ -1553,7 +1675,7 @@ | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) where name_match_rules = filter match (rc_rules env fn) - match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) + match rule = rc_pattern env `isPrefixOf` unpackFS (ruleName rule) ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc ruleAppCheck_help env fn args rules @@ -1573,7 +1695,7 @@ = text "Rule" <+> doubleQuotes (ftext name) rule_info opts rule - | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env) + | Just _ <- matchRule opts (ISE emptyInScopeSet (rc_id_unf env)) noBlackList fn args rough_args rule = text "matches (which is very peculiar!)" diff --git a/GHC/Core/Rules/Config.hs b/GHC/Core/Rules/Config.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/Rules/Config.hs @@ -0,0 +1,13 @@ +module GHC.Core.Rules.Config where + +import GHC.Prelude +import GHC.Platform + +-- | 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 + } + diff --git a/GHC/Core/SimpleOpt.hs b/GHC/Core/SimpleOpt.hs --- a/GHC/Core/SimpleOpt.hs +++ b/GHC/Core/SimpleOpt.hs @@ -27,7 +27,7 @@ import GHC.Core.FVs import GHC.Core.Unfold import GHC.Core.Unfold.Make -import GHC.Core.Make ( FloatBind(..) ) +import GHC.Core.Make ( FloatBind(..), mkWildValBinder ) import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs ) import GHC.Types.Literal import GHC.Types.Id @@ -36,7 +36,7 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Core.DataCon -import GHC.Types.Demand( etaConvertDmdSig ) +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 @@ -91,14 +91,15 @@ data SimpleOpts = SimpleOpts { so_uf_opts :: !UnfoldingOpts -- ^ Unfolding options , so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options + , so_eta_red :: !Bool -- ^ Eta reduction on? } -- | Default options for the Simple optimiser. defaultSimpleOpts :: SimpleOpts defaultSimpleOpts = SimpleOpts { so_uf_opts = defaultUnfoldingOpts - , so_co_opts = OptCoercionOpts - { optCoercionEnabled = False } + , so_co_opts = OptCoercionOpts { optCoercionEnabled = False } + , so_eta_red = False } simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr @@ -181,13 +182,10 @@ type SimpleClo = (SimpleOptEnv, InExpr) data SimpleOptEnv - = SOE { soe_co_opt_opts :: !OptCoercionOpts - -- ^ Options for the coercion optimiser - - , soe_uf_opts :: !UnfoldingOpts - -- ^ Unfolding options + = SOE { soe_opts :: {-# UNPACK #-} !SimpleOpts + -- ^ Simplifier options - , soe_inl :: IdEnv SimpleClo + , soe_inl :: IdEnv SimpleClo -- ^ Deals with preInlineUnconditionally; things -- that occur exactly once and are inlined -- without having first been simplified @@ -207,24 +205,22 @@ <+> text "}" emptyEnv :: SimpleOpts -> SimpleOptEnv -emptyEnv opts = SOE - { soe_inl = emptyVarEnv - , soe_subst = emptySubst - , soe_rec_ids = emptyUnVarSet - , soe_co_opt_opts = so_co_opts opts - , soe_uf_opts = so_uf_opts opts - } +emptyEnv opts = SOE { soe_inl = emptyVarEnv + , soe_subst = emptySubst + , soe_rec_ids = emptyUnVarSet + , soe_opts = opts } soeZapSubst :: SimpleOptEnv -> SimpleOptEnv soeZapSubst env@(SOE { soe_subst = subst }) - = env { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst } + = env { soe_inl = emptyVarEnv, soe_subst = zapSubst subst } -soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv --- Take in-scope set from env1, and the rest from env2 -soeSetInScope (SOE { soe_subst = subst1 }) - env2@(SOE { soe_subst = subst2 }) - = env2 { soe_subst = setInScope subst2 (substInScope subst1) } +soeInScope :: SimpleOptEnv -> InScopeSet +soeInScope (SOE { soe_subst = subst }) = getSubstInScope subst +soeSetInScope :: InScopeSet -> SimpleOptEnv -> SimpleOptEnv +soeSetInScope in_scope env2@(SOE { soe_subst = subst2 }) + = env2 { soe_subst = setInScope subst2 in_scope } + enterRecGroupRHSs :: SimpleOptEnv -> [OutBndr] -> (SimpleOptEnv -> (SimpleOptEnv, r)) -> (SimpleOptEnv, r) enterRecGroupRHSs env bndrs k @@ -233,9 +229,11 @@ (env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)} --------------- -simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr -simple_opt_clo env (e_env, e) - = simple_opt_expr (soeSetInScope env e_env) e +simple_opt_clo :: 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 env expr @@ -243,18 +241,18 @@ where rec_ids = soe_rec_ids env subst = soe_subst env - in_scope = substInScope subst - in_scope_env = (in_scope, simpleUnfoldingFun) + in_scope = getSubstInScope subst + in_scope_env = ISE in_scope alwaysActiveUnfoldingFun --------------- go (Var v) | Just clo <- lookupVarEnv (soe_inl env) v - = simple_opt_clo env clo + = simple_opt_clo in_scope clo | otherwise = lookupIdSubst (soe_subst env) v go (App e1 e2) = simple_app env e1 [(env,e2)] - go (Type ty) = Type (substTy subst ty) + go (Type ty) = Type (substTyUnchecked subst ty) go (Coercion co) = Coercion (go_co co) go (Lit lit) = Lit lit go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) @@ -277,7 +275,7 @@ (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $ zipEqual "simpleOptExpr" bs es - -- Note [Getting the map/coerce RULE to work] + -- See Note [Getting the map/coerce RULE to work] | isDeadBinder b , [Alt DEFAULT _ rhs] <- as , isCoVarType (varType b) @@ -287,14 +285,14 @@ = go rhs | otherwise - = Case e' b' (substTy subst ty) + = Case e' b' (substTyUnchecked subst ty) (map (go_alt env') as) where e' = go e (env', b') = subst_opt_bndr env b ---------------------- - go_co co = optCoercion (soe_co_opt_opts env) (getTCvSubst subst) co + go_co co = optCoercion (so_co_opts (soe_opts env)) subst co ---------------------- go_alt env (Alt con bndrs rhs) @@ -312,8 +310,9 @@ where (env', b') = subst_opt_bndr env b go_lam env bs' e - | Just etad_e <- tryEtaReduce rec_ids bs e' = etad_e - | otherwise = mkLams bs e' + | so_eta_red (soe_opts env) + , Just etad_e <- tryEtaReduce rec_ids bs e' topSubDmd = etad_e + | otherwise = mkLams bs e' where bs = reverse bs' e' = simple_opt_expr env e @@ -333,12 +332,12 @@ simple_app env (Var v) as | Just (env', e) <- lookupVarEnv (soe_inl env) v - = simple_app (soeSetInScope env env') e as + = simple_app (soeSetInScope (soeInScope env) env') e as | let unf = idUnfolding v , isCompulsoryUnfolding (idUnfolding v) , isAlwaysActive (idInlineActivation v) - -- See Note [Unfold compulsory unfoldings in LHSs] + -- See Note [Unfold compulsory unfoldings in RULE LHSs] = simple_app (soeZapSubst env) (unfoldingTemplate unf) as | otherwise @@ -360,8 +359,19 @@ n_args = length as do_beta env (Lam b body) (a:as) - | (env', mb_pr) <- simple_bind_pair env b Nothing a NotTopLevel - = wrapLet mb_pr $ do_beta env' body as + | -- simpl binder before looking at its type + -- See Note [Dark corner with representation polymorphism] + needsCaseBinding (idType b') (snd a) + -- This arg must not be inlined (side-effects) and cannot be let-bound, + -- due to the let-can-float invariant. So simply case-bind it here. + , let a' = simple_opt_clo (soeInScope env) a + = mkDefaultCase a' b' $ do_beta env' body as + + | (env'', mb_pr) <- simple_bind_pair env' b (Just b') a NotTopLevel + = wrapLet mb_pr $ do_beta env'' body as + + where (env', b') = subst_opt_bndr env b + do_beta env body as = simple_app env body as @@ -390,11 +400,19 @@ = finish_app env (simple_opt_expr env e) as finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr -finish_app _ fun [] - = fun -finish_app env fun (arg:args) - = finish_app env (App fun (simple_opt_clo env arg)) args +-- See Note [Eliminate casts in function position] +finish_app env (Cast (Lam x e) co) as@(_:_) + | not (isTyVar x) && not (isCoVar x) + , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True + , Just (x',e') <- pushCoercionIntoLambda (soeInScope env) x e co + = simple_app (soeZapSubst env) (Lam x' e') as +finish_app env fun args + = foldl mk_app fun args + where + in_scope = soeInScope env + mk_app fun arg = App fun (simple_opt_clo in_scope arg) + ---------------------- simple_opt_bind :: SimpleOptEnv -> InBind -> TopLevelFlag -> (SimpleOptEnv, Maybe OutBind) @@ -434,12 +452,12 @@ in_bndr mb_out_bndr clo@(rhs_env, in_rhs) top_level | Type ty <- in_rhs -- let a::* = TYPE ty in - , let out_ty = substTy (soe_subst rhs_env) ty + , let out_ty = substTyUnchecked (soe_subst rhs_env) ty = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr in_rhs) $ (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) | Coercion co <- in_rhs - , let out_co = optCoercion (soe_co_opt_opts env) (getTCvSubst (soe_subst rhs_env)) co + , let out_co = optCoercion (so_co_opts (soe_opts env)) (soe_subst rhs_env) co = assert (isCoVar in_bndr) (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) @@ -456,16 +474,17 @@ stable_unf = isStableUnfolding (idUnfolding in_bndr) active = isAlwaysActive (idInlineActivation in_bndr) occ = idOccInfo in_bndr + in_scope = getSubstInScope subst out_rhs | Just join_arity <- isJoinId_maybe in_bndr = simple_join_rhs join_arity | otherwise - = simple_opt_clo env clo + = simple_opt_clo in_scope clo simple_join_rhs join_arity -- See Note [Preserve join-binding arity] = mkLams join_bndrs' (simple_opt_expr env_body join_body) where - env0 = soeSetInScope env rhs_env + env0 = soeSetInScope in_scope rhs_env (join_bndrs, join_body) = collectNBinders join_arity in_rhs (env_body, join_bndrs') = subst_opt_bndrs env0 join_bndrs @@ -561,6 +580,53 @@ and increase the benefit for doing so. So we unconditionally inline trivial rhss here. +Note [Eliminate casts in function position] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following program: + + type R :: Type -> RuntimeRep + type family R a where { R Float = FloatRep; R Double = DoubleRep } + type F :: forall (a :: Type) -> TYPE (R a) + type family F a where { F Float = Float# ; F Double = Double# } + + type N :: forall (a :: Type) -> TYPE (R a) + newtype N a = MkN (F a) + +As MkN is a newtype, its unfolding is a lambda which wraps its argument +in a cast: + + MkN :: forall (a :: Type). F a -> N a + MkN = /\a \(x::F a). x |> co_ax + -- recall that F a :: TYPE (R a) + +This is a representation-polymorphic lambda, in which the binder has an unknown +representation (R a). We can't compile such a lambda on its own, but we can +compile instantiations, such as `MkN @Float` or `MkN @Double`. + +Our strategy to avoid running afoul of the representation-polymorphism +invariants of Note [Representation polymorphism invariants] in GHC.Core is thus: + + 1. Give the newtype a compulsory unfolding (it has no binding, as we can't + define lambdas with representation-polymorphic value binders in source Haskell). + 2. Rely on the optimiser to beta-reduce away any representation-polymorphic + value binders. + +For example, consider the application + + MkN @Float 34.0# + +After inlining MkN we'll get + + ((/\a \(x:F a). x |> co_ax) @Float) |> co 34# + +where co :: (F Float -> N Float) ~ (Float# ~ N Float) + +But to actually beta-reduce that lambda, we need to push the 'co' +inside the `\x` with pushCoecionIntoLambda. Hence the extra +equation for Cast-of-Lam in finish_app. + +This is regrettably delicate. + Note [Preserve join-binding arity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Be careful /not/ to eta-reduce the RHS of a join point, lest we lose @@ -646,7 +712,7 @@ Subst in_scope id_subst tv_subst cv_subst = subst id1 = uniqAway in_scope old_id - id2 = updateIdTypeAndMult (substTy subst) id1 + id2 = updateIdTypeAndMult (substTyUnchecked subst) id1 new_id = zapFragileIdInfo id2 -- Zaps rules, unfolding, and fragile OccInfo -- The unfolding and rules will get added back later, by add_info @@ -671,7 +737,7 @@ | otherwise = lazySetIdInfo new_bndr new_info where subst = soe_subst env - uf_opts = soe_uf_opts env + uf_opts = so_uf_opts (soe_opts env) old_info = idInfo old_bndr -- Add back in the rules and unfolding which were @@ -690,16 +756,11 @@ | otherwise = unfolding_from_rhs - unfolding_from_rhs = mkUnfolding uf_opts InlineRhs + unfolding_from_rhs = mkUnfolding uf_opts VanillaSrc (isTopLevel top_level) False -- may be bottom or not new_rhs Nothing -simpleUnfoldingFun :: IdUnfoldingFun -simpleUnfoldingFun id - | isAlwaysActive (idInlineActivation id) = idUnfolding id - | otherwise = noUnfolding - wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr wrapLet Nothing body = body wrapLet (Just (b,r)) body = Let (NonRec b r) body @@ -724,8 +785,8 @@ When inlining 'foo' in 'bar' we want the let-binding for 'inner' to remain visible until Phase 1 -Note [Unfold compulsory unfoldings in LHSs] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Unfold compulsory unfoldings in RULE LHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When the user writes `RULES map coerce = coerce` as a rule, the rule will only ever match if simpleOptExpr replaces coerce by its unfolding on the LHS, because that is the core that the rule matching engine @@ -1006,7 +1067,7 @@ case $WMkT (I# 3) |> sym axT of I# y -> ... we clearly want to simplify this. If $WMkT did not have a compulsory unfolding, we would end up with - let a = I#3 in case a of I# y -> ... + let a = I# 3 in case a of I# y -> ... because in general, we do this on-the-fly beta-reduction (\x. e) blah --> let x = blah in e and then float the let. (Substitution would risk duplicating 'blah'.) @@ -1118,7 +1179,7 @@ exprIsConApp_maybe :: HasDebugCallStack => InScopeEnv -> CoreExpr -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) -exprIsConApp_maybe (in_scope, id_unf) expr +exprIsConApp_maybe ise@(ISE in_scope id_unf) expr = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr))) where go :: Either InScopeSet Subst @@ -1140,6 +1201,30 @@ MRefl -> go subst floats expr (CC args' co2) go subst floats (App fun arg) (CC args co) + | 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 + -- put into the args, as these are going to be substituted into the case + -- alternatives, and possibly lost on the way. + -- + -- Instead, we need need to + -- make sure they are evaluated right here (using a case float), and + -- the case binder can then be substituted into the case alternaties. + -- + -- Example: + -- Simplifying case Mk# exp of Mk# a → rhs + -- will use exprIsConApp_maybe (Mk# exp) + -- + -- Bad: returning (Mk#, [exp]) with no floats + -- 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) + | otherwise = go subst floats fun (CC (subst_expr subst arg : args) co) go subst floats (Lam bndr body) (CC (arg:args) co) @@ -1168,7 +1253,7 @@ go subst'' (float:floats) expr cont go (Right sub) floats (Var v) cont - = go (Left (substInScope sub)) + = go (Left (getSubstInScope sub)) floats (lookupIdSubst sub v) cont @@ -1214,7 +1299,7 @@ | (fun `hasKey` unpackCStringIdKey) || (fun `hasKey` unpackCStringUtf8IdKey) , [arg] <- args - , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg + , Just (LitString str) <- exprIsLiteral_maybe ise arg = succeedWith in_scope floats $ dealWithStringLiteral fun str co where @@ -1238,6 +1323,13 @@ ---------------------------- -- Operations on the (Either InScopeSet GHC.Core.Subst) -- The Left case is wildly dominant + + subst_in_scope (Left in_scope) = in_scope + subst_in_scope (Right s) = getSubstInScope 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) + subst_co (Left {}) co = co subst_co (Right s) co = GHC.Core.Subst.substCo s co @@ -1303,7 +1395,7 @@ -- Nevertheless we do need to look through unfoldings for -- string literals, which are vigorously hoisted to top level -- and not subsequently inlined -exprIsLiteral_maybe env@(_, id_unf) e +exprIsLiteral_maybe env@(ISE _ id_unf) e = case e of Lit l -> Just l Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? @@ -1333,14 +1425,14 @@ = Just (x, e, []) -- Still straightforward: Ticks that we can float out of the way -exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e) +exprIsLambda_maybe ise (Tick t e) | tickishFloatable t - , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e + , Just (x, e, ts) <- exprIsLambda_maybe ise e = Just (x, e, t:ts) -- Also possible: A casted lambda. Push the coercion inside -exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) - | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e +exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co) + | Just (x, e,ts) <- exprIsLambda_maybe ise casted_e -- Only do value lambdas. -- this implies that x is not in scope in gamma (makes this code simpler) , not (isTyVar x) && not (isCoVar x) @@ -1351,7 +1443,7 @@ res -- Another attempt: See if we find a partial unfolding -exprIsLambda_maybe (in_scope_set, id_unf) e +exprIsLambda_maybe ise@(ISE in_scope_set id_unf) e | (Var f, as, ts) <- collectArgsTicks tickishFloatable e , idArity f > count isValArg as -- Make sure there is hope to get a lambda @@ -1359,7 +1451,7 @@ -- Optimize, for beta-reduction , let e' = simpleOptExprWith defaultSimpleOpts (mkEmptySubst in_scope_set) (rhs `mkApps` as) -- Recurse, because of possible casts - , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e' + , Just (x', e'', ts') <- exprIsLambda_maybe ise e' , let res = Just (x', e'', ts++ts') = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) res diff --git a/GHC/Core/Subst.hs b/GHC/Core/Subst.hs --- a/GHC/Core/Subst.hs +++ b/GHC/Core/Subst.hs @@ -6,8 +6,6 @@ Utility functions on @Core@ syntax -} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Subst ( -- * Main data types Subst(..), -- Implementation exported for supercompiler's Renaming.hs only @@ -15,18 +13,20 @@ -- ** Substituting into expressions and related types deShadowBinds, substRuleInfo, substRulesForImportedIds, - substTy, substCo, substExpr, substExprSC, substBind, substBindSC, + substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, - lookupIdSubst, substIdType, substIdOcc, + lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc, substTickish, substDVarSet, substIdInfo, -- ** Operations on substitutions - emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, + emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, isEmptySubst, extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, - extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, + extendIdSubstWithClone, + extendSubst, extendSubstList, extendSubstWithVar, extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, - isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst, - delBndr, delBndrs, + isInScope, setInScope, getSubstInScope, + extendTvSubst, extendCvSubst, + delBndr, delBndrs, zapSubst, -- ** Substituting and cloning binders substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr, @@ -40,14 +40,11 @@ import GHC.Core.FVs import GHC.Core.Seq import GHC.Core.Utils -import qualified GHC.Core.Type as Type -import qualified GHC.Core.Coercion as Coercion -- We are defining local versions -import GHC.Core.Type hiding - ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList - , isInScope, substTyVarBndr, cloneTyVarBndr ) -import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) +import GHC.Core.Type hiding ( substTy ) +import GHC.Core.Coercion + ( tyCoFVsOfCo, mkCoVarCo, substCoVarBndr ) import GHC.Types.Var.Set import GHC.Types.Var.Env as InScopeSet @@ -66,10 +63,9 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import Data.Functor.Identity (Identity (..)) import Data.List (mapAccumL) - - {- ************************************************************************ * * @@ -78,37 +74,12 @@ ************************************************************************ -} --- | A substitution environment, containing 'Id', 'TyVar', and 'CoVar' --- substitutions. --- --- Some invariants apply to how you use the substitution: --- --- 1. Note [The substitution invariant] in "GHC.Core.TyCo.Subst" --- --- 2. Note [Substitutions apply only once] in "GHC.Core.TyCo.Subst" -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 - - -- INVARIANT 1: See TyCoSubst Note [The substitution invariant] - -- This is what lets us deal with name capture properly - -- It's a hard invariant to check... - -- - -- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with - -- Types.TvSubstEnv - -- - -- INVARIANT 3: See Note [Extending the Subst] - {- -Note [Extending the Subst] +Note [Extending the IdSubstEnv] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -For a core Subst, which binds Ids as well, we make a different choice for Ids -than we do for TyVars. +We make a different choice for Ids than we do for TyVars. -For TyVars, see Note [Extending the TCvSubst] in GHC.Core.TyCo.Subst. +For TyVars, see Note [Extending the TvSubstEnv and CvSubstEnv] in GHC.Core.TyCo.Subst. For Ids, we have a different invariant The IdSubstEnv is extended *only* when the Unique on an Id changes @@ -158,31 +129,13 @@ easy to spot -} --- | An environment for substituting for 'Id's -type IdSubstEnv = IdEnv CoreExpr -- Domain is NcIds, i.e. not coercions - ---------------------------- -isEmptySubst :: Subst -> Bool -isEmptySubst (Subst _ id_env tv_env cv_env) - = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env -emptySubst :: Subst -emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv - -mkEmptySubst :: InScopeSet -> Subst -mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv - -mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst -mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs - --- | Find the in-scope set: see "GHC.Core.TyCo.Subst" Note [The substitution invariant] -substInScope :: Subst -> InScopeSet -substInScope (Subst in_scope _ _ _) = in_scope - --- | Remove all substitutions for 'Id's and 'Var's that might have been built up --- while preserving the in-scope set -zapSubstEnv :: Subst -> Subst -zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv +-- We keep GHC.Core.Subst separate from GHC.Core.TyCo.Subst to avoid creating +-- circular dependencies. Functions in this file that don't depend on +-- the definition of CoreExpr can be moved to GHC.Core.TyCo.Subst, as long +-- as it does not require importing too many additional hs-boot files and +-- cause a significant drop in performance. -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is -- such that TyCoSubst Note [The substitution invariant] @@ -193,38 +146,20 @@ = assertPpr (isNonCoVarId v) (ppr v $$ ppr r) $ Subst in_scope (extendVarEnv ids v r) tvs cvs +extendIdSubstWithClone :: Subst -> Id -> Id -> Subst +extendIdSubstWithClone (Subst in_scope ids tvs cvs) v v' + = assertPpr (isNonCoVarId v) (ppr v $$ ppr v') $ + Subst (extendInScopeSetSet in_scope new_in_scope) + (extendVarEnv ids v (varToCoreExpr v')) tvs cvs + where + new_in_scope = tyCoVarsOfType (varType v') `extendVarSet` v' + -- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst extendIdSubstList (Subst in_scope ids tvs cvs) prs = assert (all (isNonCoVarId . fst) prs) $ Subst in_scope (extendVarEnvList ids prs) tvs cvs --- | Add a substitution for a 'TyVar' to the 'Subst' --- The 'TyVar' *must* be a real TyVar, and not a CoVar --- You must ensure that the in-scope set is such that --- "GHC.Core.TyCo.Subst" Note [The substitution invariant] holds --- after extending the substitution like this. -extendTvSubst :: Subst -> TyVar -> Type -> Subst -extendTvSubst (Subst in_scope ids tvs cvs) tv ty - = assert (isTyVar tv) $ - Subst in_scope ids (extendVarEnv tvs tv ty) cvs - --- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' -extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst -extendTvSubstList subst vrs - = foldl' extend subst vrs - where - extend subst (v, r) = extendTvSubst subst v r - --- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': --- you must ensure that the in-scope set satisfies --- "GHC.Core.TyCo.Subst" Note [The substitution invariant] --- after extending the substitution like this -extendCvSubst :: Subst -> CoVar -> Coercion -> Subst -extendCvSubst (Subst in_scope ids tvs cvs) v r - = assert (isCoVar v) $ - Subst in_scope ids tvs (extendVarEnv cvs v r) - -- | Add a substitution appropriate to the thing being substituted -- (whether an expression, type, or coercion). See also -- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst' @@ -249,16 +184,24 @@ extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs -- | Find the substitution for an 'Id' in the 'Subst' +-- The Id should not be a CoVar lookupIdSubst :: HasDebugCallStack => Subst -> Id -> CoreExpr lookupIdSubst (Subst in_scope ids _ _) v - | not (isLocalId v) = Var v + | assertPpr (isId v && not (isCoVar v)) (ppr v) + not (isLocalId v) = Var v | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' - -- Vital! See Note [Extending the Subst] + -- Vital! See Note [Extending the IdSubstEnv] -- If v isn't in the InScopeSet, we panic, because - -- it's a bad bug and we reallly want to know + -- it's a bad bug and we really want to know | otherwise = pprPanic "lookupIdSubst" (ppr v $$ ppr in_scope) +lookupIdSubst_maybe :: HasDebugCallStack => Subst -> Id -> Maybe CoreExpr +-- Just look up in the substitution; do not check the in-scope set +lookupIdSubst_maybe (Subst _ ids _ _) v + = assertPpr (isId v && not (isCoVar v)) (ppr v) $ + lookupVarEnv ids v + delBndr :: Subst -> Var -> Subst delBndr (Subst in_scope ids tvs cvs) v | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v) @@ -281,42 +224,7 @@ (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) ------------------------------ -isInScope :: Var -> Subst -> Bool -isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope --- | Add the 'Var' to the in-scope set -extendSubstInScope :: Subst -> Var -> Subst -extendSubstInScope (Subst in_scope ids tvs cvs) v - = Subst (in_scope `InScopeSet.extendInScopeSet` v) - ids tvs cvs - --- | Add the 'Var's to the in-scope set: see also 'extendInScope' -extendSubstInScopeList :: Subst -> [Var] -> Subst -extendSubstInScopeList (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetList` vs) - ids tvs cvs - --- | Add the 'Var's to the in-scope set: see also 'extendInScope' -extendSubstInScopeSet :: Subst -> VarSet -> Subst -extendSubstInScopeSet (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetSet` vs) - ids tvs cvs - -setInScope :: Subst -> InScopeSet -> Subst -setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs - --- Pretty printing, for debugging only - -instance Outputable Subst where - ppr (Subst in_scope ids tvs cvs) - = text " in_scope_doc - $$ text " IdSubst =" <+> ppr ids - $$ text " TvSubst =" <+> ppr tvs - $$ text " CvSubst =" <+> ppr cvs - <> char '>' - where - in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr) - {- ************************************************************************ * * @@ -339,14 +247,14 @@ -- See Note [Substitutions apply only once] in "GHC.Core.TyCo.Subst" -- -- Do *not* attempt to short-cut in the case of an empty substitution! --- See Note [Extending the Subst] +-- See Note [Extending the IdSubstEnv] substExpr :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr -- HasDebugCallStack so we can track failures in lookupIdSubst substExpr subst expr = go expr where go (Var v) = lookupIdSubst subst v - go (Type ty) = Type (substTy subst ty) + go (Type ty) = Type (substTyUnchecked subst ty) go (Coercion co) = Coercion (substCo subst co) go (Lit lit) = Lit lit go (App fun arg) = App (go fun) (go arg) @@ -366,7 +274,7 @@ where (subst', bind') = substBind subst bind - go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts) + go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTyUnchecked subst ty) (map (go_alt subst') alts) where (subst', bndr') = substBndr subst bndr @@ -442,15 +350,18 @@ | otherwise = substIdBndr (text "var-bndr") subst subst bndr -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right -substBndrs :: Subst -> [Var] -> (Subst, [Var]) -substBndrs subst bndrs = mapAccumL substBndr subst bndrs +substBndrs :: Traversable f => Subst -> f Var -> (Subst, f Var) +substBndrs = mapAccumL substBndr +{-# INLINE substBndrs #-} -- | Substitute in a mutually recursive group of 'Id's -substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) +substRecBndrs :: Traversable f => Subst -> f Id -> (Subst, f Id) substRecBndrs subst bndrs = (new_subst, new_bndrs) where -- Here's the reason we need to pass rec_subst to subst_id (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs +{-# SPECIALIZE substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) #-} +{-# SPECIALIZE substRecBndrs :: Subst -> Identity Id -> (Subst, Identity Id) #-} substIdBndr :: SDoc -> Subst -- ^ Substitution to use for the IdInfo @@ -464,7 +375,7 @@ where id1 = uniqAway in_scope old_id -- id1 is cloned if necessary id2 | no_type_change = id1 - | otherwise = updateIdTypeAndMult (substTy subst) id1 + | otherwise = updateIdTypeAndMult (substTyUnchecked subst) id1 old_ty = idType old_id old_w = idMult old_id @@ -484,7 +395,7 @@ | otherwise = extendVarEnv env old_id (Var new_id) no_change = id1 == old_id - -- See Note [Extending the Subst] + -- See Note [Extending the IdSubstEnv] -- it's /not/ necessary to check mb_new_info and no_type_change {- @@ -494,12 +405,14 @@ -- | Very similar to 'substBndr', but it always allocates a new 'Unique' for -- each variable in its output. It substitutes the IdInfo though. +-- Discards non-Stable unfoldings cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id) cloneIdBndr subst us old_id = clone_id subst subst (old_id, uniqFromSupply us) -- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final -- substitution from left to right +-- Discards non-Stable unfoldings cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) cloneIdBndrs subst us ids = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) @@ -525,6 +438,7 @@ -- Just like substIdBndr, except that it always makes a new unique -- It is given the unique to use +-- Discards non-Stable unfoldings clone_id :: Subst -- Substitution for the IdInfo -> Subst -> (Id, Unique) -- Substitution and Id to transform -> (Subst, Id) -- Transformed pair @@ -544,41 +458,8 @@ Types and Coercions * * ************************************************************************ - -For types and coercions we just call the corresponding functions in -Type and Coercion, but we have to repackage the substitution, from a -Subst to a TCvSubst. -} -substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) -substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv - = case Type.substTyVarBndr (TCvSubst in_scope tv_env cv_env) tv of - (TCvSubst in_scope' tv_env' cv_env', tv') - -> (Subst in_scope' id_env tv_env' cv_env', tv') - -cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) -cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq - = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of - (TCvSubst in_scope' tv_env' cv_env', tv') - -> (Subst in_scope' id_env tv_env' cv_env', tv') - -substCoVarBndr :: Subst -> CoVar -> (Subst, CoVar) -substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv - = case Coercion.substCoVarBndr (TCvSubst in_scope tv_env cv_env) cv of - (TCvSubst in_scope' tv_env' cv_env', cv') - -> (Subst in_scope' id_env tv_env' cv_env', cv') - --- | See 'GHC.Core.Type.substTy'. -substTy :: Subst -> Type -> Type -substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty - -getTCvSubst :: Subst -> TCvSubst -getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv - --- | See 'Coercion.substCo' -substCo :: HasCallStack => Subst -> Coercion -> Coercion -substCo subst co = Coercion.substCo (getTCvSubst subst) co - {- ************************************************************************ * * @@ -592,7 +473,7 @@ | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) = id | otherwise = - updateIdTypeAndMult (substTy subst) id + updateIdTypeAndMult (substTyUnchecked subst) id -- The tyCoVarsOfType is cheaper than it looks -- because we cache the free tyvars of the type -- in a Note in the id's type itself @@ -602,6 +483,7 @@ ------------------ -- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'. +-- Discards unfoldings, unless they are Stable substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo substIdInfo subst new_id info | nothing_to_do = Nothing @@ -632,7 +514,7 @@ args' = map (substExpr subst') args substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) - -- Retain an InlineRule! + -- Retain stable unfoldings | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work = NoUnfolding | otherwise -- But keep a stable one! @@ -705,7 +587,7 @@ = tyCoFVsOfCo fv_co (const True) emptyVarSet $! acc | otherwise , let fv_expr = lookupIdSubst subst fv - = expr_fvs fv_expr isLocalVar emptyVarSet $! acc + = exprFVs fv_expr (const True) emptyVarSet $! acc ------------------ substTickish :: Subst -> CoreTickish -> CoreTickish @@ -765,7 +647,7 @@ Second, we have to ensure that we never try to substitute a literal for an Id in a breakpoint. We ensure this by never storing an Id with -an unlifted type in a Breakpoint - see GHC.HsToCore.Coverage.mkTickish. +an unlifted type in a Breakpoint - see GHC.HsToCore.Ticks.mkTickish. Breakpoints can't handle free variables with unlifted types anyway. -} diff --git a/GHC/Core/Tidy.hs b/GHC/Core/Tidy.hs --- a/GHC/Core/Tidy.hs +++ b/GHC/Core/Tidy.hs @@ -8,7 +8,6 @@ -} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Tidy ( tidyExpr, tidyRules, tidyCbvInfoTop, tidyBndrs ) where @@ -34,7 +33,6 @@ import GHC.Data.Maybe import GHC.Utils.Misc import Data.List (mapAccumL) --- import GHC.Utils.Trace import GHC.Utils.Outputable import GHC.Types.RepType (typePrimRep) import GHC.Utils.Panic @@ -84,7 +82,7 @@ -- This means the code generator can get the full calling convention by only looking at the function -- itself without having to inspect the RHS. -- --- The actual logic is in computeCbvInfo and takes: +-- The actual logic is in tidyCbvInfo and takes: -- * The function id -- * The functions rhs -- And gives us back the function annotated with the marks. @@ -117,8 +115,7 @@ -- See Note [CBV Function Ids] tidyCbvInfoLocal :: HasDebugCallStack => Id -> CoreExpr -> Id -tidyCbvInfoLocal id rhs - | otherwise = computeCbvInfo id rhs +tidyCbvInfoLocal id rhs = computeCbvInfo id rhs -- | For a binding we: -- * Look at the args @@ -135,9 +132,9 @@ -> Id -- computeCbvInfo fun_id rhs = fun_id computeCbvInfo fun_id rhs - | (isWorkerLike || isJoinId fun_id) && (valid_unlifted_worker val_args) - = - -- pprTrace "computeCbvInfo" + | is_wkr_like || isJust mb_join_id + , valid_unlifted_worker val_args + = -- pprTrace "computeCbvInfo" -- (text "fun" <+> ppr fun_id $$ -- text "arg_tys" <+> ppr (map idType val_args) $$ @@ -146,31 +143,48 @@ -- text "cbv_marks" <+> ppr cbv_marks $$ -- text "out_id" <+> ppr cbv_bndr $$ -- ppr rhs) - cbv_bndr + cbv_bndr + | otherwise = fun_id where - val_args = filter isId . fst $ collectBinders rhs - cbv_marks = - -- CBV marks are only set during tidy so none should be present already. - assertPpr (maybe True null $ idCbvMarks_maybe fun_id) (ppr fun_id <+> (ppr $ idCbvMarks_maybe fun_id) $$ ppr rhs) $ - map mkMark val_args - cbv_bndr - | valid_unlifted_worker val_args - , any isMarkedCbv cbv_marks - -- seqList to avoid retaining the original rhs - = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks - | otherwise = - -- pprTraceDebug "tidyCbvInfo: Worker seems to take unboxed tuple/sum types!" (ppr fun_id <+> ppr rhs) - asNonWorkerLikeId fun_id - -- We don't set CBV marks on functions which take unboxed tuples or sums as arguments. - -- Doing so would require us to compute the result of unarise here in order to properly determine - -- argument positions at runtime. - -- In practice this doesn't matter much. Most "interesting" functions will get a W/W split which will eliminate - -- unboxed tuple arguments, and unboxed sums are rarely used. But we could change this in the future and support + mb_join_id = isJoinId_maybe 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 + = fst $ collectNBinders join_arity rhs + | otherwise + = fst $ collectBinders rhs + + cbv_marks = -- assert: CBV marks are only set during tidy so none should be present already. + assertPpr (maybe True null $ idCbvMarks_maybe fun_id) + (ppr fun_id <+> (ppr $ idCbvMarks_maybe fun_id) $$ ppr rhs) $ + map mkMark val_args + + cbv_bndr | any isMarkedCbv cbv_marks + = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks + -- seqList: avoid retaining the original rhs + + | otherwise + = -- pprTraceDebug "tidyCbvInfo: Worker seems to take unboxed tuple/sum types!" + -- (ppr fun_id <+> ppr rhs) + asNonWorkerLikeId fun_id + + -- We don't set CBV marks on functions which take unboxed tuples or sums as + -- arguments. Doing so would require us to compute the result of unarise + -- here in order to properly determine argument positions at runtime. + -- + -- In practice this doesn't matter much. Most "interesting" functions will + -- get a W/W split which will eliminate unboxed tuple arguments, and unboxed + -- sums are rarely used. But we could change this in the future and support -- unboxed sums/tuples as well. valid_unlifted_worker args = -- pprTrace "valid_unlifted" (ppr fun_id $$ ppr args) $ all isSingleUnarisedArg args + isSingleUnarisedArg v | isUnboxedSumType ty = False | isUnboxedTupleType ty = isSimplePrimRep (typePrimRep ty) @@ -188,7 +202,6 @@ , not (isDeadEndId fun_id) = MarkedCbv | otherwise = NotMarkedCbv - isWorkerLike = isWorkerLikeId fun_id ------------ Expressions -------------- tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr @@ -339,7 +352,7 @@ new_info = vanillaIdInfo `setOccInfo` occInfo old_info `setArityInfo` arityInfo old_info - `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info) + `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info) `setDemandInfo` demandInfo old_info `setInlinePragInfo` inlinePragInfo old_info `setUnfoldingInfo` new_unf @@ -386,7 +399,7 @@ (a) To make printing tidy core nicer - (b) Because we tidy RULES and InlineRules, which may then propagate + (b) Because we tidy RULES and unfoldings, which may then propagate via --make into the compilation of the next module, and we want the benefit of that occurrence analysis when we use the rule or or inline the function. In particular, it's vital not to lose diff --git a/GHC/Core/TyCo/Compare.hs b/GHC/Core/TyCo/Compare.hs new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/Compare.hs @@ -0,0 +1,584 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1998 + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} + +-- | Type equality and comparison +module GHC.Core.TyCo.Compare ( + + -- * Type comparison + eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX, + nonDetCmpTypesX, nonDetCmpTc, + eqVarBndrs, + + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, + tcEqTyConApps, + + -- * Visiblity comparision + eqForAllVis, cmpForAllVis + + ) where + +import GHC.Prelude + +import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe ) + +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.FVs +import GHC.Core.TyCon + +import GHC.Types.Var +import GHC.Types.Unique +import GHC.Types.Var.Env + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic + +import GHC.Base (reallyUnsafePtrEquality#) + +import qualified Data.Semigroup as S + +{- GHC.Core.TyCo.Compare overview +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module implements type equality and comparison + +It uses a few functions from GHC.Core.Type, notably `typeKind`, +so it currently sits "on top of" GHC.Core.Type. +-} + +{- ********************************************************************* +* * + Type equality +* * +********************************************************************* -} + +{- Note [Computing equality on types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module implements type equality, notably `eqType`. This is +"definitional equality" or just "equality" for short. + +There are several places within GHC that depend on the precise choice of +definitional equality used. If we change that definition, all these places +must be updated. This Note merely serves as a place for all these places +to refer to, so searching for references to this Note will find every place +that needs to be updated. + +* See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. + +* See Historical Note [Typechecker equality vs definitional equality] + below + +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: + \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%. +-} + + +tcEqKind :: HasDebugCallStack => Kind -> Kind -> Bool +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 + +-- | 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 + +-- | 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) + -- 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. + +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. + +See #19226. +-} + +-- | 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 + +-- | 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 + +-- | 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 + +-- | 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 +-- 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' + + go env (TyVarTy tv1) (TyVarTy tv2) + = rnOccL env tv1 == rnOccR env tv2 + + go _ (LitTy lit1) (LitTy lit2) + = lit1 == lit2 + + 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 + + -- 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) + + -- 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 (tc_vis tc1) ts1 ts2 + + go env (CastTy t1 _) t2 = go env t1 t2 + go env t1 (CastTy t2 _) = go env t1 t2 + go _ (CoercionTy {}) (CoercionTy {}) = True + + go _ _ _ = False + + gos _ _ [] [] = True + gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2) + && gos env igs ts1 ts2 + gos _ _ _ _ = False + + 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]. + + +-- | 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 + +-- | 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. +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 +cmpForAllVis (Invisible _) (Invisible _) = EQ + + +{- Note [ForAllTy and type equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we compare (ForAllTy (Bndr tv1 vis1) ty1) + and (ForAllTy (Bndr tv2 vis2) ty2) +what should we do about `vis1` vs `vis2`. + +First, we always compare with `eqForAllVis` and `cmpForAllVis`. +But what decision do we make? + +Should GHC type-check the following program (adapted from #15740)? + + {-# LANGUAGE PolyKinds, ... #-} + data D a + type family F :: forall k. k -> Type + type instance F = D + +Due to the way F is declared, any instance of F must have a right-hand side +whose kind is equal to `forall k. k -> Type`. The kind of D is +`forall {k}. k -> Type`, which is very close, but technically uses distinct +Core: + + ----------------------------------------------------------- + | Source Haskell | Core | + ----------------------------------------------------------- + | forall k. <...> | ForAllTy (Bndr k Specified) (<...>) | + | forall {k}. <...> | ForAllTy (Bndr k Inferred) (<...>) | + ----------------------------------------------------------- + +We could deem these kinds to be unequal, but that would imply rejecting +programs like the one above. Whether a kind variable binder ends up being +specified or inferred can be somewhat subtle, however, especially for kinds +that aren't explicitly written out in the source code (like in D above). + +For now, we decide + + the specified/inferred status of an invisible type variable binder + does not affect GHC's notion of equality. + +That is, we have the following: + + -------------------------------------------------- + | Type 1 | Type 2 | Equal? | + --------------------|----------------------------- + | forall k. <...> | forall k. <...> | Yes | + | | forall {k}. <...> | Yes | + | | forall k -> <...> | No | + -------------------------------------------------- + | forall {k}. <...> | forall k. <...> | Yes | + | | forall {k}. <...> | Yes | + | | forall k -> <...> | No | + -------------------------------------------------- + | forall k -> <...> | forall k. <...> | No | + | | forall {k}. <...> | No | + | | 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 +history lying around in the code. + +Summary: prior to summer 2022, GHC had have two notions of equality +over Core types. But now there is only one: definitional equality, +or just equality for short. + +The old setup was: + +* Definitional equality, as implemented by GHC.Core.Type.eqType. + 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. + +Typechecker equality implied definitional equality: if two types are equal +according to typechecker equality, then they are also equal according to +definitional equality. The converse is not always true, as typechecker equality +is more finer-grained than definitional equality in two places: + +* Constraint vs Type. Definitional equality equated Type and + Constraint, but typechecker treats them as distinct types. + +* Unlike definitional equality, which does not care about the ForAllTyFlag of a + ForAllTy, typechecker equality treats Required type variable binders as + distinct from Invisible type variable binders. + See Note [ForAllTy and type equality] + + +************************************************************************ +* * + Comparison for types + (We don't use instances so that we know where it happens) +* * +************************************************************************ + +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 +uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for +ordering leads to nondeterminism. We hit the same problem in the TyVarTy case, +comparing type variables is nondeterministic, note the call to nonDetCmpVar in +nonDetCmpTypeX. +See Note [Unique Determinism] for more details. +-} + +nonDetCmpType :: Type -> Type -> Ordering +nonDetCmpType !t1 !t2 + -- See Note [Type comparisons using object pointer comparisons] + | 1# <- reallyUnsafePtrEquality# t1 t2 + = EQ +nonDetCmpType (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 + = EQ +nonDetCmpType t1 t2 + -- we know k1 and k2 have the same kind, because they both have kind *. + = 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@ + | TEQ -- ^ @t1 ~ t2@ and there are no casts in either, + -- therefore we can conclude @k1 ~ k2@ + | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so + -- they may differ in kind. + | TGT -- ^ @t1 > t2@ + deriving (Eq, Ord, Enum, Bounded) + +nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse + -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep + -- See Note [Computing equality on types] +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 + -- the kinds of the types being compared + TEQX -> toOrdering $ go env k1 k2 + ty_ordering -> toOrdering ty_ordering + where + k1 = typeKind orig_t1 + k2 = typeKind orig_t2 + + toOrdering :: TypeOrdering -> Ordering + toOrdering TLT = LT + toOrdering TEQ = EQ + toOrdering TEQX = EQ + toOrdering TGT = GT + + liftOrdering :: Ordering -> TypeOrdering + liftOrdering LT = TLT + liftOrdering EQ = TEQ + liftOrdering GT = TGT + + thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering + thenCmpTy TEQ rel = rel + thenCmpTy TEQX rel = hasCast rel + thenCmpTy rel _ = rel + + hasCast :: TypeOrdering -> TypeOrdering + hasCast TEQ = TEQX + hasCast rel = rel + + -- 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 + go env t1 t2 + | Just t1' <- coreView t1 = go env t1' t2 + | Just t2' <- coreView t2 = go env t1 t2' + + 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) + `thenCmpTy` go env (varType tv1) (varType tv2) + `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 + + -- See Note [Equality on AppTys] + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- splitAppTyNoView_maybe ty2 + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- splitAppTyNoView_maybe ty1 + = go env s1 s2 `thenCmpTy` go env t1 t2 + + go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) + -- NB: nonDepCmpTypeX does the kind check requested by + -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep + = liftOrdering (nonDetCmpTypeX env s1 s2 S.<> nonDetCmpTypeX env t1 t2) + `thenCmpTy` go env w1 w2 + -- Comparing multiplicities last because the test is usually true + + go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) + = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 + + go _ (LitTy l1) (LitTy l2) = liftOrdering (nonDetCmpTyLit l1 l2) + go env (CastTy t1 _) t2 = hasCast $ go env t1 t2 + go env t1 (CastTy t2 _) = hasCast $ go env t1 t2 + + go _ (CoercionTy {}) (CoercionTy {}) = TEQ + + -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy + go _ ty1 ty2 + = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2) + where get_rank :: Type -> Int + get_rank (CastTy {}) + = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) + get_rank (TyVarTy {}) = 0 + get_rank (CoercionTy {}) = 1 + get_rank (AppTy {}) = 3 + get_rank (LitTy {}) = 4 + get_rank (TyConApp {}) = 5 + get_rank (FunTy {}) = 6 + get_rank (ForAllTy {}) = 7 + + gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering + gos _ [] [] = TEQ + gos _ [] _ = TLT + 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. +-- See Note [nonDetCmpType nondeterminism] +nonDetCmpTc :: TyCon -> TyCon -> Ordering +nonDetCmpTc tc1 tc2 + = u1 `nonDetCmpUnique` u2 + where + u1 = tyConUnique tc1 + u2 = tyConUnique tc2 + + + 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 @@ -30,6 +30,15 @@ anyFreeVarsOfType, anyFreeVarsOfTypes, anyFreeVarsOfCo, noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, + -- * Free type constructors + tyConsOfType, tyConsOfTypes, + + -- * Free vars with visible/invisible separate + visVarsOfTypes, visVarsOfType, + + -- * Occurrence-check expansion + occCheckExpand, + -- * Well-scoped free variables scopedSort, tyCoVarsOfTypeWellScoped, tyCoVarsOfTypesWellScoped, @@ -44,19 +53,26 @@ import GHC.Prelude -import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes) +import {-# SOURCE #-} GHC.Core.Type( partitionInvisibleTypes, coreView ) +import {-# SOURCE #-} GHC.Core.Coercion( coercionLKind ) +import GHC.Builtin.Types.Prim( funTyFlagTyCon ) + import Data.Monoid as DM ( Endo(..), Any(..) ) import GHC.Core.TyCo.Rep import GHC.Core.TyCon -import GHC.Types.Var +import GHC.Core.Coercion.Axiom( coAxiomTyCon ) import GHC.Utils.FV +import GHC.Types.Var import GHC.Types.Unique.FM +import GHC.Types.Unique.Set + import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Data.Pair {- %************************************************************************ @@ -219,7 +235,7 @@ * * ********************************************************************* -} -{- Note [Acumulating parameter free variables] +{- Note [Accumulating parameter free variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can use foldType to build an accumulating-parameter version of a free-var finder, thus: @@ -254,7 +270,7 @@ AppTy equation we don't build a thunk for (fvs env t2 acc). The optimiser does do all this, but not very robustly. It depends -critially on the basic arity-2 function not being exported, so that +critically on the basic arity-2 function not being exported, so that all its calls are visibly to three arguments. This analysis is done by the Call Arity pass. @@ -283,7 +299,7 @@ -- tyCoVarsOfTypes tys = closeOverKinds (shallowTyCoVarsOfTypes tys) tyCoVarsOfCo :: Coercion -> TyCoVarSet --- See Note [Free variables of Coercions] +-- See Note [Free variables of types] tyCoVarsOfCo co = runTyCoVars (deep_co co) tyCoVarsOfMCo :: MCoercion -> TyCoVarSet @@ -575,7 +591,7 @@ tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc -tyCoFVsBndr :: TyCoVarBinder -> FV -> FV +tyCoFVsBndr :: ForAllTyBinder -> FV -> FV -- Free vars of (forall b. ) tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs @@ -617,7 +633,7 @@ = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc -tyCoFVsOfCo (FunCo _ w co1 co2) 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 tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc = tyCoFVsOfCoVar v fv_cand in_scope acc @@ -630,7 +646,7 @@ `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 (NthCo _ _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (SelCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfCo (LRCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc 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 @@ -673,8 +689,8 @@ almost_devoid_co_var_of_co (ForAllCo v kind_co 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 _ w co1 co2) cv - = almost_devoid_co_var_of_co w cv +almost_devoid_co_var_of_co (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) cv + = almost_devoid_co_var_of_co w cv && almost_devoid_co_var_of_co co1 cv && almost_devoid_co_var_of_co co2 cv almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv @@ -690,7 +706,7 @@ almost_devoid_co_var_of_co (TransCo co1 co2) cv = almost_devoid_co_var_of_co co1 cv && almost_devoid_co_var_of_co co2 cv -almost_devoid_co_var_of_co (NthCo _ _ co) cv +almost_devoid_co_var_of_co (SelCo _ co) cv = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_co (LRCo _ co) cv = almost_devoid_co_var_of_co co cv @@ -747,6 +763,43 @@ +{- +%************************************************************************ +%* * + Free tyvars, but with visible/invisible info +%* * +%************************************************************************ + +-} +-- | Retrieve the free variables in this type, splitting them based +-- on whether they are used visibly or invisibly. Invisible ones come +-- first. +visVarsOfType :: Type -> Pair TyCoVarSet +visVarsOfType orig_ty = Pair invis_vars vis_vars + where + Pair invis_vars1 vis_vars = go orig_ty + invis_vars = invis_vars1 `minusVarSet` vis_vars + + go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) + go (AppTy t1 t2) = go t1 `mappend` go t2 + go (TyConApp tc tys) = go_tc tc tys + go (FunTy _ w t1 t2) = go w `mappend` go t1 `mappend` go t2 + go (ForAllTy (Bndr tv _) ty) + = ((`delVarSet` tv) <$> go ty) `mappend` + (invisible (tyCoVarsOfType $ varType tv)) + go (LitTy {}) = mempty + go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) + go (CoercionTy co) = invisible $ tyCoVarsOfCo co + + invisible vs = Pair vs emptyVarSet + + go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in + invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis + +visVarsOfTypes :: [Type] -> Pair TyCoVarSet +visVarsOfTypes = foldMap visVarsOfType + + {- ********************************************************************* * * Injective free vars @@ -833,7 +886,7 @@ -- * In the kind of a bound variable in a forall -- * In a coercion -- * In a Specified or Inferred argument to a function --- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" +-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" invisibleVarsOfType :: Type -> FV invisibleVarsOfType = go where @@ -996,3 +1049,274 @@ -- | Get the free vars of types in scoped order tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList + +{- +************************************************************************ +* * + Free type constructors +* * +************************************************************************ +-} + +-- | All type constructors occurring in the type; looking through type +-- synonyms, but not newtypes. +-- When it finds a Class, it returns the class TyCon. +tyConsOfType :: Type -> UniqSet TyCon +tyConsOfType ty + = go ty + where + go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy {}) = emptyUniqSet + go (LitTy {}) = emptyUniqSet + go (TyConApp tc tys) = go_tc tc `unionUniqSets` tyConsOfTypes tys + go (AppTy a b) = go a `unionUniqSets` go b + go (FunTy af w a b) = go w `unionUniqSets` + go a `unionUniqSets` go b + `unionUniqSets` go_tc (funTyFlagTyCon af) + go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) + go (CastTy ty co) = go ty `unionUniqSets` go_co co + go (CoercionTy co) = go_co co + + go_co (Refl ty) = go ty + 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 (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 (CoVarCo {}) = emptyUniqSet + go_co (HoleCo {}) = emptyUniqSet + go_co (SymCo co) = go_co co + go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 + go_co (SelCo _ co) = go_co co + go_co (LRCo _ co) = go_co co + 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 + +tyConsOfTypes :: [Type] -> UniqSet TyCon +tyConsOfTypes tys = foldr (unionUniqSets . tyConsOfType) emptyUniqSet tys + +{- ********************************************************************** +* * + Occurs check expansion +%* * +%********************************************************************* -} + +{- Note [Occurs check expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid +of occurrences of tv outside type function arguments, if that is +possible; otherwise, it returns Nothing. + +For example, suppose we have + type F a b = [a] +Then + occCheckExpand b (F Int b) = Just [Int] +but + occCheckExpand a (F a Int) = Nothing + +We don't promise to do the absolute minimum amount of expanding +necessary, but we try not to do expansions we don't need to. We +prefer doing inner expansions first. For example, + type F a b = (a, Int, a, [a]) + type G b = Char +We have + occCheckExpand b (F (G b)) = Just (F Char) +even though we could also expand F to get rid of b. + +Note [Occurrence checking: look inside kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are considering unifying + (alpha :: *) ~ Int -> (beta :: alpha -> alpha) +This may be an error (what is that alpha doing inside beta's kind?), +but we must not make the mistake of actually unifying or we'll +build an infinite data structure. So when looking for occurrences +of alpha in the rhs, we must look in the kinds of type variables +that occur there. + +occCheckExpand tries to expand type synonyms to remove +unnecessary occurrences of a variable, and thereby get past an +occurs-check failure. This is good; but + we can't do it in the /kind/ of a variable /occurrence/ + +For example #18451 built an infinite type: + type Const a b = a + data SameKind :: k -> k -> Type + type T (k :: Const Type a) = forall (b :: k). SameKind a b + +We have + b :: k + k :: Const Type a + a :: k (must be same as b) + +So if we aren't careful, a's kind mentions a, which is bad. +And expanding an /occurrence/ of 'a' doesn't help, because the +/binding site/ is the master copy and all the occurrences should +match it. + +Here's a related example: + f :: forall a b (c :: Const Type b). Proxy '[a, c] + +The list means that 'a' gets the same kind as 'c'; but that +kind mentions 'b', so the binders are out of order. + +Bottom line: in occCheckExpand, do not expand inside the kinds +of occurrences. See bad_var_occ in occCheckExpand. And +see #18451 for more debate. +-} + +occCheckExpand :: [Var] -> Type -> Maybe Type +-- See Note [Occurs check expansion] +-- We may have needed to do some type synonym unfolding in order to +-- get rid of the variable (or forall), so we also return the unfolded +-- version of the type, which is guaranteed to be syntactically free +-- of the given type variable. If the type is already syntactically +-- free of the variable, then the same type is returned. +occCheckExpand vs_to_avoid ty + | null vs_to_avoid -- Efficient shortcut + = Just ty -- Can happen, eg. GHC.Core.Utils.mkSingleAltCase + + | otherwise + = go (mkVarSet vs_to_avoid, emptyVarEnv) ty + where + go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type + -- The VarSet is the set of variables we are trying to avoid + -- The VarEnv carries mappings necessary + -- because of kind expansion + go (as, env) ty@(TyVarTy tv) + | Just tv' <- lookupVarEnv env tv = return (mkTyVarTy tv') + | bad_var_occ as tv = Nothing + | otherwise = return ty + + go _ ty@(LitTy {}) = return ty + go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (AppTy ty1' ty2') } + go cxt ty@(FunTy _ w ty1 ty2) + = do { w' <- go cxt w + ; ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (ty { ft_mult = w', ft_arg = ty1', ft_res = ty2' }) } + go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) + = do { ki' <- go cxt (varType tv) + ; let tv' = setVarType tv ki' + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go (as', env') body_ty + ; return (ForAllTy (Bndr tv' vis) body') } + + -- For a type constructor application, first try expanding away the + -- offending variable from the arguments. If that doesn't work, next + -- see if the type constructor is a type synonym, and if so, expand + -- it and try again. + go cxt ty@(TyConApp tc tys) + = case mapM (go cxt) tys of + Just tys' -> return (TyConApp tc tys') + Nothing | Just ty' <- coreView ty -> go cxt ty' + | otherwise -> Nothing + -- Failing that, try to expand a synonym + + go cxt (CastTy ty co) = do { ty' <- go cxt ty + ; co' <- go_co cxt co + ; return (CastTy ty' co') } + go cxt (CoercionTy co) = do { co' <- go_co cxt co + ; return (CoercionTy co') } + + ------------------ + bad_var_occ :: VarSet -> Var -> Bool + -- Works for TyVar and CoVar + -- See Note [Occurrence checking: look inside kinds] + bad_var_occ vs_to_avoid v + = v `elemVarSet` vs_to_avoid + || tyCoVarsOfType (varType v) `intersectsVarSet` vs_to_avoid + + ------------------ + go_mco _ MRefl = return MRefl + go_mco ctx (MCo co) = MCo <$> go_co ctx co + + ------------------ + go_co cxt (Refl ty) = do { ty' <- go cxt ty + ; return (Refl ty') } + go_co cxt (GRefl r ty mco) = do { mco' <- go_mco cxt mco + ; ty' <- go cxt ty + ; return (GRefl r ty' mco') } + -- Note: Coercions do not contain type synonyms + go_co cxt (TyConAppCo r tc args) = do { args' <- mapM (go_co cxt) args + ; return (TyConAppCo r tc args') } + 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) + = 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') } + 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 + ; w' <- go_co cxt w + ; return (co { fco_mult = w', fco_arg = co1', fco_res = co2' })} + + go_co (as,env) co@(CoVarCo c) + | Just c' <- lookupVarEnv env c = return (CoVarCo c') + | bad_var_occ as c = Nothing + | otherwise = return co + + go_co (as,_) co@(HoleCo h) + | 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 + diff --git a/GHC/Core/TyCo/FVs.hs-boot b/GHC/Core/TyCo/FVs.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/Core/TyCo/FVs.hs-boot @@ -0,0 +1,6 @@ +module GHC.Core.TyCo.FVs where + +import GHC.Prelude ( Bool ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) + +noFreeVarsOfType :: Type -> Bool 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 @@ -27,14 +27,14 @@ import GHC.Prelude import {-# SOURCE #-} GHC.CoreToIface - ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr + ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndrs , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) import {-# SOURCE #-} GHC.Core.DataCon ( dataConFullSig , dataConUserTyVarBinders, DataCon ) -import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern One, pattern Many, - splitForAllReqTVBinders, splitForAllInvisTVBinders ) +import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern OneTy, pattern ManyTy, + splitForAllReqTyBinders, splitForAllInvisTyBinders ) import GHC.Core.TyCon import GHC.Core.TyCo.Rep @@ -42,7 +42,7 @@ import GHC.Core.TyCo.FVs import GHC.Core.Class import GHC.Types.Var - +import GHC.Core.Multiplicity( pprArrowWithMultiplicity ) import GHC.Iface.Type import GHC.Types.Var.Set @@ -68,17 +68,11 @@ works just by setting the initial context precedence very high. Note that any function which pretty-prints a @Type@ first converts the @Type@ -to an @IfaceType@. See Note [IfaceType and pretty-printing] in GHC.Iface.Type. +to an @IfaceType@. See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr. See Note [Precedence in types] in GHC.Types.Basic. -} --------------------------------------------------------- --- When pretty-printing types, we convert to IfaceType, --- and pretty-print that. --- See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr --------------------------------------------------------- - pprType, pprParendType, pprTidiedType :: Type -> SDoc pprType = pprPrecType topPrec pprParendType = pprPrecType appPrec @@ -167,18 +161,18 @@ pprSigmaType :: Type -> SDoc pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType -pprForAll :: [TyCoVarBinder] -> SDoc -pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) +pprForAll :: [ForAllTyBinder] -> SDoc +pprForAll tvs = pprIfaceForAll (toIfaceForAllBndrs tvs) -- | Print a user-level forall; see @Note [When to print foralls]@ in -- "GHC.Iface.Type". -pprUserForAll :: [TyCoVarBinder] -> SDoc -pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr +pprUserForAll :: [ForAllTyBinder] -> SDoc +pprUserForAll = pprUserIfaceForAll . toIfaceForAllBndrs -pprTCvBndrs :: [TyCoVarBinder] -> SDoc +pprTCvBndrs :: [ForAllTyBinder] -> SDoc pprTCvBndrs tvs = sep (map pprTCvBndr tvs) -pprTCvBndr :: TyCoVarBinder -> SDoc +pprTCvBndr :: ForAllTyBinder -> SDoc pprTCvBndr = pprTyVar . binderVar pprTyVars :: [TyVar] -> SDoc @@ -236,18 +230,15 @@ debug_ppr_ty _ (TyVarTy tv) = ppr tv -- With -dppr-debug we get (tv :: kind) -debug_ppr_ty prec ty@(FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) +debug_ppr_ty prec (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) = maybeParen prec funPrec $ sep [debug_ppr_ty funPrec arg, arr <+> debug_ppr_ty prec res] where - arr = case af of - VisArg -> case mult of - One -> lollipop - Many -> arrow - w -> mulArrow (ppr w) - InvisArg -> case mult of - Many -> darrow - _ -> pprPanic "unexpected multiplicity" (ppr ty) + arr = pprArrowWithMultiplicity af $ + case mult of + OneTy -> Left True + ManyTy -> Left False + _ -> Right (debug_ppr_ty appPrec mult) debug_ppr_ty prec (TyConApp tc tys) | null tys = ppr tc @@ -269,7 +260,7 @@ -- Invisible forall: forall {k} (a :: k). t debug_ppr_ty prec t - | (bndrs, body) <- splitForAllInvisTVBinders t + | (bndrs, body) <- splitForAllInvisTyBinders t , not (null bndrs) = maybeParen prec funPrec $ sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <> dot, @@ -282,7 +273,7 @@ -- Visible forall: forall x y -> t debug_ppr_ty prec t - | (bndrs, body) <- splitForAllReqTVBinders t + | (bndrs, body) <- splitForAllReqTyBinders t , not (null bndrs) = maybeParen prec funPrec $ sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <+> arrow, @@ -294,7 +285,7 @@ -- Impossible case: neither visible nor invisible forall. debug_ppr_ty _ ForAllTy{} - = panic "debug_ppr_ty: neither splitForAllInvisTVBinders nor splitForAllReqTVBinders returned any binders" + = panic "debug_ppr_ty: neither splitForAllInvisTyBinders nor splitForAllReqTyBinders returned any binders" {- Note [Infix type variables] diff --git a/GHC/Core/TyCo/Ppr.hs-boot b/GHC/Core/TyCo/Ppr.hs-boot --- a/GHC/Core/TyCo/Ppr.hs-boot +++ b/GHC/Core/TyCo/Ppr.hs-boot @@ -5,6 +5,7 @@ import GHC.Utils.Outputable ( SDoc ) pprType :: Type -> SDoc +debugPprType :: Type -> SDoc pprKind :: Kind -> SDoc pprCo :: Coercion -> SDoc pprTyLit :: TyLit -> SDoc 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 @@ -30,13 +30,13 @@ TyLit(..), KindOrType, Kind, - RuntimeRepType, + RuntimeRepType, LevityType, KnotTied, PredType, ThetaType, FRRType, -- Synonyms - ArgFlag(..), AnonArgFlag(..), + ForAllTyFlag(..), FunTyFlag(..), -- * Coercions - Coercion(..), + Coercion(..), CoSel(..), FunSel(..), UnivCoProvenance(..), CoercionHole(..), coHoleCoVar, setCoHoleCoVar, CoercionN, CoercionR, CoercionP, KindCoercion, @@ -45,23 +45,15 @@ -- * Functions over types mkNakedTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, - mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, + mkFunTy, mkNakedFunTy, + mkVisFunTy, mkScaledFunTys, + mkInvisFunTy, mkInvisFunTys, + tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTys, mkForAllTy, mkForAllTys, mkInvisForAllTys, mkPiTy, mkPiTys, - mkFunTyMany, - mkScaledFunTy, mkVisFunTyMany, mkVisFunTysMany, - mkInvisFunTyMany, mkInvisFunTysMany, nonDetCmpTyLit, cmpTyLit, - -- * Functions over binders - TyCoBinder(..), TyCoVarBinder, TyBinder, - binderVar, binderVars, binderType, binderArgFlag, - delBinderVar, - isInvisibleArgFlag, isVisibleArgFlag, - isInvisibleBinder, isVisibleBinder, - isTyBinder, isNamedBinder, - -- * Functions over coercions pickLR, @@ -78,27 +70,30 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit ) +import {-# SOURCE #-} GHC.Builtin.Types +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 import GHC.Core.TyCon import GHC.Core.Coercion.Axiom -- others -import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy ) +import GHC.Builtin.Names + import GHC.Types.Basic ( LeftOrRight(..), pickLR ) -import GHC.Types.Unique ( Uniquable(..) ) import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Binary -- libraries import qualified Data.Data as Data hiding ( TyCon ) import Data.IORef ( IORef ) -- for CoercionHole +import Control.DeepSeq {- ********************************************************************** * * @@ -116,6 +111,9 @@ -- | Type synonym used for types of kind RuntimeRep. type RuntimeRepType = Type +-- | Type synonym used for types of kind Levity. +type LevityType = Type + -- A type with a syntactically fixed RuntimeRep, in the sense -- of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. type FRRType = Type @@ -155,7 +153,7 @@ -- can appear as the right hand side of a type synonym. | ForAllTy - {-# UNPACK #-} !TyCoVarBinder + {-# UNPACK #-} !ForAllTyBinder Type -- ^ A Π type. -- Note [When we quantify over a coercion variable] -- INVARIANT: If the binder is a coercion variable, it must @@ -164,11 +162,15 @@ | FunTy -- ^ FUN m t1 t2 Very common, so an important special case -- See Note [Function types] - { ft_af :: AnonArgFlag -- Is this (->) or (=>)? - , ft_mult :: Mult -- Multiplicity - , ft_arg :: Type -- Argument type - , ft_res :: Type } -- Result type + { ft_af :: FunTyFlag -- Is this (->/FUN) or (=>) or (==>)? + -- This info is fully specified by the kinds in + -- ft_arg and ft_res + -- Note [FunTyFlag] in GHC.Types.Var + , ft_mult :: Mult -- Multiplicity; always Many for (=>) and (==>) + , ft_arg :: Type -- Argument type + , ft_res :: Type } -- Result type + | LitTy TyLit -- ^ Type literals are similar to type constructors. | CastTy @@ -232,9 +234,9 @@ TYPE r2 -> Type mkTyConApp ensures that we convert a saturated application - TyConApp FUN [m,r1,r2,t1,t2] into FunTy VisArg m t1 t2 + TyConApp FUN [m,r1,r2,t1,t2] into FunTy FTF_T_T m t1 t2 dropping the 'r1' and 'r2' arguments; they are easily recovered - from 't1' and 't2'. The visibility is always VisArg, because + from 't1' and 't2'. The FunTyFlag is always FTF_T_T, because we build constraint arrows (=>) with e.g. mkPhiTy and friends, never `mkTyConApp funTyCon args`. @@ -255,12 +257,8 @@ There is a plan to change the argument order and make the multiplicity argument nondependent in #20164. -* The ft_af field says whether or not this is an invisible argument - VisArg: t1 -> t2 Ordinary function type - InvisArg: t1 => t2 t1 is guaranteed to be a predicate type, - i.e. t1 :: Constraint +* 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. @@ -299,8 +297,8 @@ of kind Constrain), are just regular old types, are visible, and are not implicitly instantiated. -In a FunTy { ft_af = InvisArg }, the argument type is always -a Predicate type. +In a FunTy { ft_af = af } and af = FTF_C_T or FTF_C_C, the argument +type is always a Predicate type. Note [Weird typing rule for ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -363,7 +361,7 @@ the box on the spot. * How can we get such a MkT? By promoting a GADT-style data - constructor + constructor, written with an explicit equality constraint. data T a b where MkT :: (a~b) => a -> b -> T a b See DataCon.mkPromotedDataCon @@ -386,15 +384,15 @@ * The existence of promoted MkT with an equality-constraint argument is the (only) reason that the AnonTCB constructor - of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg). + 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 InvisArg) - Bndr (_ :: a) (AnonTCB VisArg)) - Bndr (_ :: b) (AnonTCB VisArg)) + 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 @@ -539,12 +537,6 @@ extract relevant free variables, but it would not be hard to write if the need arises. -Besides eqType, another equality relation that upholds the (EQ) property above -is /typechecker equality/, which is implemented as -GHC.Tc.Utils.TcType.tcEqType. See -Note [Typechecker equality vs definitional equality] in GHC.Tc.Utils.TcType for -what the difference between eqType and tcEqType is. - Note [Respecting definitional equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note [Non-trivial definitional equality] introduces the property (EQ). @@ -569,7 +561,7 @@ about outermost casts to uphold (EQ). Eliminating reflexive casts is done in mkCastTy. This is (EQ1) below. -Unforunately, that's not the end of the story. Consider comparing +Unfortunately, that's not the end of the story. Consider comparing (T a b c) =? (T a b |> (co -> )) (c |> co) These two types have the same kind (Type), but the left type is a TyConApp while the right type is not. To handle this case, we say that the right-hand @@ -634,7 +626,7 @@ Note [When we quantify over a coercion variable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The TyCoVarBinder in a ForAllTy can be (most often) a TyVar or (rarely) +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 the example: @@ -664,11 +656,11 @@ Note [Unused coercion variable in ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have - \(co:t1 ~ t2). e + \(co:t1 ~# t2). e -What type should we give to this expression? - (1) forall (co:t1 ~ t2) -> t - (2) (t1 ~ t2) -> t +What type should we give to the above expression? + (1) forall (co:t1 ~# t2) -> t + (2) (t1 ~# t2) -> t If co is used in t, (1) should be the right choice. if co is not used in t, we would like to have (1) and (2) equivalent. @@ -734,242 +726,6 @@ {- ********************************************************************** * * - TyCoBinder and ArgFlag -* * -********************************************************************** -} - --- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be --- dependent ('Named') or nondependent ('Anon'). They may also be visible or --- not. See Note [TyCoBinders] -data TyCoBinder - = Named TyCoVarBinder -- A type-lambda binder - | Anon AnonArgFlag (Scaled Type) -- A term-lambda binder. Type here can be CoercionTy. - -- Visibility is determined by the AnonArgFlag - deriving Data.Data - -instance Outputable TyCoBinder where - ppr (Anon af ty) = ppr af <+> ppr ty - ppr (Named (Bndr v Required)) = ppr v - ppr (Named (Bndr v Specified)) = char '@' <> ppr v - ppr (Named (Bndr v Inferred)) = braces (ppr v) - - --- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder' --- in the 'Named' field. -type TyBinder = TyCoBinder - --- | Remove the binder's variable from the set, if the binder has --- a variable. -delBinderVar :: VarSet -> TyCoVarBinder -> VarSet -delBinderVar vars (Bndr tv _) = vars `delVarSet` tv - --- | Does this binder bind an invisible argument? -isInvisibleBinder :: TyCoBinder -> Bool -isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis -isInvisibleBinder (Anon InvisArg _) = True -isInvisibleBinder (Anon VisArg _) = False - --- | Does this binder bind a visible argument? -isVisibleBinder :: TyCoBinder -> Bool -isVisibleBinder = not . isInvisibleBinder - -isNamedBinder :: TyCoBinder -> Bool -isNamedBinder (Named {}) = True -isNamedBinder (Anon {}) = False - --- | If its a named binder, is the binder a tyvar? --- Returns True for nondependent binder. --- This check that we're really returning a *Ty*Binder (as opposed to a --- coercion binder). That way, if/when we allow coercion quantification --- in more places, we'll know we missed updating some function. -isTyBinder :: TyCoBinder -> Bool -isTyBinder (Named bnd) = isTyVarBinder bnd -isTyBinder _ = True - -{- Note [TyCoBinders] -~~~~~~~~~~~~~~~~~~~ -A ForAllTy contains a TyCoVarBinder. But a type can be decomposed -to a telescope consisting of a [TyCoBinder] - -A TyCoBinder represents the type of binders -- that is, the type of an -argument to a Pi-type. GHC Core currently supports two different -Pi-types: - - * A non-dependent function type, - written with ->, e.g. ty1 -> ty2 - represented as FunTy ty1 ty2. These are - lifted to Coercions with the corresponding FunCo. - - * A dependent compile-time-only polytype, - written with forall, e.g. forall (a:*). ty - represented as ForAllTy (Bndr a v) ty - -Both Pi-types classify terms/types that take an argument. In other -words, if `x` is either a function or a polytype, `x arg` makes sense -(for an appropriate `arg`). - - -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder. - Each TyCoVarBinder - Bndr a tvis - is equipped with tvis::ArgFlag, which says whether or not arguments - for this binder should be visible (explicit) in source Haskell. - -* A TyCon contains a list of TyConBinders. Each TyConBinder - Bndr a cvis - is equipped with cvis::TyConBndrVis, which says whether or not type - and kind arguments for this TyCon should be visible (explicit) in - source Haskell. - -This table summarises the visibility rules: ---------------------------------------------------------------------------------------- -| Occurrences look like this -| GHC displays type as in Haskell source code -|-------------------------------------------------------------------------------------- -| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term -| tvis :: ArgFlag -| 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 TyCoBinder in terms] -| -| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon -| cvis :: TyConBndrVis -| cvis = AnonTCB: T :: kind -> kind Required: T * -| cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T -| T :: forall {co}. kind Arg not allowed: T -| cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T -| cvis = NamedTCB Required: T :: forall k -> kind Required: T * ---------------------------------------------------------------------------------------- - -[1] In types, in the Specified case, it would make sense to allow - optional kind applications, thus (T @*), but we have not - yet implemented that - ----- In term declarations ---- - -* Inferred. Function defn, with no signature: f1 x = x - We infer f1 :: forall {a}. a -> a, with 'a' Inferred - It's Inferred because it doesn't appear in any - user-written signature for f1 - -* Specified. Function defn, with signature (implicit forall): - f2 :: a -> a; f2 x = x - So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified - even though 'a' is not bound in the source code by an explicit forall - -* Specified. Function defn, with signature (explicit forall): - f3 :: forall a. a -> a; f3 x = x - So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified - -* 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 - It's Inferred because the user marked it as such, even though it does appear - in the user-written signature for f4 - -* 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 - 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 - This time 'k' is Specified, because it is mentioned explicitly, - so we get f6 :: forall (k:*) (a:k->*) (b:k). a b -> Int - -* Similarly pattern synonyms: - Inferred - from inferred types (e.g. no pattern type signature) - - or from inferred kind polymorphism - ----- In type declarations ---- - -* Inferred (k) - data T1 a b = MkT1 (a b) - Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * - The kind variable 'k' is Inferred, since it is not mentioned - - Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind, - and Anon binders don't have a visibility flag. (Or you could think - of Anon having an implicit Required flag.) - -* Specified (k) - data T2 (a::k->*) b = MkT (a b) - Here T's kind is T :: forall (k:*). (k->*) -> k -> * - The kind variable 'k' is Specified, since it is mentioned in - the signature. - -* Required (k) - data T k (a::k->*) b = MkT (a b) - Here T's kind is T :: forall k:* -> (k->*) -> k -> * - The kind is Required, since it bound in a positional way in T's declaration - Every use of T must be explicitly applied to a kind - -* Inferred (k1), Specified (k) - data T a b (c :: k) = MkT (a b) (Proxy c) - Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * - So 'k' is Specified, because it appears explicitly, - but 'k1' is Inferred, because it does not - -Generally, in the list of TyConBinders for a TyCon, - -* Inferred arguments always come first -* Specified, Anon and Required can be mixed - -e.g. - data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... - -Here Foo's TyConBinders are - [Required 'a', Specified 'b', Anon] -and its kind prints as - Foo :: forall a -> forall b. (a -> b -> Type) -> Type - -See also Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl - ----- Printing ----- - - We print forall types with enough syntax to tell you their visibility - flag. But this is not source Haskell, and these types may not all - be parsable. - - Specified: a list of Specified binders is written between `forall` and `.`: - 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 - - Required: binders are put between `forall` and `->`: - T :: forall k -> * - ----- Other points ----- - -* In classic Haskell, all named binders (that is, the type variables in - a polymorphic function type f :: forall a. a -> a) have been Inferred. - -* Inferred variables correspond to "generalized" variables from the - Visible Type Applications paper (ESOP'16). - -Note [No Required TyCoBinder 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 TyCoBinders 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. --} - - -{- ********************************************************************** -* * PredType * * ********************************************************************** -} @@ -1041,60 +797,106 @@ mkTyCoVarTys :: [TyCoVar] -> [Type] mkTyCoVarTys = map mkTyCoVarTy -infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy`, `mkVisFunTyMany`, - `mkInvisFunTyMany` -- Associates to the right +infixr 3 `mkFunTy`, `mkInvisFunTy`, `mkVisFunTyMany` -mkFunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type -mkFunTy af mult arg res = FunTy { ft_af = af - , ft_mult = mult - , ft_arg = arg - , ft_res = res } +mkNakedFunTy :: FunTyFlag -> Kind -> Kind -> Kind +-- See Note [Naked FunTy] in GHC.Builtin.Types +-- Always Many multiplicity; kinds have no linearity +mkNakedFunTy af arg res + = FunTy { ft_af = af, ft_mult = manyDataConTy + , ft_arg = arg, ft_res = res } -mkScaledFunTy :: AnonArgFlag -> Scaled Type -> Type -> Type -mkScaledFunTy af (Scaled mult arg) res = mkFunTy af mult arg res +mkFunTy :: HasDebugCallStack => FunTyFlag -> Mult -> Type -> Type -> Type +mkFunTy af mult arg res + = assertPpr (af == chooseFunTyFlag arg res) (vcat + [ text "af" <+> ppr af + , text "chooseAAF" <+> ppr (chooseFunTyFlag arg res) + , text "arg" <+> ppr arg <+> dcolon <+> ppr (typeKind arg) + , text "res" <+> ppr res <+> dcolon <+> ppr (typeKind res) ]) $ + FunTy { ft_af = af + , ft_mult = mult + , ft_arg = arg + , ft_res = res } -mkVisFunTy, mkInvisFunTy :: Mult -> Type -> Type -> Type -mkVisFunTy = mkFunTy VisArg -mkInvisFunTy = mkFunTy InvisArg +mkInvisFunTy :: HasDebugCallStack => Type -> Type -> Type +mkInvisFunTy arg res + = mkFunTy (invisArg (typeTypeOrConstraint res)) manyDataConTy arg res -mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type -mkFunTyMany af = mkFunTy af manyDataConTy +mkInvisFunTys :: HasDebugCallStack => [Type] -> Type -> Type +mkInvisFunTys args res + = foldr (mkFunTy af manyDataConTy) res args + where + af = invisArg (typeTypeOrConstraint res) --- | Special, common, case: Arrow type with mult Many -mkVisFunTyMany :: Type -> Type -> Type -mkVisFunTyMany = mkVisFunTy manyDataConTy +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 } -mkInvisFunTyMany :: Type -> Type -> Type -mkInvisFunTyMany = mkInvisFunTy manyDataConTy +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 + -- | Make nested arrow types -mkVisFunTys :: [Scaled Type] -> Type -> Type -mkVisFunTys tys ty = foldr (mkScaledFunTy VisArg) ty tys +-- | Special, common, case: Arrow type with mult Many +mkVisFunTyMany :: HasDebugCallStack => Type -> Type -> Type +-- Always TypeLike, multiplicity Many +mkVisFunTyMany = mkVisFunTy manyDataConTy mkVisFunTysMany :: [Type] -> Type -> Type +-- Always TypeLike, multiplicity Many mkVisFunTysMany tys ty = foldr mkVisFunTyMany ty tys -mkInvisFunTysMany :: [Type] -> Type -> Type -mkInvisFunTysMany tys ty = foldr mkInvisFunTyMany ty tys +--------------- +mkScaledFunTy :: HasDebugCallStack => FunTyFlag -> Scaled Type -> Type -> Type +mkScaledFunTy af (Scaled mult arg) res = mkFunTy af mult arg res +mkScaledFunTys :: HasDebugCallStack => [Scaled Type] -> Type -> Type +-- All visible args +-- Result type can be TypeLike or ConstraintLike +-- Example of the latter: dataConWrapperType for the data con of a class +mkScaledFunTys tys ty = foldr (mkScaledFunTy af) ty tys + 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 :: TyCoVar -> ArgFlag -> Type -> Type -mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty +mkForAllTy :: ForAllTyBinder -> Type -> Type +mkForAllTy = ForAllTy -- | Wraps foralls over the type using the provided 'TyCoVar's from left to right -mkForAllTys :: [TyCoVarBinder] -> Type -> Type +mkForAllTys :: [ForAllTyBinder] -> Type -> Type mkForAllTys tyvars ty = foldr ForAllTy ty tyvars -- | Wraps foralls over the type using the provided 'InvisTVBinder's from left to right mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type mkInvisForAllTys tyvars = mkForAllTys (tyVarSpecToBinders tyvars) -mkPiTy :: TyCoBinder -> Type -> Type -mkPiTy (Anon af ty1) ty2 = mkScaledFunTy af ty1 ty2 -mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty +mkPiTy :: PiTyBinder -> Type -> Type +mkPiTy (Anon ty1 af) ty2 = mkScaledFunTy af ty1 ty2 +mkPiTy (Named bndr) ty = mkForAllTy bndr ty -mkPiTys :: [TyCoBinder] -> Type -> Type +mkPiTys :: [PiTyBinder] -> Type -> Type mkPiTys tbs ty = foldr mkPiTy ty tbs -- | 'mkNakedTyConTy' creates a nullary 'TyConApp'. In general you @@ -1158,13 +960,15 @@ | ForAllCo TyCoVar KindCoercion Coercion -- ForAllCo :: _ -> N -> e -> e - | FunCo Role CoercionN Coercion Coercion -- lift FunTy - -- FunCo :: "e" -> N -> e -> e -> e - -- Note: why doesn't FunCo have a AnonArgFlag, like FunTy? - -- Because the AnonArgFlag has no impact on Core; it is only - -- there to guide implicit instantiation of Haskell source - -- types, and that is irrelevant for coercions, which are - -- Core-only. + | FunCo -- FunCo :: "e" -> N/P -> e -> e -> e + -- See Note [FunCo] for fco_afl, fco_afr + { fco_role :: Role + , fco_afl :: FunTyFlag -- Arrow for coercionLKind + , fco_afr :: FunTyFlag -- Arrow for coercionRKind + , fco_mult :: CoercionN + , fco_arg, fco_res :: Coercion } + -- (if the role "e" is Phantom, the first coercion is, too) + -- the first coercion is for the multiplicity -- These are special | CoVarCo CoVar -- :: _ -> (N or R) @@ -1191,14 +995,7 @@ | SymCo Coercion -- :: e -> e | TransCo Coercion Coercion -- :: e -> e -> e - | NthCo Role Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) - -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles]) - -- Using NthCo on a ForAllCo gives an N coercion always - -- See Note [NthCo and newtypes] - -- - -- Invariant: (NthCo r i co), it is always the case that r = role of (Nth i co) - -- That is: the role of the entire coercion is redundantly cached here. - -- See Note [NthCo Cached Roles] + | SelCo CoSel Coercion -- See Note [SelCo] | LRCo LeftOrRight CoercionN -- Decomposes (t_left t_right) -- :: _ -> N -> N @@ -1218,6 +1015,27 @@ -- Only present during typechecking deriving Data.Data +data CoSel -- See Note [SelCo] + = SelTyCon Int Role -- Decomposes (T co1 ... con); zero-indexed + -- Invariant: Given: SelCo (SelTyCon i r) co + -- we have r == tyConRole (coercionRole co) tc + -- and tc1 == tc2 + -- where T tc1 _ = coercionLKind co + -- T tc2 _ = coercionRKind co + -- See Note [SelCo] + + | SelFun FunSel -- Decomposes (co1 -> co2) + + | SelForAll -- Decomposes (forall a. co) + + deriving( Eq, Data.Data ) + +data FunSel -- See Note [SelCo] + = SelMult -- Multiplicity + | SelArg -- Argument of function + | SelRes -- Result of function + deriving( Eq, Data.Data ) + type CoercionN = Coercion -- always nominal type CoercionR = Coercion -- always representational type CoercionP = Coercion -- always phantom @@ -1226,6 +1044,36 @@ instance Outputable Coercion where 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) + +instance Outputable FunSel where + ppr SelMult = text "mult" + ppr SelArg = text "arg" + ppr SelRes = text "res" + +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 + put_ bh (SelFun SelMult) = putByte bh 2 + put_ bh (SelFun SelArg) = putByte bh 3 + put_ bh (SelFun SelRes) = putByte bh 4 + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { n <- get bh; r <- get bh; return (SelTyCon n r) } + 1 -> return SelForAll + 2 -> return (SelFun SelMult) + 3 -> return (SelFun SelArg) + _ -> return (SelFun SelRes) } + +instance NFData CoSel where + rnf (SelTyCon n r) = n `seq` r `seq` () + rnf SelForAll = () + rnf (SelFun fs) = fs `seq` () + -- | A semantically more meaningful type to represent what may or may not be a -- useful 'Coercion'. data MCoercion @@ -1246,7 +1094,7 @@ Invariant 1: Refl lifting Refl (similar for GRefl r ty MRefl) is always lifted as far as possible. For example - (Refl T) (Refl a) (Refl b) is normalised (by mkAPpCo) to (Refl (T a b)). + (Refl T) (Refl a) (Refl b) is normalised (by mkAppCo) to (Refl (T a b)). You might think that a consequences is: Every identity coercion has Refl at the root @@ -1298,6 +1146,72 @@ A nominal reflexive coercion is quite common, so we keep the special form Refl to save allocation. +Note [SelCo] +~~~~~~~~~~~~ +The Coercion form SelCo allows us to decompose a structural coercion, one +between ForallTys, or TyConApps, or FunTys. + +There are three forms, split by the CoSel field inside the SelCo: +SelTyCon, SelForAll, and SelFun. + +* 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 + i < n (i is zero-indexed) + ---------------------------------- + SelCo (SelTyCon i r) : si ~r ti + + "Not a newtype": see Note [SelCo and newtypes] + "Not an arrow type": see SelFun below + + See Note [SelCo Cached Roles] + +* SelForAll: + co : forall (a:k1).t1 ~r0 forall (a:k2).t2 + ---------------------------------- + SelCo SelForAll : k1 ~N k2 + + NB: SelForAll always gives a Nominal coercion. + +* The SelFun form, for functions, has three sub-forms for the three + components of the function type (multiplicity, argument, result). + + co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2) + r = funRole r0 SelMult + ---------------------------------- + SelCo (SelFun SelMult) : m1 ~r m2 + + co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2) + r = funRole r0 SelArg + ---------------------------------- + SelCo (SelFun SelArg) : s1 ~r s2 + + co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2) + r = funRole r0 SelRes + ---------------------------------- + SelCo (SelFun SelRes) : t1 ~r t2 + +Note [FunCo] +~~~~~~~~~~~~ +Just as FunTy has a ft_af :: FunTyFlag field, FunCo (which connects +two function types) has two FunTyFlag fields: + funco_afl, funco_afr :: FunTyFlag +In all cases, the FunTyFlag is recoverable from the kinds of the argument +and result types/coercions; but experiments show that it's better to +cache it. + +Why does FunCo need /two/ flags? If we have a single method class, +implemented as a newtype + class C a where { op :: [a] -> a } +then we can have a coercion + co :: C Int ~R ([Int]->Int) +So now we can define + FunCo co : (C Int => Bool) ~R (([Int]->Int) -> Bool) +Notice that the left and right arrows are different! Hence two flags, +one for coercionLKind and one for coercionRKind. + Note [Coercion axioms applied to coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The reason coercion axioms can be applied to coercions and not just @@ -1416,7 +1330,7 @@ This collapse is done by mkPredCo; there is no PredCo constructor in Coercion. This is important because we need Nth to work on predicates too: - Nth 1 ((~) [c] g) = g + SelCo (SelTyCon 1) ((~) [c] g) = g See Simplify.simplCoercionF, which generates such selections. Note [Roles] @@ -1530,7 +1444,7 @@ The rules here dictate the roles of the parameters to mkTyConAppCo (should be checked by Lint). -Note [NthCo and newtypes] +Note [SelCo and newtypes] ~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have @@ -1547,20 +1461,21 @@ co = NTCo:N a ; sym (NTCo:N b) for any `a` and `b`. Because of the role annotation on N, if we use -NthCo, we'll get out a representational coercion. That is: +SelCo, we'll get out a representational coercion. That is: - NthCo r 0 co :: forall a b. a ~R b + SelCo (SelTyCon 0 r) co :: forall a b. a ~r b Yikes! Clearly, this is terrible. The solution is simple: forbid -NthCo to be used on newtypes if the internal coercion is representational. +SelCo to be used on newtypes if the internal coercion is representational. +See the SelCo equation for GHC.Core.Lint.lintCoercion. This is not just some corner case discovered by a segfault somewhere; it was discovered in the proof of soundness of roles and described in the "Safe Coercions" paper (ICFP '14). -Note [NthCo Cached Roles] +Note [SelCo Cached Roles] ~~~~~~~~~~~~~~~~~~~~~~~~~ -Why do we cache the role of NthCo in the NthCo constructor? +Why do we cache the role of SelCo in the SelCo constructor? Because computing role(Nth i co) involves figuring out that co :: T tys1 ~ T tys2 @@ -1570,7 +1485,7 @@ we have to compute the kind and role of a coercion simultaneously, which makes the code complicated and inefficient. -This only happens for NthCo. Caching the role solves the problem, and +This only happens for SelCo. Caching the role solves the problem, and allows coercionKind and coercionRole to be simple. See #11735 @@ -1720,7 +1635,7 @@ holes are easier. - Moreover, nothing is lost from the lack of let-bindings. For - dictionaries want to achieve sharing to avoid recomoputing the + dictionaries want to achieve sharing to avoid recomputing the dictionary. But coercions are entirely erased, so there's little benefit to sharing. Indeed, even if we had a let-binding, we always inline types and coercions at every use site and drop the @@ -1886,7 +1801,7 @@ -- ^ What to do with coercion holes. -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". - , tcf_tycobinder :: env -> TyCoVar -> ArgFlag -> env + , tcf_tycobinder :: env -> TyCoVar -> ForAllTyFlag -> env -- ^ The returned env is used in the extended scope } @@ -1921,27 +1836,28 @@ go_cos _ [] = mempty go_cos env (c:cs) = go_co env c `mappend` go_cos env cs - go_co env (Refl ty) = go_ty env ty - go_co env (GRefl _ ty MRefl) = go_ty env ty - go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co - 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 (FunCo _ cw c1 c2) = go_co env cw `mappend` - 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 (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 (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 (NthCo _ _ 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 - go_co env (KindCo co) = go_co env co - go_co env (SubCo co) = go_co env co + go_co env (Refl ty) = go_ty env ty + go_co env (GRefl _ ty MRefl) = go_ty env ty + go_co env (GRefl _ ty (MCo co)) = go_ty env ty `mappend` go_co env co + 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 (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 (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 + go_co env (KindCo co) = go_co env co + go_co env (SubCo co) = go_co env co + + 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 kind_co `mappend` go_ty env (varType tv) `mappend` go_co env' co @@ -1991,17 +1907,17 @@ 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 (FunCo _ w co1 co2) = 1 + coercionSize co1 + coercionSize co2 - + coercionSize w +coercionSize (AppCo co arg) = coercionSize co + coercionSize arg +coercionSize (ForAllCo _ h 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 (SymCo co) = 1 + coercionSize co coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 -coercionSize (NthCo _ _ co) = 1 + coercionSize co +coercionSize (SelCo _ co) = 1 + coercionSize co coercionSize (LRCo _ co) = 1 + coercionSize co coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg coercionSize (KindCo co) = 1 + coercionSize co 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,28 +3,39 @@ import GHC.Utils.Outputable ( Outputable ) import Data.Data ( Data ) -import {-# SOURCE #-} GHC.Types.Var( Var, ArgFlag, AnonArgFlag ) +import {-# SOURCE #-} GHC.Types.Var( Var, VarBndr, ForAllTyFlag, FunTyFlag ) import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) data Type data Coercion +data CoSel data UnivCoProvenance data TyLit -data TyCoBinder data MCoercion data Scaled a +scaledThing :: Scaled a -> a + type Mult = Type type PredType = Type +type RuntimeRepType = Type type Kind = Type type ThetaType = [PredType] type CoercionN = Coercion type MCoercionN = MCoercion -mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type -mkForAllTy :: Var -> ArgFlag -> Type -> Type -mkNakedTyConTy :: TyCon -> Type +mkForAllTy :: VarBndr Var ForAllTyFlag -> Type -> Type +mkNakedTyConTy :: TyCon -> Type +mkNakedFunTy :: FunTyFlag -> Type -> Type -> Type -instance Data Type -- To support Data instances in GHC.Core.Coercion.Axiom + +-- To support Data instances in GHC.Core.Coercion.Axiom +instance Data Type + +-- To support instances PiTyBinder in Var +instance Data a => Data (Scaled a) + +-- To support debug pretty-printing instance Outputable Type +instance Outputable a => Outputable (Scaled a) 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 @@ -6,27 +6,25 @@ {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | Substitution into types and coercions. module GHC.Core.TyCo.Subst ( -- * Substitutions - TCvSubst(..), TvSubstEnv, CvSubstEnv, - emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, - emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, - mkTCvSubst, mkTvSubst, mkCvSubst, - getTvSubstEnv, - getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, - isInScope, elemTCvSubst, notElemTCvSubst, - setTvSubstEnv, setCvSubstEnv, zapTCvSubst, - extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv, + emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst, + emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst, + mkSubst, mkTvSubst, mkCvSubst, mkIdSubst, + getTvSubstEnv, getIdSubstEnv, + getCvSubstEnv, getSubstInScope, setInScope, getSubstRangeTyCoFVs, + isInScope, elemSubst, notElemSubst, zapSubst, + extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, extendTCvSubst, extendTCvSubstWithClone, extendCvSubst, extendCvSubstWithClone, extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, extendTvSubstList, extendTvSubstAndInScope, extendTCvSubstList, - unionTCvSubst, zipTyEnv, zipCoEnv, + unionSubst, zipTyEnv, zipCoEnv, zipTvSubst, zipCvSubst, zipTCvSubst, mkTvSubstPrs, @@ -45,9 +43,9 @@ substVarBndr, substVarBndrs, substTyVarBndr, substTyVarBndrs, substCoVarBndr, - substTyVar, substTyVars, substTyCoVars, - substTyCoBndr, - substForAllCoBndr, + substTyVar, substTyVars, substTyVarToTyVar, + substTyCoVars, + substTyCoBndr, substForAllCoBndr, substVarBndrUsing, substForAllCoBndrUsing, checkValidSubst, isValidTCvSubst, ) where @@ -55,16 +53,18 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Core.Type - ( mkCastTy, mkAppTy, isCoercionTy, mkTyConApp ) + ( mkCastTy, mkAppTy, isCoercionTy, mkTyConApp, getTyVar_maybe ) import {-# SOURCE #-} GHC.Core.Coercion - ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo + ( mkCoVarCo, mkKindCo, mkSelCo, mkTransCo , mkNomReflCo, mkSubCo, mkSymCo - , mkFunCo, mkForAllCo, mkUnivCo + , mkFunCo2, mkForAllCo, mkUnivCo , mkAxiomInstCo, mkAppCo, mkGReflCo , mkInstCo, mkLRCo, mkTyConAppCo , mkCoercionType , coercionKind, coercionLKind, coVarKindsTypesRole ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar ) +import {-# SOURCE #-} GHC.Core.Ppr ( ) +import {-# SOURCE #-} GHC.Core ( CoreExpr ) import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs @@ -95,28 +95,34 @@ %************************************************************************ -} --- | Type & coercion substitution --- --- #tcvsubst_invariant# --- The following invariants must hold of a 'TCvSubst': --- --- 1. The in-scope set is needed /only/ to --- guide the generation of fresh uniques --- --- 2. In particular, the /kind/ of the type variables in --- the in-scope set is not relevant +-- | Type & coercion & id substitution -- --- 3. The substitution is only applied ONCE! This is because --- in general such application will not reach a fixed point. -data TCvSubst - = TCvSubst InScopeSet -- The in-scope type and kind variables - TvSubstEnv -- Substitutes both type and kind variables - CvSubstEnv -- Substitutes coercion variables - -- See Note [Substitutions apply only once] - -- and Note [Extending the TCvSubstEnv] - -- and Note [Substituting types and coercions] - -- and Note [The substitution invariant] +-- The "Subst" data type defined in this module contains substitution +-- for tyvar, covar and id. However, operations on IdSubstEnv (mapping +-- from "Id" to "CoreExpr") that require the definition of the "Expr" +-- data type are defined in GHC.Core.Subst to avoid circular module +-- dependency. +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 + -- INVARIANT 1: See Note [The substitution invariant] + -- This is what lets us deal with name capture properly + -- + -- INVARIANT 2: The substitution is apply-once; + -- see Note [Substitutions apply only once] + -- + -- INVARIANT 3: See Note [Extending the IdSubstEnv] in "GHC.Core.Subst" + -- and Note [Extending the TvSubstEnv and CvSubstEnv] + -- + -- INVARIANT 4: See Note [Substituting types, coercions, and expressions] + +-- | A substitution of 'Expr's for non-coercion 'Id's +type IdSubstEnv = IdEnv CoreExpr -- Domain is NonCoVarIds, i.e. not coercions + -- | A substitution of 'Type's for 'TyVar's -- and 'Kind's for 'KindVar's type TvSubstEnv = TyVarEnv Type @@ -139,8 +145,6 @@ (SIa) The free vars of the range of the substitution (SIb) The free vars of ty minus the domain of the substitution -The same rules apply to other substitutions (notably GHC.Core.Subst.Subst) - * Reason for (SIa). Consider substTy [a :-> Maybe b] (forall b. b->a) we must rename the forall b, to get @@ -179,7 +183,7 @@ A TCvSubst is not idempotent, but, unlike the non-idempotent substitution we use during unifications, it must not be repeatedly applied. -Note [Extending the TCvSubstEnv] +Note [Extending the TvSubstEnv and CvSubstEnv] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See #tcvsubst_invariant# for the invariants that must hold. @@ -203,128 +207,150 @@ * In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty -Note [Substituting types and coercions] +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. -However, the constructor used to create type variables is distinct from -that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note -that it would be possible to use the CoercionTy constructor to combine -these environments, but that seems like a false economy. +Likewise, expressions may contain type variables or coercion variables. +However, we use different constructors for constructing expression variables, +coercion variables, and type variables, so we carry three VarEnvs for each +variable type. Note that it would be possible to use the CoercionTy constructor +and the Type constructor to combine these environments, but that seems like a +false economy. -Note that the TvSubstEnv should *never* map a CoVar (built with the Id -constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, -the range of the TvSubstEnv should *never* include a type headed with +Note that the domain of the VarEnvs must be respected, despite the fact that +TyVar, Id, and CoVar are all type synonyms of the Var type. For example, +TvSubstEnv should *never* map a CoVar (built with the Id constructor) +and the CvSubstEnv should *never* map a TyVar. Furthermore, the range +of the TvSubstEnv should *never* include a type headed with CoercionTy. -} +emptyIdSubstEnv :: IdSubstEnv +emptyIdSubstEnv = emptyVarEnv + emptyTvSubstEnv :: TvSubstEnv emptyTvSubstEnv = emptyVarEnv emptyCvSubstEnv :: CvSubstEnv emptyCvSubstEnv = emptyVarEnv -composeTCvSubstEnv :: InScopeSet - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) - -> (TvSubstEnv, CvSubstEnv) --- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. --- It assumes that both are idempotent. --- Typically, @env1@ is the refinement to a base substitution @env2@ -composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) - = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 - , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) - -- First apply env1 to the range of env2 - -- Then combine the two, making sure that env1 loses if - -- both bind the same variable; that's why env1 is the - -- *left* argument to plusVarEnv, because the right arg wins - where - subst1 = TCvSubst in_scope tenv1 cenv1 - -- | Composes two substitutions, applying the second one provided first, --- like in function composition. -composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst -composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) - = TCvSubst is3 tenv3 cenv3 +-- like in function composition. This function leaves IdSubstEnv untouched +-- because IdSubstEnv is not used during substitution for types. +composeTCvSubst :: Subst -> Subst -> Subst +composeTCvSubst subst1@(Subst is1 ids1 tenv1 cenv1) (Subst is2 _ tenv2 cenv2) + = Subst is3 ids1 tenv3 cenv3 where is3 = is1 `unionInScope` is2 - (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) + tenv3 = tenv1 `plusVarEnv` mapVarEnv (substTy extended_subst1) tenv2 + cenv3 = cenv1 `plusVarEnv` mapVarEnv (substCo extended_subst1) cenv2 -emptyTCvSubst :: TCvSubst -emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv + -- Make sure the in-scope set in the first substitution is wide enough to + -- cover the free variables in the range of the second substitution before + -- applying it (#22235). + extended_subst1 = subst1 `setInScope` is3 -mkEmptyTCvSubst :: InScopeSet -> TCvSubst -mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv +emptySubst :: Subst +emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv -isEmptyTCvSubst :: TCvSubst -> Bool - -- See Note [Extending the TCvSubstEnv] -isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv +mkEmptySubst :: InScopeSet -> Subst +mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv -mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst -mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv +isEmptySubst :: Subst -> Bool +isEmptySubst (Subst _ id_env tv_env cv_env) + = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env -mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst +-- | Checks whether the tyvar and covar environments are empty. +-- This function should be used over 'isEmptySubst' when substituting +-- for types, because types currently do not contain expressions; we can +-- safely disregard the expression environment when deciding whether +-- to skip a substitution. Using 'isEmptyTCvSubst' gives us a non-trivial +-- performance boost (up to 70% less allocation for T18223) +isEmptyTCvSubst :: Subst -> Bool +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 + +mkIdSubst :: InScopeSet -> IdSubstEnv -> Subst +mkIdSubst in_scope ids = Subst in_scope ids emptyTvSubstEnv emptyCvSubstEnv + +mkTvSubst :: InScopeSet -> TvSubstEnv -> Subst -- ^ Make a TCvSubst with specified tyvar subst and empty covar subst -mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv +mkTvSubst in_scope tenv = Subst in_scope emptyIdSubstEnv tenv emptyCvSubstEnv -mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst +mkCvSubst :: InScopeSet -> CvSubstEnv -> Subst -- ^ Make a TCvSubst with specified covar subst and empty tyvar subst -mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv +mkCvSubst in_scope cenv = Subst in_scope emptyIdSubstEnv emptyTvSubstEnv cenv -getTvSubstEnv :: TCvSubst -> TvSubstEnv -getTvSubstEnv (TCvSubst _ env _) = env +getIdSubstEnv :: Subst -> IdSubstEnv +getIdSubstEnv (Subst _ ids _ _) = ids -getCvSubstEnv :: TCvSubst -> CvSubstEnv -getCvSubstEnv (TCvSubst _ _ env) = env +getTvSubstEnv :: Subst -> TvSubstEnv +getTvSubstEnv (Subst _ _ tenv _) = tenv -getTCvInScope :: TCvSubst -> InScopeSet -getTCvInScope (TCvSubst in_scope _ _) = in_scope +getCvSubstEnv :: Subst -> CvSubstEnv +getCvSubstEnv (Subst _ _ _ cenv) = cenv +-- | Find the in-scope set: see Note [The substitution invariant] +getSubstInScope :: Subst -> InScopeSet +getSubstInScope (Subst in_scope _ _ _) = in_scope + +setInScope :: Subst -> InScopeSet -> Subst +setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs + -- | Returns the free variables of the types in the range of a substitution as -- a non-deterministic set. -getTCvSubstRangeFVs :: TCvSubst -> VarSet -getTCvSubstRangeFVs (TCvSubst _ tenv cenv) - = unionVarSet tenvFVs cenvFVs +getSubstRangeTyCoFVs :: Subst -> VarSet +getSubstRangeTyCoFVs (Subst _ _ tenv cenv) + = tenvFVs `unionVarSet` cenvFVs where tenvFVs = shallowTyCoVarsOfTyVarEnv tenv cenvFVs = shallowTyCoVarsOfCoVarEnv cenv -isInScope :: Var -> TCvSubst -> Bool -isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope +isInScope :: Var -> Subst -> Bool +isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope -elemTCvSubst :: Var -> TCvSubst -> Bool -elemTCvSubst v (TCvSubst _ tenv cenv) +elemSubst :: Var -> Subst -> Bool +elemSubst v (Subst _ ids tenv cenv) | isTyVar v = v `elemVarEnv` tenv - | otherwise + | isCoVar v = v `elemVarEnv` cenv - -notElemTCvSubst :: Var -> TCvSubst -> Bool -notElemTCvSubst v = not . elemTCvSubst v - -setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst -setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv + | otherwise + = v `elemVarEnv` ids -setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst -setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv +notElemSubst :: Var -> Subst -> Bool +notElemSubst v = not . elemSubst v -zapTCvSubst :: TCvSubst -> TCvSubst -zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv +-- | Remove all substitutions that might have been built up +-- while preserving the in-scope set +-- originally called zapSubstEnv +zapSubst :: Subst -> Subst +zapSubst (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv -extendTCvInScope :: TCvSubst -> Var -> TCvSubst -extendTCvInScope (TCvSubst in_scope tenv cenv) var - = TCvSubst (extendInScopeSet in_scope var) tenv cenv +-- | Add the 'Var' to the in-scope set +extendSubstInScope :: Subst -> Var -> Subst +extendSubstInScope (Subst in_scope ids tvs cvs) v + = Subst (in_scope `extendInScopeSet` v) + ids tvs cvs -extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst -extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv +-- | Add the 'Var's to the in-scope set: see also 'extendInScope' +extendSubstInScopeList :: Subst -> [Var] -> Subst +extendSubstInScopeList (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + ids tvs cvs -extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst -extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars - = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv +-- | Add the 'Var's to the in-scope set: see also 'extendInScope' +extendSubstInScopeSet :: Subst -> VarSet -> Subst +extendSubstInScopeSet (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetSet` vs) + ids tvs cvs -extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst +extendTCvSubst :: Subst -> TyCoVar -> Type -> Subst extendTCvSubst subst v ty | isTyVar v = extendTvSubst subst v ty @@ -333,102 +359,119 @@ | otherwise = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) -extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst +extendTCvSubstWithClone :: Subst -> TyCoVar -> TyCoVar -> Subst extendTCvSubstWithClone subst tcv | isTyVar tcv = extendTvSubstWithClone subst tcv | otherwise = extendCvSubstWithClone subst tcv -extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst -extendTvSubst (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv +-- | Add a substitution for a 'TyVar' to the 'Subst' +-- The 'TyVar' *must* be a real TyVar, and not a CoVar +-- You must ensure that the in-scope set is such that +-- Note [The substitution invariant] holds +-- after extending the substitution like this. +extendTvSubst :: Subst -> TyVar -> Type -> Subst +extendTvSubst (Subst in_scope ids tvs cvs) tv ty + = assert (isTyVar tv) $ + Subst in_scope ids (extendVarEnv tvs tv ty) cvs -extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst +extendTvSubstBinderAndInScope :: Subst -> PiTyBinder -> Type -> Subst extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty = assert (isTyVar v ) extendTvSubstAndInScope subst v ty extendTvSubstBinderAndInScope subst (Anon {}) _ = subst -extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst --- Adds a new tv -> tv mapping, /and/ extends the in-scope set -extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv' - = TCvSubst (extendInScopeSetSet in_scope new_in_scope) +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 - where - new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv' -extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst -extendCvSubst (TCvSubst in_scope tenv cenv) v co - = TCvSubst in_scope tenv (extendVarEnv cenv v co) +-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': +-- you must ensure that the in-scope set satisfies +-- Note [The substitution invariant] +-- after extending the substitution like this +extendCvSubst :: Subst -> CoVar -> Coercion -> Subst +extendCvSubst (Subst in_scope ids tvs cvs) v r + = assert (isCoVar v) $ + Subst in_scope ids tvs (extendVarEnv cvs v r) -extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst -extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv' - = TCvSubst (extendInScopeSetSet in_scope new_in_scope) +extendCvSubstWithClone :: Subst -> CoVar -> CoVar -> Subst +extendCvSubstWithClone (Subst in_scope ids tenv cenv) cv cv' + = Subst (extendInScopeSetSet in_scope new_in_scope) + ids tenv (extendVarEnv cenv cv (mkCoVarCo cv')) where new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' -extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst +extendTvSubstAndInScope :: Subst -> TyVar -> Type -> Subst -- Also extends the in-scope set -extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty - = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) +extendTvSubstAndInScope (Subst in_scope ids tenv cenv) tv ty + = Subst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) + ids (extendVarEnv tenv tv ty) cenv -extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst -extendTvSubstList subst tvs tys - = foldl2 extendTvSubst subst tvs tys +-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' +extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst +extendTvSubstList subst vrs + = foldl' extend subst vrs + where + extend subst (v, r) = extendTvSubst subst v r -extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTCvSubstList :: Subst -> [Var] -> [Type] -> Subst extendTCvSubstList subst tvs tys = foldl2 extendTCvSubst subst tvs tys -unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +unionSubst :: Subst -> Subst -> Subst -- Works when the ranges are disjoint -unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) - = assert (tenv1 `disjointVarEnv` tenv2 +unionSubst (Subst in_scope1 ids1 tenv1 cenv1) (Subst in_scope2 ids2 tenv2 cenv2) + = assert (ids1 `disjointVarEnv` ids2 + && tenv1 `disjointVarEnv` tenv2 && cenv1 `disjointVarEnv` cenv2 ) - TCvSubst (in_scope1 `unionInScope` in_scope2) - (tenv1 `plusVarEnv` tenv2) - (cenv1 `plusVarEnv` cenv2) - --- mkTvSubstPrs and zipTvSubst generate the in-scope set from --- the types given; but it's just a thunk so with a bit of luck --- it'll never be evaluated + Subst (in_scope1 `unionInScope` in_scope2) + (ids1 `plusVarEnv` ids2) + (tenv1 `plusVarEnv` tenv2) + (cenv1 `plusVarEnv` cenv2) --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming --- environment. No CoVars, please! -zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst +-- | Generates the in-scope set for the 'Subst' from the types in the incoming +-- environment. No CoVars or Ids, please! +zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> Subst zipTvSubst tvs tys = mkTvSubst (mkInScopeSet (shallowTyCoVarsOfTypes tys)) tenv where tenv = zipTyEnv tvs tys --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- | Generates the in-scope set for the 'Subst' from the types in the incoming -- environment. No TyVars, please! -zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst +zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> Subst zipCvSubst cvs cos - = TCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) emptyTvSubstEnv cenv + = mkCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) cenv where cenv = zipCoEnv cvs cos -zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst + +zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> Subst zipTCvSubst tcvs tys = zip_tcvsubst tcvs tys $ - mkEmptyTCvSubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys - where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst + mkEmptySubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys + where zip_tcvsubst :: [TyCoVar] -> [Type] -> Subst -> Subst zip_tcvsubst (tv:tvs) (ty:tys) subst = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) zip_tcvsubst [] [] subst = subst -- empty case zip_tcvsubst _ _ _ = pprPanic "zipTCvSubst: length mismatch" - (ppr tcvs <+> ppr tys) + (ppr tcvs <+> ppr tys) -- | Generates the in-scope set for the 'TCvSubst' from the types in the --- incoming environment. No CoVars, please! -mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst -mkTvSubstPrs [] = emptyTCvSubst +-- incoming environment. No CoVars, please! The InScopeSet is just a thunk +-- so with a bit of luck it'll never be evaluated +mkTvSubstPrs :: [(TyVar, Type)] -> Subst +mkTvSubstPrs [] = emptySubst mkTvSubstPrs prs = assertPpr onlyTyVarsAndNoCoercionTy (text "prs" <+> ppr prs) $ mkTvSubst in_scope tenv @@ -438,6 +481,7 @@ and [ isTyVar tv && not (isCoercionTy ty) | (tv, ty) <- prs ] +-- | The InScopeSet is just a thunk so with a bit of luck it'll never be evaluated zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv zipTyEnv tyvars tys | debugIsOn @@ -467,13 +511,18 @@ | otherwise = mkVarEnv (zipEqual "zipCoEnv" cvs cos) -instance Outputable TCvSubst where - ppr (TCvSubst ins tenv cenv) - = brackets $ sep[ text "TCvSubst", - nest 2 (text "In scope:" <+> ppr ins), - nest 2 (text "Type env:" <+> ppr tenv), - nest 2 (text "Co env:" <+> ppr cenv) ] +-- Pretty printing, for debugging only +instance Outputable Subst where + ppr (Subst in_scope ids tvs cvs) + = text " in_scope_doc + $$ text " IdSubst =" <+> ppr ids + $$ text " TvSubst =" <+> ppr tvs + $$ text " CvSubst =" <+> ppr cvs + <> char '>' + where + in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr) + {- %************************************************************************ %* * @@ -614,16 +663,17 @@ -- 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 :: TCvSubst -> Type -> Type +substTyAddInScope :: Subst -> Type -> Type substTyAddInScope subst ty = - substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty + substTy (extendSubstInScopeSet subst $ tyCoVarsOfType ty) ty -- | When calling `substTy` it should be the case that the in-scope set in -- the substitution is a superset of the free vars of the range of the -- substitution. -- See also Note [The substitution invariant]. -isValidTCvSubst :: TCvSubst -> Bool -isValidTCvSubst (TCvSubst in_scope tenv cenv) = +-- TODO: take into account ids and rename as isValidSubst +isValidTCvSubst :: Subst -> Bool +isValidTCvSubst (Subst in_scope _ tenv cenv) = (tenvFVs `varSetInScope` in_scope) && (cenvFVs `varSetInScope` in_scope) where @@ -632,8 +682,8 @@ -- | This checks if the substitution satisfies the invariant from -- Note [The substitution invariant]. -checkValidSubst :: HasDebugCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a -checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a +checkValidSubst :: HasDebugCallStack => Subst -> [Type] -> [Coercion] -> a -> a +checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos a = assertPpr (isValidTCvSubst subst) (text "in_scope" <+> ppr in_scope $$ text "tenv" <+> ppr tenv $$ @@ -663,9 +713,9 @@ -- | Substitute within a 'Type' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substTy :: HasDebugCallStack => TCvSubst -> Type -> Type +substTy :: HasDebugCallStack => Subst -> Type -> Type substTy subst ty - | isEmptyTCvSubst subst = ty + | isEmptyTCvSubst subst = ty | otherwise = checkValidSubst subst [ty] [] $ subst_ty subst ty @@ -674,26 +724,26 @@ -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTyUnchecked to -- substTy and remove this function. Please don't use in new code. -substTyUnchecked :: TCvSubst -> Type -> Type +substTyUnchecked :: Subst -> Type -> Type substTyUnchecked subst ty - | isEmptyTCvSubst subst = ty + | isEmptyTCvSubst subst = ty | otherwise = subst_ty subst ty -substScaledTy :: HasDebugCallStack => TCvSubst -> Scaled Type -> Scaled Type +substScaledTy :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type substScaledTy subst scaled_ty = mapScaledType (substTy subst) scaled_ty -substScaledTyUnchecked :: HasDebugCallStack => TCvSubst -> Scaled Type -> Scaled Type +substScaledTyUnchecked :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type substScaledTyUnchecked subst scaled_ty = mapScaledType (substTyUnchecked subst) scaled_ty -- | Substitute within several 'Type's -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substTys :: HasDebugCallStack => TCvSubst -> [Type] -> [Type] +substTys :: HasDebugCallStack => Subst -> [Type] -> [Type] substTys subst tys | isEmptyTCvSubst subst = tys | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys -substScaledTys :: HasDebugCallStack => TCvSubst -> [Scaled Type] -> [Scaled Type] +substScaledTys :: HasDebugCallStack => Subst -> [Scaled Type] -> [Scaled Type] substScaledTys subst scaled_tys | isEmptyTCvSubst subst = scaled_tys | otherwise = checkValidSubst subst (map scaledMult scaled_tys ++ map scaledThing scaled_tys) [] $ @@ -704,12 +754,12 @@ -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTysUnchecked to -- substTys and remove this function. Please don't use in new code. -substTysUnchecked :: TCvSubst -> [Type] -> [Type] +substTysUnchecked :: Subst -> [Type] -> [Type] substTysUnchecked subst tys | isEmptyTCvSubst subst = tys | otherwise = map (subst_ty subst) tys -substScaledTysUnchecked :: TCvSubst -> [Scaled Type] -> [Scaled Type] +substScaledTysUnchecked :: Subst -> [Scaled Type] -> [Scaled Type] substScaledTysUnchecked subst tys | isEmptyTCvSubst subst = tys | otherwise = map (mapScaledType (subst_ty subst)) tys @@ -717,7 +767,7 @@ -- | Substitute within a 'ThetaType' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substTheta :: HasDebugCallStack => TCvSubst -> ThetaType -> ThetaType +substTheta :: HasDebugCallStack => Subst -> ThetaType -> ThetaType substTheta = substTys -- | Substitute within a 'ThetaType' disabling the sanity checks. @@ -725,11 +775,11 @@ -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substThetaUnchecked to -- substTheta and remove this function. Please don't use in new code. -substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType +substThetaUnchecked :: Subst -> ThetaType -> ThetaType substThetaUnchecked = substTysUnchecked -subst_ty :: TCvSubst -> Type -> Type +subst_ty :: Subst -> Type -> Type -- subst_ty is the main workhorse for type substitution -- -- Note that the in_scope set is poked only if we hit a forall @@ -762,34 +812,44 @@ go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) go (CoercionTy co) = CoercionTy $! (subst_co subst co) -substTyVar :: TCvSubst -> TyVar -> Type -substTyVar (TCvSubst _ tenv _) tv +substTyVar :: Subst -> TyVar -> Type +substTyVar (Subst _ _ tenv _) tv = assert (isTyVar tv) $ case lookupVarEnv tenv tv of Just ty -> ty Nothing -> TyVarTy tv -substTyVars :: TCvSubst -> [TyVar] -> [Type] +substTyVarToTyVar :: HasDebugCallStack => Subst -> TyVar -> TyVar +-- Apply the substitution, expecing the result to be a TyVarTy +substTyVarToTyVar (Subst _ _ tenv _) tv + = assert (isTyVar tv) $ + case lookupVarEnv tenv tv of + Just ty -> case getTyVar_maybe ty of + Just tv -> tv + Nothing -> pprPanic "substTyVarToTyVar" (ppr tv $$ ppr ty) + Nothing -> tv + +substTyVars :: Subst -> [TyVar] -> [Type] substTyVars subst = map $ substTyVar subst -substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type] +substTyCoVars :: Subst -> [TyCoVar] -> [Type] substTyCoVars subst = map $ substTyCoVar subst -substTyCoVar :: TCvSubst -> TyCoVar -> Type +substTyCoVar :: Subst -> TyCoVar -> Type substTyCoVar subst tv | isTyVar tv = substTyVar subst tv | otherwise = CoercionTy $ substCoVar subst tv -lookupTyVar :: TCvSubst -> TyVar -> Maybe Type - -- See Note [Extending the TCvSubst] -lookupTyVar (TCvSubst _ tenv _) tv +lookupTyVar :: Subst -> TyVar -> Maybe Type + -- See Note [Extending the TvSubstEnv and CvSubstEnv] +lookupTyVar (Subst _ _ tenv _) tv = assert (isTyVar tv ) lookupVarEnv tenv tv -- | Substitute within a 'Coercion' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substCo :: HasDebugCallStack => TCvSubst -> Coercion -> Coercion +substCo :: HasDebugCallStack => Subst -> Coercion -> Coercion substCo subst co | isEmptyTCvSubst subst = co | otherwise = checkValidSubst subst [] [co] $ subst_co subst co @@ -799,7 +859,7 @@ -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substCoUnchecked to -- substCo and remove this function. Please don't use in new code. -substCoUnchecked :: TCvSubst -> Coercion -> Coercion +substCoUnchecked :: Subst -> Coercion -> Coercion substCoUnchecked subst co | isEmptyTCvSubst subst = co | otherwise = subst_co subst co @@ -807,12 +867,12 @@ -- | Substitute within several 'Coercion's -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant]. -substCos :: HasDebugCallStack => TCvSubst -> [Coercion] -> [Coercion] +substCos :: HasDebugCallStack => Subst -> [Coercion] -> [Coercion] substCos subst cos | isEmptyTCvSubst subst = cos | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos -subst_co :: TCvSubst -> Coercion -> Coercion +subst_co :: Subst -> Coercion -> Coercion subst_co subst co = go co where @@ -833,14 +893,14 @@ = case substForAllCoBndrUnchecked subst tv kind_co of (subst', tv', kind_co') -> ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co - go (FunCo r w co1 co2) = ((mkFunCo r $! go w) $! go co1) $! go co2 + 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 (SymCo co) = mkSymCo $! (go co) go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) - go (NthCo r d co) = mkNthCo r d $! (go co) + go (SelCo d co) = mkSelCo d $! (go co) go (LRCo lr co) = mkLRCo lr $! (go co) go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg go (KindCo co) = mkKindCo $! (go co) @@ -858,8 +918,8 @@ go_hole h@(CoercionHole { ch_co_var = cv }) = h { ch_co_var = updateVarType go_ty cv } -substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndr :: Subst -> TyCoVar -> KindCoercion + -> (Subst, TyCoVar, Coercion) substForAllCoBndr subst = substForAllCoBndrUsing False (substCo subst) subst @@ -868,27 +928,27 @@ -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substCoUnchecked to -- substCo and remove this function. Please don't use in new code. -substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion + -> (Subst, TyCoVar, Coercion) substForAllCoBndrUnchecked subst = substForAllCoBndrUsing False (substCoUnchecked subst) subst -- See Note [Sym and ForAllCo] substForAllCoBndrUsing :: Bool -- apply sym to binder? -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> TyCoVar -> KindCoercion - -> (TCvSubst, TyCoVar, KindCoercion) + -> 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 substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> TyVar -> KindCoercion - -> (TCvSubst, TyVar, KindCoercion) -substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co + -> Subst -> TyVar -> KindCoercion + -> (Subst, TyVar, KindCoercion) +substForAllCoTyVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) old_var old_kind_co = assert (isTyVar old_var ) - ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv + ( 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 @@ -912,12 +972,12 @@ substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> CoVar -> KindCoercion - -> (TCvSubst, CoVar, KindCoercion) -substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) + -> Subst -> CoVar -> KindCoercion + -> (Subst, CoVar, KindCoercion) +substForAllCoCoVarBndrUsing sym sco (Subst in_scope idenv tenv cenv) old_var old_kind_co = assert (isCoVar old_var ) - ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv + ( 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 @@ -935,31 +995,31 @@ new_var_type | sym = h2 | otherwise = h1 -substCoVar :: TCvSubst -> CoVar -> Coercion -substCoVar (TCvSubst _ _ cenv) cv +substCoVar :: Subst -> CoVar -> Coercion +substCoVar (Subst _ _ _ cenv) cv = case lookupVarEnv cenv cv of Just co -> co Nothing -> CoVarCo cv -substCoVars :: TCvSubst -> [CoVar] -> [Coercion] +substCoVars :: Subst -> [CoVar] -> [Coercion] substCoVars subst cvs = map (substCoVar subst) cvs -lookupCoVar :: TCvSubst -> Var -> Maybe Coercion -lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v +lookupCoVar :: Subst -> Var -> Maybe Coercion +lookupCoVar (Subst _ _ _ cenv) v = lookupVarEnv cenv v -substTyVarBndr :: HasDebugCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndr :: HasDebugCallStack => Subst -> TyVar -> (Subst, TyVar) substTyVarBndr = substTyVarBndrUsing substTy -substTyVarBndrs :: HasDebugCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) +substTyVarBndrs :: HasDebugCallStack => Subst -> [TyVar] -> (Subst, [TyVar]) substTyVarBndrs = mapAccumL substTyVarBndr -substVarBndr :: HasDebugCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndr :: HasDebugCallStack => Subst -> TyCoVar -> (Subst, TyCoVar) substVarBndr = substVarBndrUsing substTy -substVarBndrs :: HasDebugCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) +substVarBndrs :: HasDebugCallStack => Subst -> [TyCoVar] -> (Subst, [TyCoVar]) substVarBndrs = mapAccumL substVarBndr -substCoVarBndr :: HasDebugCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndr :: HasDebugCallStack => Subst -> CoVar -> (Subst, CoVar) substCoVarBndr = substCoVarBndrUsing substTy -- | Like 'substVarBndr', but disables sanity checks. @@ -967,11 +1027,11 @@ -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTyUnchecked to -- substTy and remove this function. Please don't use in new code. -substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUnchecked :: Subst -> TyCoVar -> (Subst, TyCoVar) substVarBndrUnchecked = substVarBndrUsing substTyUnchecked -substVarBndrUsing :: (TCvSubst -> Type -> Type) - -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUsing :: (Subst -> Type -> Type) + -> Subst -> TyCoVar -> (Subst, TyCoVar) substVarBndrUsing subst_fn subst v | isTyVar v = substTyVarBndrUsing subst_fn subst v | otherwise = substCoVarBndrUsing subst_fn subst v @@ -980,12 +1040,12 @@ -- extended subst and a new tyvar. -- Use the supplied function to substitute in the kind substTyVarBndrUsing - :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind - -> TCvSubst -> TyVar -> (TCvSubst, TyVar) -substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + :: (Subst -> Type -> Type) -- ^ Use this to substitute in the kind + -> Subst -> TyVar -> (Subst, TyVar) +substTyVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var = assertPpr _no_capture (pprTyVar old_var $$ pprTyVar new_var $$ ppr subst) $ assert (isTyVar old_var ) - (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) + (Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv, new_var) where new_env | no_change = delVarEnv tenv old_var | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) @@ -998,7 +1058,7 @@ no_change = no_kind_change && (new_var == old_var) -- no_change means that the new_var is identical in -- all respects to the old_var (same unique, same kind) - -- See Note [Extending the TCvSubst] + -- See Note [Extending the TvSubstEnv and CvSubstEnv] -- -- In that case we don't need to extend the substitution -- to map old to new. But instead we must zap any @@ -1015,11 +1075,11 @@ -- extended subst and a new covar. -- Use the supplied function to substitute in the kind substCoVarBndrUsing - :: (TCvSubst -> Type -> Type) - -> TCvSubst -> CoVar -> (TCvSubst, CoVar) -substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + :: (Subst -> Type -> Type) + -> Subst -> CoVar -> (Subst, CoVar) +substCoVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var = assert (isCoVar old_var) - (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) + (Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv, new_var) where new_co = mkCoVarCo new_var no_kind_change = noFreeVarsOfTypes [t1, t2] @@ -1038,11 +1098,14 @@ -- It's important to do the substitution for coercions, -- because they can have free type variables -cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) -cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq +cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) +cloneTyVarBndr subst@(Subst in_scope id_env tv_env cv_env) tv uniq = assertPpr (isTyVar tv) (ppr tv) -- I think it's only called on TyVars - (TCvSubst (extendInScopeSet in_scope tv') - (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') + ( Subst (extendInScopeSet in_scope tv') + id_env + (extendVarEnv tv_env tv (mkTyVarTy tv')) + cv_env + , tv') where old_ki = tyVarKind tv no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed @@ -1052,7 +1115,7 @@ tv' = setVarUnique tv1 uniq -cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) +cloneTyVarBndrs :: Subst -> [TyVar] -> UniqSupply -> (Subst, [TyVar]) cloneTyVarBndrs subst [] _usupply = (subst, []) cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) where @@ -1060,9 +1123,8 @@ (subst' , tv ) = cloneTyVarBndr subst t uniq (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' -substTyCoBndr :: TCvSubst -> TyCoBinder -> (TCvSubst, TyCoBinder) -substTyCoBndr subst (Anon af ty) = (subst, Anon af (substScaledTy subst ty)) +substTyCoBndr :: Subst -> PiTyBinder -> (Subst, PiTyBinder) +substTyCoBndr subst (Anon ty af) = (subst, Anon (substScaledTy subst ty) af) substTyCoBndr subst (Named (Bndr tv vis)) = (subst', Named (Bndr tv' vis)) where (subst', tv') = substVarBndr subst tv - 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,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | Tidying types and coercions for printing in error messages. @@ -13,10 +12,11 @@ tidyTyCoVarOcc, tidyTopType, tidyCo, tidyCos, - tidyTyCoVarBinder, tidyTyCoVarBinders + tidyForAllTyBinder, tidyForAllTyBinders ) where import GHC.Prelude +import GHC.Data.FastString import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList) @@ -70,24 +70,24 @@ -- this way is a helpful clue for users getHelpfulOccName tv | isSystemName name, isTcTyVar tv - = mkTyVarOcc (occNameString occ ++ "0") + = mkTyVarOccFS (occNameFS occ `appendFS` fsLit "0") | otherwise = occ where name = varName tv occ = getOccName name -tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis +tidyForAllTyBinder :: TidyEnv -> VarBndr TyCoVar vis -> (TidyEnv, VarBndr TyCoVar vis) -tidyTyCoVarBinder tidy_env (Bndr tv vis) +tidyForAllTyBinder tidy_env (Bndr tv vis) = (tidy_env', Bndr tv' vis) where (tidy_env', tv') = tidyVarBndr tidy_env tv -tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis] +tidyForAllTyBinders :: TidyEnv -> [VarBndr TyCoVar vis] -> (TidyEnv, [VarBndr TyCoVar vis]) -tidyTyCoVarBinders tidy_env tvbs - = mapAccumL tidyTyCoVarBinder +tidyForAllTyBinders tidy_env tvbs + = mapAccumL tidyForAllTyBinder (avoidNameClashes (binderVars tvbs) tidy_env) tvbs --------------- @@ -174,14 +174,14 @@ -- The following two functions differ from mkForAllTys and splitForAllTyCoVars in that --- they expect/preserve the ArgFlag argument. These belong to "GHC.Core.Type", but +-- they expect/preserve the ForAllTyFlag argument. These belong to "GHC.Core.Type", but -- how should they be named? -mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type +mkForAllTys' :: [(TyCoVar, ForAllTyFlag)] -> Type -> Type mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs where strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty -splitForAllTyCoVars' :: Type -> ([TyCoVar], [ArgFlag], Type) +splitForAllTyCoVars' :: Type -> ([TyCoVar], [ForAllTyFlag], Type) splitForAllTyCoVars' ty = go ty [] [] where go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) @@ -232,7 +232,7 @@ 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 w co1 co2) = ((FunCo r $! go w) $! go co1) $! go co2 + 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' @@ -242,7 +242,7 @@ tidyType env t1) $! tidyType env t2 go (SymCo co) = SymCo $! go co go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 - go (NthCo r d co) = NthCo r d $! go co + go (SelCo d co) = SelCo d $! go co go (LRCo lr co) = LRCo lr $! go co go (InstCo co ty) = (InstCo $! go co) $! go ty go (KindCo co) = KindCo $! go co diff --git a/GHC/Core/TyCon.hs b/GHC/Core/TyCon.hs --- a/GHC/Core/TyCon.hs +++ b/GHC/Core/TyCon.hs @@ -17,2928 +17,2866 @@ AlgTyConRhs(..), visibleDataCons, AlgTyConFlav(..), isNoParent, FamTyConFlav(..), Role(..), Injectivity(..), - RuntimeRepInfo(..), TyConFlavour(..), - - -- * TyConBinder - TyConBinder, TyConBndrVis(..), TyConTyCoBinder, - mkNamedTyConBinder, mkNamedTyConBinders, - mkRequiredTyConBinder, - mkAnonTyConBinder, mkAnonTyConBinders, - tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder, - isVisibleTyConBinder, isInvisibleTyConBinder, isVisibleTcbVis, - - -- ** Field labels - tyConFieldLabels, lookupTyConFieldLabel, - - -- ** Constructing TyCons - mkAlgTyCon, - mkClassTyCon, - mkFunTyCon, - mkPrimTyCon, - mkTupleTyCon, - mkSumTyCon, - mkDataTyConRhs, - mkLevPolyDataTyConRhs, - mkSynonymTyCon, - mkFamilyTyCon, - mkPromotedDataCon, - mkTcTyCon, - noTcTyConScopedTyVars, - - -- ** Predicates on TyCons - isAlgTyCon, isVanillaAlgTyCon, isConstraintKindCon, - isClassTyCon, isFamInstTyCon, - isFunTyCon, - isPrimTyCon, - isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isUnboxedSumTyCon, isPromotedTupleTyCon, - isLiftedAlgTyCon, - isTypeSynonymTyCon, - mustBeSaturated, - isPromotedDataCon, isPromotedDataCon_maybe, - isKindTyCon, isLiftedTypeKindTyConName, - isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon, - - isDataTyCon, - isEnumerationTyCon, - isNewTyCon, isAbstractTyCon, - isFamilyTyCon, isOpenFamilyTyCon, - isTypeFamilyTyCon, isDataFamilyTyCon, - isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, - tyConInjectivityInfo, - isBuiltInSynFamTyCon_maybe, - isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, - isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, - isImplicitTyCon, - isTyConWithSrcDataCons, - isTcTyCon, setTcTyConKind, - tcHasFixedRuntimeRep, - isConcreteTyCon, - - -- ** Extracting information out of TyCons - tyConName, - tyConSkolem, - tyConKind, - tyConUnique, - tyConTyVars, tyConVisibleTyVars, - tyConCType, tyConCType_maybe, - tyConDataCons, tyConDataCons_maybe, - tyConSingleDataCon_maybe, tyConSingleDataCon, - tyConAlgDataCons_maybe, - tyConSingleAlgDataCon_maybe, - tyConFamilySize, - tyConStupidTheta, - tyConArity, - tyConNullaryTy, - tyConRoles, - tyConFlavour, - tyConTuple_maybe, tyConClass_maybe, tyConATs, - tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, - tyConFamilyResVar_maybe, - synTyConDefn_maybe, synTyConRhs_maybe, - famTyConFlav_maybe, famTcResVar, - algTyConRhs, - newTyConRhs, newTyConEtadArity, newTyConEtadRhs, - unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, - newTyConDataCon_maybe, - algTcFields, - tyConRuntimeRepInfo, - tyConBinders, tyConResKind, tyConInvisTVBinders, - tcTyConScopedTyVars, tcTyConIsPoly, - mkTyConTagMap, - - -- ** Manipulating TyCons - expandSynTyCon_maybe, - newTyConCo, newTyConCo_maybe, - pprPromotionQuote, mkTyConKind, - - -- ** Predicated on TyConFlavours - tcFlavourIsOpen, - - -- * Runtime type representation - TyConRepName, tyConRepName_maybe, - mkPrelTyConRepName, - tyConRepModOcc, - - -- * Primitive representations of Types - PrimRep(..), PrimElemRep(..), - primElemRepToPrimRep, - isVoidRep, isGcPtrRep, - primRepSizeB, - primElemRepSizeB, - primRepIsFloat, - primRepsCompatible, - primRepCompatible, - primRepIsWord, - primRepIsInt, - -) where - -import GHC.Prelude -import GHC.Platform - -import {-# SOURCE #-} GHC.Core.TyCo.Rep - ( Kind, Type, PredType, mkForAllTy, mkFunTyMany, mkNakedTyConTy ) -import {-# SOURCE #-} GHC.Core.TyCo.Ppr - ( pprType ) -import {-# SOURCE #-} GHC.Builtin.Types - ( runtimeRepTyCon, constraintKind, levityTyCon - , multiplicityTyCon - , vecCountTyCon, vecElemTyCon, liftedTypeKind ) -import {-# SOURCE #-} GHC.Core.DataCon - ( DataCon, dataConFieldLabels - , dataConTyCon, dataConFullSig - , isUnboxedSumDataCon ) -import {-# SOURCE #-} GHC.Core.Type - ( isLiftedTypeKind ) -import GHC.Builtin.Uniques - ( tyConRepNameUnique - , dataConTyRepNameUnique ) - -import GHC.Utils.Binary -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Core.Class -import GHC.Types.Basic -import GHC.Types.ForeignCall -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Core.Coercion.Axiom -import GHC.Builtin.Names -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 qualified Data.Data as Data - -{- ------------------------------------------------ - Notes about type families ------------------------------------------------ - -Note [Type synonym families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Type synonym families, also known as "type functions", map directly - onto the type functions in FC: - - type family F a :: * - type instance F Int = Bool - ..etc... - -* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon - -* From the user's point of view (F Int) and Bool are simply - equivalent types. - -* A Haskell 98 type synonym is a degenerate form of a type synonym - family. - -* Type functions can't appear in the LHS of a type function: - type instance F (F Int) = ... -- BAD! - -* Translation of type family decl: - type family F a :: * - translates to - a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon - - type family G a :: * where - G Int = Bool - G Bool = Char - G a = () - translates to - a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the - appropriate CoAxiom representing the equations - -We also support injective type families -- see Note [Injective type families] - -Note [Data type families] -~~~~~~~~~~~~~~~~~~~~~~~~~ -See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make - -* Data type families are declared thus - data family T a :: * - data instance T Int = T1 | T2 Bool - - Here T is the "family TyCon". - -* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon - -* The user does not see any "equivalent types" as they did with type - synonym families. They just see constructors with types - T1 :: T Int - T2 :: Bool -> T Int - -* Here's the FC version of the above declarations: - - data T a - data R:TInt = T1 | T2 Bool - axiom ax_ti : T Int ~R R:TInt - - Note that this is a *representational* coercion - The R:TInt is the "representation TyCons". - It has an AlgTyConFlav of - DataFamInstTyCon T [Int] ax_ti - -* The axiom ax_ti may be eta-reduced; see - Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom - -* Data family instances may have a different arity than the data family. - See Note [Arity of data families] in GHC.Core.FamInstEnv - -* The data constructor T2 has a wrapper (which is what the - source-level "T2" invokes): - - $WT2 :: Bool -> T Int - $WT2 b = T2 b `cast` sym ax_ti - -* A data instance can declare a fully-fledged GADT: - - data instance T (a,b) where - X1 :: T (Int,Bool) - X2 :: a -> b -> T (a,b) - - Here's the FC version of the above declaration: - - data R:TPair a b where - X1 :: R:TPair Int Bool - X2 :: a -> b -> R:TPair a b - axiom ax_pr :: T (a,b) ~R R:TPair a b - - $WX1 :: forall a b. a -> b -> T (a,b) - $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) - - The R:TPair are the "representation TyCons". - We have a bit of work to do, to unpick the result types of the - data instance declaration for T (a,b), to get the result type in the - representation; e.g. T (a,b) --> R:TPair a b - - The representation TyCon R:TList, has an AlgTyConFlav of - - DataFamInstTyCon T [(a,b)] ax_pr - -* Notice that T is NOT translated to a FC type function; it just - becomes a "data type" with no constructors, which can be coerced - into R:TInt, R:TPair by the axioms. These axioms - axioms come into play when (and *only* when) you - - use a data constructor - - do pattern matching - Rather like newtype, in fact - - As a result - - - T behaves just like a data type so far as decomposition is concerned - - - (T Int) is not implicitly converted to R:TInt during type inference. - Indeed the latter type is unknown to the programmer. - - - There *is* an instance for (T Int) in the type-family instance - environment, but it is looked up (via tcLookupDataFamilyInst) - in can_eq_nc (via tcTopNormaliseNewTypeTF_maybe) when trying to - solve representational equalities like - T Int ~R# Bool - Here we look up (T Int), convert it to R:TInt, and then unwrap the - newtype R:TInt. - - It is also looked up in reduceTyFamApp_maybe. - - - It's fine to have T in the LHS of a type function: - type instance F (T a) = [a] - - It was this last point that confused me! The big thing is that you - 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 instance F (G Int) = Bool - is no good, even if G is injective, because consider - type instance G Int = Bool - type instance F Bool = Char - - So a data type family is not an injective type function. It's just a - data type with some axioms that connect it to other data types. - -* The tyConTyVars of the representation tycon are the tyvars that the - user wrote in the patterns. This is important in GHC.Tc.Deriv, where we - bring these tyvars into scope before type-checking the deriving - clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl. - -Note [Associated families and their parent class] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -*Associated* families are just like *non-associated* families, except -that they have a famTcParent field of (Just cls_tc), which identifies the -parent class. - -However there is an important sharing relationship between - * the tyConTyVars of the parent Class - * the tyConTyVars of the associated TyCon - - class C a b where - data T p a - type F a q b - -Here the 'a' and 'b' are shared with the 'Class'; that is, they have -the same Unique. - -This is important. In an instance declaration we expect - * all the shared variables to be instantiated the same way - * the non-shared variables of the associated type should not - be instantiated at all - - instance C [x] (Tree y) where - data T p [x] = T1 x | T2 p - type F [x] q (Tree y) = (x,y,q) - -Note [TyCon Role signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Every tycon has a role signature, assigning a role to each of the tyConTyVars -(or of equal length to the tyConArity, if there are no tyConTyVars). An -example demonstrates these best: say we have a tycon T, with parameters a at -nominal, b at representational, and c at phantom. Then, to prove -representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have -nominal equality between a1 and a2, representational equality between b1 and -b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This -might happen, say, with the following declaration: - - data T a b c where - MkT :: b -> T Int b c - -Data and class tycons have their roles inferred (see inferRoles in GHC.Tc.TyCl.Utils), -as do vanilla synonym tycons. Family tycons have all parameters at role N, -though it is conceivable that we could relax this restriction. (->)'s and -tuples' parameters are at role R. Each primitive tycon declares its roles; -it's worth noting that (~#)'s parameters are at role N. Promoted data -constructors' type arguments are at role R. All kind arguments are at role -N. - -Note [Unboxed tuple RuntimeRep vars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The contents of an unboxed tuple may have any representation. Accordingly, -the kind of the unboxed tuple constructor is runtime-representation -polymorphic. - -Type constructor (2 kind arguments) - (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). - TYPE q -> TYPE r -> TYPE (TupleRep [q, r]) -Data constructor (4 type arguments) - (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep) - (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #) - -These extra tyvars (q and r) cause some delicate processing around tuples, -where we need to manually insert RuntimeRep arguments. -The same situation happens with unboxed sums: each alternative -has its own RuntimeRep. -For boxed tuples, there is no representation polymorphism, and therefore -we add RuntimeReps only for the unboxed version. - -Type constructor (no kind arguments) - (,) :: Type -> Type -> Type -Data constructor (2 type arguments) - (,) :: forall a b. a -> b -> (a, b) - - -Note [Injective type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We allow injectivity annotations for type families (both open and closed): - - type family F (a :: k) (b :: k) = r | r -> a - type family G a b = res | res -> a b where ... - -Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. -`famTcInj` maybe stores a list of Bools, where each entry corresponds to a -single element of `tyConTyVars` (both lists should have identical length). If no -injectivity annotation was provided `famTcInj` is Nothing. From this follows an -invariant that if `famTcInj` is a Just then at least one element in the list -must be True. - -See also: - * [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 - -Note [Sharing nullary TyConApps] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Nullary type constructor applications are extremely common. For this reason -each TyCon carries with it a @TyConApp tycon []@. This ensures that -'mkTyConTy' does not need to allocate and eliminates quite a bit of heap -residency. Furthermore, we use 'mkTyConTy' in the nullary case of 'mkTyConApp', -ensuring that this function also benefits from sharing. - -This optimisation improves allocations in the Cabal test by around 0.3% and -decreased cache misses measurably. - -See #19367. - - -************************************************************************ -* * - TyConBinder, TyConTyCoBinder -* * -************************************************************************ --} - -type TyConBinder = VarBndr TyVar TyConBndrVis -type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis - -- Only PromotedDataCon has TyConTyCoBinders - -- See Note [Promoted GADT data constructors] - -data TyConBndrVis - = NamedTCB ArgFlag - | AnonTCB AnonArgFlag - -instance Outputable TyConBndrVis where - ppr (NamedTCB flag) = text "NamedTCB" <> ppr flag - ppr (AnonTCB af) = text "AnonTCB" <> ppr af - -mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder -mkAnonTyConBinder af tv = assert (isTyVar tv) $ - Bndr tv (AnonTCB af) - -mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder] -mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs - -mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder --- The odd argument order supports currying -mkNamedTyConBinder vis tv = assert (isTyVar tv) $ - Bndr tv (NamedTCB vis) - -mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder] --- The odd argument order supports currying -mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs - --- | Make a Required TyConBinder. It chooses between NamedTCB and --- AnonTCB based on whether the tv is mentioned in the dependent set -mkRequiredTyConBinder :: TyCoVarSet -- these are used dependently - -> TyVar - -> TyConBinder -mkRequiredTyConBinder dep_set tv - | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv - | otherwise = mkAnonTyConBinder VisArg tv - -tyConBinderArgFlag :: TyConBinder -> ArgFlag -tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis - -tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag -tyConBndrVisArgFlag (NamedTCB vis) = vis -tyConBndrVisArgFlag (AnonTCB VisArg) = Required -tyConBndrVisArgFlag (AnonTCB InvisArg) = Inferred -- See Note [AnonTCB InvisArg] - -isNamedTyConBinder :: TyConBinder -> Bool --- Identifies kind variables --- E.g. data T k (a:k) = blah --- Here 'k' is a NamedTCB, a variable used in the kind of other binders -isNamedTyConBinder (Bndr _ (NamedTCB {})) = True -isNamedTyConBinder _ = False - -isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool --- Works for IfaceTyConBinder too -isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis - -isVisibleTcbVis :: TyConBndrVis -> Bool -isVisibleTcbVis (NamedTCB vis) = isVisibleArgFlag vis -isVisibleTcbVis (AnonTCB VisArg) = True -isVisibleTcbVis (AnonTCB InvisArg) = False - -isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool --- Works for IfaceTyConBinder too -isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) - --- Build the 'tyConKind' from the binders and the result kind. --- Keep in sync with 'mkTyConKind' in GHC.Iface.Type. -mkTyConKind :: [TyConBinder] -> Kind -> Kind -mkTyConKind bndrs res_kind = foldr mk res_kind bndrs - where - mk :: TyConBinder -> Kind -> Kind - mk (Bndr tv (AnonTCB af)) k = mkFunTyMany af (varType tv) k - mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k - -tyConInvisTVBinders :: [TyConBinder] -- From the TyCon - -> [InvisTVBinder] -- Suitable for the foralls of a term function --- See Note [Building TyVarBinders from TyConBinders] -tyConInvisTVBinders tc_bndrs - = map mk_binder tc_bndrs - where - mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv - where - vis = case tc_vis of - AnonTCB VisArg -> SpecifiedSpec - AnonTCB InvisArg -> InferredSpec -- See Note [AnonTCB InvisArg] - NamedTCB Required -> SpecifiedSpec - NamedTCB (Invisible vis) -> vis - --- Returns only tyvars, as covars are always inferred -tyConVisibleTyVars :: TyCon -> [TyVar] -tyConVisibleTyVars tc - = [ tv | Bndr tv vis <- tyConBinders tc - , isVisibleTcbVis vis ] - -{- Note [AnonTCB InvisArg] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's pretty rare to have an (AnonTCB InvisArg) binder. 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 InvisArg) to an ArgFlag, in -tyConBndrVisArgFlag, 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 VisArg) 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 AnonArgFlag in -the first place. - -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 -TyConBinders but TyVarBinders (used in forall-type) E.g: - - * From data T a = MkT (Maybe a) - we are going to make a data constructor with type - MkT :: forall a. Maybe a -> T a - See the TyCoVarBinders passed to buildDataCon - - * From class C a where { op :: a -> Maybe a } - we are going to make a default method - $dmop :: forall a. C a => a -> Maybe a - See the TyCoVarBinders passed to mkSigmaTy in mkDefaultMethodType - -Both of these are user-callable. (NB: default methods are not callable -directly by the user but rather via the code generated by 'deriving', -which uses visible type application; see mkDefMethBind.) - -Since they are user-callable we must get their type-argument visibility -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 -> * - -The TyCon has - - tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), 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 - -That is, its TyCoVarBinders should be - - dataConUnivTyVarBinders = [ Bndr (k:*) Inferred - , Bndr (a:k->*) Specified - , Bndr (b:k) Specified ] - -So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: - - variable names from the TyConBinders - - 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 TyCoBinders for a term (see Note [No Required TyCoBinder in terms] -in GHC.Core.TyCo.Rep), so we change it to Specified when making MkT's TyCoBinders --} - - -{- Note [The binders/kind/arity fields of a TyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All TyCons have this group of fields - tyConBinders :: [TyConBinder/TyConTyCoBinder] - tyConResKind :: Kind - tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders - -- NB: Currently (Aug 2018), TyCons that own this - -- field really only contain TyVars. So it is - -- [TyVar] instead of [TyCoVar]. - tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind - tyConArity :: Arity -- Cached = length tyConBinders - -They fit together like so: - -* tyConBinders gives the telescope of type/coercion 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 - , Bndr (b:k) AnonTCB ] - - Note that there are three binders here, including the - kind variable k. - - See Note [tyConBinders and lexical scoping] - -* See Note [VarBndrs, TyCoVarBinders, 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 - 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 ] - 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 -> * - - We get a 'forall' in the kind for each NamedTCB, and an arrow - for each AnonTCB - - tyConKind is the full kind of the TyCon, not just the result kind - -* For type families, tyConArity is the arguments this TyCon must be - applied to, to be considered saturated. Here we mean "applied to in - the actual Type", not surface syntax; i.e. including implicit kind - variables. So it's just (length tyConBinders) - -* For an algebraic data type, or data instance, the tyConResKind is - always (TYPE r); that is, the tyConBinders are enough to saturate - the type constructor. I'm not quite sure why we have this invariant, - but it's enforced by splitTyConKind - -Note [tyConBinders and lexical scoping] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a TyCon, and a PolyTcTyCon, we obey the following rule: - - The Name of the TyConBinder is precisely - the lexically scoped Name from the original declaration - (precisely = both OccName and Unique) - -For example, - data T a (b :: wombat) = MkT -We will get tyConBinders of [k, wombat, a::k, b::wombat] -The 'k' is made up; the user didn't specify it. But for the kind of 'b' -we must use 'wombat'. - -Why do we have this invariant? - -* Similarly, when typechecking default definitions for class methods, in - GHC.Tc.TyCl.Class.tcClassDecl2, we only have the (final) Class available; - but the variables bound in that class must be in scope. Eample (#19738): - - type P :: k -> Type - data P a = MkP - - type T :: k -> Constraint - class T (a :: j) where - f :: P a - f = MkP @j @a -- 'j' must be in scope when we typecheck 'f' - -* When typechecking `deriving` clauses for top-level data declarations, the - tcTyConScopedTyVars are brought into scope in through the `di_scoped_tvs` - field of GHC.Tc.Deriv.DerivInfo. Example (#16731): - - class C x1 x2 - - type T :: a -> Type - data T (x :: z) deriving (C z) - - When typechecking `C z`, we want `z` to map to `a`, which is exactly what the - tcTyConScopedTyVars for T give us. --} - -instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where - ppr (Bndr v bi) = ppr_bi bi <+> parens (pprBndr LetBind v) - where - ppr_bi (AnonTCB VisArg) = text "anon-vis" - ppr_bi (AnonTCB InvisArg) = text "anon-invis" - ppr_bi (NamedTCB Required) = text "req" - ppr_bi (NamedTCB Specified) = text "spec" - ppr_bi (NamedTCB Inferred) = text "inf" - -instance Binary TyConBndrVis where - put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af } - 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) } - _ -> do { vis <- get bh; return (NamedTCB vis) } } - - -{- ********************************************************************* -* * - The TyCon type -* * -************************************************************************ --} - - --- | TyCons represent type constructors. Type constructors are introduced by --- things such as: --- --- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of --- kind @*@ --- --- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor --- --- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor --- of kind @* -> *@ --- --- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor --- of kind @*@ --- --- This data type also encodes a number of primitive, built in type constructors --- such as those for function and tuple types. - --- If you edit this type, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint -data TyCon - = -- | The function type constructor, @(->)@ - FunTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - tyConNullaryTy :: Type, - - tcRepName :: TyConRepName - } - - -- | Algebraic data types, from - -- - @data@ declarations - -- - @newtype@ declarations - -- - data instance declarations - -- - type instance declarations - -- - the TyCon generated by a class declaration - -- - boxed tuples - -- - unboxed tuples - -- - constraint tuples - -- - unboxed sums - -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. - -- See 'AlgTyConRhs' for more information. - | AlgTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ - - -- The tyConTyVars scope over: - -- - -- 1. The 'algTcStupidTheta' - -- 2. The cached types in algTyConRhs.NewTyCon - -- 3. The family instance types if present - -- - -- Note that it does /not/ scope over the data - -- constructors. - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - tyConCType :: Maybe CType,-- ^ The C type that should be used - -- for this type when using the FFI - -- and CAPI - - algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT - -- syntax? If so, that doesn't mean it's a - -- true GADT; only that the "where" form - -- was used. This field is used only to - -- guide pretty-printing - - algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data - -- type (always empty for GADTs). A - -- \"stupid theta\" is the context to - -- the left of an algebraic type - -- declaration, e.g. @Eq a@ in the - -- declaration @data Eq a => T a ...@. - -- See @Note [The stupid context]@ in - -- "GHC.Core.DataCon". - - algTcRhs :: AlgTyConRhs, -- ^ Contains information about the - -- data constructors of the algebraic type - - algTcFields :: FieldLabelEnv, -- ^ Maps a label to information - -- about the field - - algTcFlavour :: AlgTyConFlav -- ^ The flavour of this algebraic tycon. - -- Gives the class or family declaration - -- 'TyCon' for derived 'TyCon's representing - -- class or family instances, respectively. - - } - - -- | Represents type synonyms - | SynonymTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ - -- tyConTyVars scope over: synTcRhs - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - synTcRhs :: Type, -- ^ Contains information about the expansion - -- of the synonym - - synIsTau :: Bool, -- True <=> the RHS of this synonym does not - -- have any foralls, after expanding any - -- nested synonyms - synIsFamFree :: Bool, -- True <=> the RHS of this synonym does not mention - -- any type synonym families (data families - -- are fine), again after expanding any - -- nested synonyms - synIsForgetful :: Bool -- 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. - } - - -- | Represents families (both type and data) - -- Argument roles are all Nominal - | FamilyTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ - -- tyConTyVars connect an associated family TyCon - -- with its parent class; see GHC.Tc.Validity.checkConsistentFamInst - - famTcResVar :: Maybe Name, -- ^ Name of result type variable, used - -- for pretty-printing with --show-iface - -- and for reifying TyCon in Template - -- Haskell - - famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, - -- abstract, built-in. See comments for - -- FamTyConFlav - - famTcParent :: Maybe TyCon, -- ^ For *associated* type/data families - -- The class tycon in which the family is declared - -- See Note [Associated families and their parent class] - - famTcInj :: Injectivity -- ^ is this a type family injective in - -- its type variables? Nothing if no - -- injectivity annotation was given - } - - -- | Primitive types; cannot be defined in Haskell. This includes - -- the usual suspects (such as @Int#@) as well as foreign-imported - -- types and kinds (@*@, @#@, and @?@) - | PrimTyCon { - tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: - -- identical to Unique of Name stored in - -- tyConName field. - - tyConName :: Name, -- ^ Name of the constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ - - tcRoles :: [Role], -- ^ The role for each type variable - -- This list has length = tyConArity - -- See also Note [TyCon Role signatures] - - primRepName :: TyConRepName -- ^ The 'Typeable' representation. - -- A cached version of - -- @'mkPrelTyConRepName' ('tyConName' tc)@. - } - - -- | Represents promoted data constructor. - | PromotedDataCon { -- See Note [Promoted data constructors] - tyConUnique :: Unique, -- ^ Same Unique as the data constructor - tyConName :: Name, -- ^ Same Name as the data constructor - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConTyCoBinder], -- ^ Full binders - -- TyConTyCoBinder: see Note [Promoted GADT data construtors] - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ - - tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars - dataCon :: DataCon, -- ^ Corresponding data constructor - tcRepName :: TyConRepName, - promDcRepInfo :: RuntimeRepInfo -- ^ See comments with 'RuntimeRepInfo' - } - - -- | These exist only during type-checking. See Note [How TcTyCons work] - -- in "GHC.Tc.TyCl" - | TcTyCon { - tyConUnique :: Unique, - tyConName :: Name, - - -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders - tyConTyVars :: [TyVar], -- ^ TyVar binders - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ - - -- NB: the TyConArity of a TcTyCon must match - -- the number of Required (positional, user-specified) - -- arguments to the type constructor; see the use - -- of tyConArity in generaliseTcTyCon - - tcTyConScopedTyVars :: [(Name,TcTyVar)], - -- ^ Scoped tyvars over the tycon's body - -- The range is always a skolem or TcTyVar, be - -- MonoTcTyCon only: see Note [Scoped tyvars in a TcTyCon] - - tcTyConIsPoly :: Bool, -- ^ Is this TcTyCon already generalized? - -- Used only to make zonking more efficient - - tcTyConFlavour :: TyConFlavour - -- ^ What sort of 'TyCon' this represents. - } - -{- Note [Scoped tyvars in a TcTyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The tcTyConScopedTyVars field records the lexicial-binding connection -between the original, user-specified Name (i.e. thing in scope) and -the TcTyVar that the Name is bound to. - -Order *does* matter; the tcTyConScopedTyvars list consists of - specified_tvs ++ required_tvs - -where - * specified ones first - * required_tvs the same as tyConTyVars - * 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 [TyConTyCoBinder] for the -tyconBinders field. TyConTyCoBinder is a synonym for TyConBinder, -but with the clue that the binder can be a CoVar not just a TyVar. - -Note [Representation-polymorphic TyCons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To check for representation-polymorphism directly in the typechecker, -e.g. when using GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep, -we need to compute whether a type has a syntactically fixed RuntimeRep, -as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. - -It's useful to have a quick way to check whether a saturated application -of a type constructor has a fixed RuntimeRep. That is, we want -to know, given a TyCon 'T' of arity 'n', does - - T a_1 ... a_n - -always have a fixed RuntimeRep? That is, is it always the case -that this application has a kind of the form - - T a_1 ... a_n :: TYPE rep - -in which 'rep' is a concrete 'RuntimeRep'? -('Concrete' in the sense of Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete: -it contains no type-family applications or type variables.) - -To answer this question, we have 'tcHasFixedRuntimeRep'. -If 'tcHasFixedRuntimeRep' returns 'True', it means we're sure that -every saturated application of `T` has a fixed RuntimeRep. -However, if it returns 'False', we don't know: perhaps some application might not -have a fixed RuntimeRep. - -Examples: - - - For type families, we won't know in general whether an application - will have a fixed RuntimeRep: - - type F :: k -> k - type family F a where {..} - - `tcHasFixedRuntimeRep F = False' - - - For newtypes, we're usually OK: - - newtype N a b c = MkN Int - - No matter what arguments we apply `N` to, we always get something of - kind `Type`, which has a fixed RuntimeRep. - Thus `tcHasFixedRuntimeRep N = True`. - - However, with `-XUnliftedNewtypes`, we can have representation-polymorphic - newtypes: - - type UN :: TYPE rep -> TYPE rep - newtype UN a = MkUN a - - `tcHasFixedRuntimeRep UN = False` - - For example, `UN @Int8Rep Int8#` is represented by an 8-bit value, - while `UN @LiftedRep Int` is represented by a heap pointer. - - To distinguish whether we are dealing with a representation-polymorphic newtype, - we keep track of which situation we are in using the 'nt_fixed_rep' - field of the 'NewTyCon' constructor of 'AlgTyConRhs', and read this field - to compute 'tcHasFixedRuntimeRep'. - - - A similar story can be told for datatypes: we're usually OK, - except with `-XUnliftedDatatypes` which allows for levity polymorphism, - e.g.: - - type UC :: TYPE (BoxedRep l) -> TYPE (BoxedRep l) - type UC a = MkUC a - - `tcHasFixedRuntimeRep UC = False` - - Here, we keep track of whether we are dealing with a levity-polymorphic - unlifted datatype using the 'data_fixed_lev' field of the 'DataTyCon' - constructor of 'AlgTyConRhs'. - - N.B.: technically, the representation of a datatype is fixed, - as it is always a pointer. However, we currently require that we - know the specific `RuntimeRep`: knowing that it's `BoxedRep l` - for a type-variable `l` isn't enough. See #15532. --} - --- | Represents right-hand-sides of 'TyCon's for algebraic types -data AlgTyConRhs - - -- | Says that we know nothing about this data type, except that - -- it's represented by a pointer. Used when we export a data type - -- abstractly into an .hi file. - = AbstractTyCon - - -- | Information about those 'TyCon's derived from a @data@ - -- declaration. This includes data types with no constructors at - -- all. - | DataTyCon { - data_cons :: [DataCon], - -- ^ The data type constructors; can be empty if the - -- user declares the type to have no constructors - -- - -- INVARIANT: Kept in order of increasing 'DataCon' - -- tag (see the tag assignment in mkTyConTagMap) - data_cons_size :: Int, - -- ^ Cached value: length data_cons - is_enum :: Bool, -- ^ Cached value: is this an enumeration type? - -- See Note [Enumeration types] - data_fixed_lev :: Bool - -- ^ 'True' if the data type constructor has - -- a known, fixed levity when fully applied - -- to its arguments, False otherwise. - -- - -- This can only be 'False' with UnliftedDatatypes, - -- e.g. - -- - -- > data A :: TYPE (BoxedRep l) where { MkA :: Int -> A } - -- - -- This boolean is cached to make it cheaper to check - -- for levity and representation-polymorphism in - -- tcHasFixedRuntimeRep. - } - - | TupleTyCon { -- A boxed, unboxed, or constraint tuple - data_con :: DataCon, -- NB: it can be an *unboxed* tuple - tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint - -- tuple? - } - - -- | An unboxed sum type. - | SumTyCon { - data_cons :: [DataCon], - data_cons_size :: Int -- ^ Cached value: length data_cons - } - - -- | Information about those 'TyCon's derived from a @newtype@ declaration - | NewTyCon { - data_con :: DataCon, -- ^ The unique constructor for the @newtype@. - -- It has no existentials - - nt_rhs :: Type, -- ^ Cached value: the argument type of the - -- constructor, which is just the representation - -- type of the 'TyCon' (remember that @newtype@s - -- do not exist at runtime so need a different - -- representation type). - -- - -- The free 'TyVar's of this type are the - -- 'tyConTyVars' from the corresponding 'TyCon' - - nt_etad_rhs :: ([TyVar], Type), - -- ^ Same as the 'nt_rhs', but this time eta-reduced. - -- Hence the list of 'TyVar's in this field may be - -- shorter than the declared arity of the 'TyCon'. - - -- See Note [Newtype eta] - nt_co :: CoAxiom Unbranched, - -- The axiom coercion that creates the @newtype@ - -- from the representation 'Type'. The axiom witnesses - -- a representational coercion: - -- nt_co :: N ty1 ~R# rep_tys - - -- See Note [Newtype coercions] - -- Invariant: arity = #tvs in nt_etad_rhs; - -- See Note [Newtype eta] - -- Watch out! If any newtypes become transparent - -- again check #1072. - nt_fixed_rep :: Bool - -- ^ 'True' if the newtype has a known, fixed representation - -- when fully applied to its arguments, 'False' otherwise. - -- This can only ever be 'False' with UnliftedNewtypes. - -- - -- Example: - -- - -- > newtype N (a :: TYPE r) = MkN a - -- - -- Invariant: nt_fixed_rep nt = tcHasFixedRuntimeRep (nt_rhs nt) - -- - -- This boolean is cached to make it cheaper to check if a - -- variable binding is representation-polymorphic - -- in tcHasFixedRuntimeRep. - } - -mkSumTyConRhs :: [DataCon] -> AlgTyConRhs -mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) - --- | Create an 'AlgTyConRhs' from the data constructors, --- for a potentially levity-polymorphic datatype (with `UnliftedDatatypes`). -mkLevPolyDataTyConRhs :: Bool -- ^ whether the 'DataCon' has a fixed levity - -> [DataCon] - -> AlgTyConRhs -mkLevPolyDataTyConRhs fixed_lev cons - = DataTyCon { - data_cons = cons, - data_cons_size = length cons, - is_enum = not (null cons) && all is_enum_con cons, - -- See Note [Enumeration types] in GHC.Core.TyCon - data_fixed_lev = fixed_lev - } - where - is_enum_con con - | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) - <- dataConFullSig con - = null ex_tvs && null eq_spec && null theta && null arg_tys - --- | Create an 'AlgTyConRhs' from the data constructors. --- --- Use 'mkLevPolyDataConRhs' if the datatype can be levity-polymorphic. -mkDataTyConRhs :: [DataCon] -> AlgTyConRhs -mkDataTyConRhs = mkLevPolyDataTyConRhs False - --- | Some promoted datacons signify extra info relevant to GHC. For example, --- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep' --- constructor of 'PrimRep'. This data structure allows us to store this --- information right in the 'TyCon'. The other approach would be to look --- up things like @RuntimeRep@'s @PrimRep@ by known-key every time. --- See also Note [Getting from RuntimeRep to PrimRep] in "GHC.Types.RepType" -data RuntimeRepInfo - = NoRRI -- ^ an ordinary promoted data con - | RuntimeRep ([Type] -> [PrimRep]) - -- ^ A constructor of @RuntimeRep@. The argument to the function should - -- be the list of arguments to the promoted datacon. - | VecCount Int -- ^ A constructor of @VecCount@ - | VecElem PrimElemRep -- ^ A constructor of @VecElem@ - | LiftedInfo -- ^ A constructor of @Levity@ - | UnliftedInfo -- ^ A constructor of @Levity@ - --- | Extract those 'DataCon's that we are able to learn about. Note --- 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 - --- | Describes the flavour of an algebraic type constructor. For --- classes and data families, this flavour includes a reference to --- the parent 'TyCon'. -data AlgTyConFlav - = -- | An ordinary algebraic type constructor. This includes unlifted and - -- representation-polymorphic datatypes and newtypes and unboxed tuples, - -- but NOT unboxed sums; see UnboxedSumTyCon. - VanillaAlgTyCon - TyConRepName -- For Typeable - - -- | An unboxed sum type constructor. This is distinct from VanillaAlgTyCon - -- because we currently don't allow unboxed sums to be Typeable since - -- there are too many of them. See #13276. - | UnboxedSumTyCon - - -- | Type constructors representing a class dictionary. - -- See Note [ATyCon for classes] in "GHC.Core.TyCo.Rep" - | ClassTyCon - Class -- INVARIANT: the classTyCon of this Class is the - -- current tycon - TyConRepName - - -- | Type constructors representing an *instance* of a *data* family. - -- Parameters: - -- - -- 1) The type family in question - -- - -- 2) Instance types; free variables are the 'tyConTyVars' - -- of the current 'TyCon' (not the family one). INVARIANT: - -- the number of types matches the arity of the family 'TyCon' - -- - -- 3) A 'CoTyCon' identifying the representation - -- type with the type instance family - | DataFamInstTyCon -- See Note [Data type families] - (CoAxiom Unbranched) -- The coercion axiom. - -- A *Representational* coercion, - -- of kind T ty1 ty2 ~R R:T a b c - -- where T is the family TyCon, - -- and R:T is the representation TyCon (ie this one) - -- and a,b,c are the tyConTyVars of this TyCon - -- - -- BUT may be eta-reduced; see - -- Note [Eta reduction for data families] in - -- GHC.Core.Coercion.Axiom - - -- Cached fields of the CoAxiom, but adjusted to - -- use the tyConTyVars of this TyCon - TyCon -- The family TyCon - [Type] -- Argument types (mentions the tyConTyVars of this TyCon) - -- No shorter in length than the tyConTyVars of the family TyCon - -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv - - -- E.g. data instance T [a] = ... - -- gives a representation tycon: - -- data R:TList a = ... - -- axiom co a :: T [a] ~ R:TList a - -- with R:TList's algTcFlavour = DataFamInstTyCon T [a] co - -instance Outputable AlgTyConFlav where - ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" - ppr (UnboxedSumTyCon {}) = text "Unboxed sum" - ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls - ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" - <+> ppr tc <+> sep (map pprType tys) - --- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class --- name, if any -okParent :: Name -> AlgTyConFlav -> Bool -okParent _ (VanillaAlgTyCon {}) = True -okParent _ (UnboxedSumTyCon {}) = True -okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) -okParent _ (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc - -isNoParent :: AlgTyConFlav -> Bool -isNoParent (VanillaAlgTyCon {}) = True -isNoParent _ = False - --------------------- - -data Injectivity - = NotInjective - | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) - deriving( Eq ) - --- | Information pertaining to the expansion of a type synonym (@type@) -data FamTyConFlav - = -- | Represents an open type family without a fixed right hand - -- side. Additional instances can appear at any time. - -- - -- These are introduced by either a top level declaration: - -- - -- > data family T a :: * - -- - -- Or an associated data type declaration, within a class declaration: - -- - -- > class C a b where - -- > data T b :: * - DataFamilyTyCon - TyConRepName - - -- | An open type synonym family e.g. @type family F x y :: * -> *@ - | OpenSynFamilyTyCon - - -- | A closed type synonym family e.g. - -- @type family F x where { F Int = Bool }@ - | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched)) - -- See Note [Closed type families] - - -- | A closed type synonym family declared in an hs-boot file with - -- type family F a where .. - | AbstractClosedSynFamilyTyCon - - -- | Built-in type family used by the TypeNats solver - | BuiltInSynFamTyCon BuiltInSynFamily - -instance Outputable FamTyConFlav where - ppr (DataFamilyTyCon n) = text "data family" <+> ppr n - ppr OpenSynFamilyTyCon = text "open type family" - ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family" - ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax - ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family" - ppr (BuiltInSynFamTyCon _) = text "built-in type family" - -{- Note [Closed type families] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* In an open type family you can add new instances later. This is the - usual case. - -* In a closed type family you can only put equations where the family - is defined. - -A non-empty closed type family has a single axiom with multiple -branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed -type family with no equations does not have an axiom, because there is -nothing for the axiom to prove! - - -Note [Promoted data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All data constructors can be promoted to become a type constructor, -via the PromotedDataCon alternative in GHC.Core.TyCon. - -* The TyCon promoted from a DataCon has the *same* Name and Unique as - the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78, - say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) - -* We promote the *user* type of the DataCon. Eg - data T = MkT {-# UNPACK #-} !(Bool, Bool) - The promoted kind is - 'MkT :: (Bool,Bool) -> T - *not* - 'MkT :: Bool -> Bool -> T - -* Similarly for GADTs: - data G a where - MkG :: forall b. b -> G [b] - The promoted data constructor has kind - 'MkG :: forall b. b -> G [b] - *not* - 'MkG :: forall a b. (a ~# [b]) => b -> G a - -Note [Enumeration types] -~~~~~~~~~~~~~~~~~~~~~~~~ -We define datatypes with no constructors to *not* be -enumerations; this fixes trac #2578, Otherwise we -end up generating an empty table for - __closure_tbl -which is used by tagToEnum# to map Int# to constructors -in an enumeration. The empty table apparently upset -the linker. - -Moreover, all the data constructor must be enumerations, meaning -they have type (forall abc. T a b c). GADTs are not enumerations. -For example consider - data T a where - T1 :: T Int - T2 :: T Bool - T3 :: T a -What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. -See #4528. - -Note [Newtype coercions] -~~~~~~~~~~~~~~~~~~~~~~~~ -The NewTyCon field nt_co is a CoAxiom which is used for coercing from -the representation type of the newtype, to the newtype itself. For -example, - - newtype T a = MkT (a -> a) - -the NewTyCon for T will contain nt_co = CoT where CoT :: forall a. T a ~ a -> a. - -We might also eta-contract the axiom: see Note [Newtype eta]. - -Note [Newtype eta] -~~~~~~~~~~~~~~~~~~ -Consider - newtype Parser a = MkParser (IO a) deriving Monad -Are these two types equal? That is, does a coercion exist between them? - Monad Parser - Monad IO -(We need this coercion to make the derived instance for Monad Parser.) - -Well, yes. But to see that easily we eta-reduce the RHS type of -Parser, in this case to IO, so that even unsaturated applications of -Parser will work right. So instead of - axParser :: forall a. Parser a ~ IO a -we generate an eta-reduced axiom - axParser :: Parser ~ IO - -This eta reduction is done when the type constructor is built, in -GHC.Tc.TyCl.Build.mkNewTyConRhs, and cached in NewTyCon. - -Here's an example that I think showed up in practice. -Source code: - newtype T a = MkT [a] - newtype Foo m = MkFoo (forall a. m a -> Int) - - w1 :: Foo [] - w1 = ... - - w2 :: Foo T - w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) - -After desugaring, and discarding the data constructors for the newtypes, -we would like to get: - w2 = w1 `cast` Foo axT - -so that w2 and w1 share the same code. To do this, the coercion axiom -axT must have - kind: axT :: T ~ [] - and arity: 0 - -See also Note [Newtype eta and homogeneous axioms] in GHC.Tc.TyCl.Build. - -************************************************************************ -* * - TyConRepName -* * -********************************************************************* -} - -type TyConRepName = Name - -- The Name of the top-level declaration for the Typeable world - -- $tcMaybe :: Data.Typeable.Internal.TyCon - -- $tcMaybe = TyCon { tyConName = "Maybe", ... } - -tyConRepName_maybe :: TyCon -> Maybe TyConRepName -tyConRepName_maybe (FunTyCon { tcRepName = rep_nm }) - = Just rep_nm -tyConRepName_maybe (PrimTyCon { primRepName = rep_nm }) - = Just rep_nm -tyConRepName_maybe (AlgTyCon { algTcFlavour = parent }) = case parent of - VanillaAlgTyCon rep_nm -> Just rep_nm - UnboxedSumTyCon -> Nothing - ClassTyCon _ rep_nm -> Just rep_nm - DataFamInstTyCon {} -> Nothing -tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) - = Just rep_nm -tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm }) - | isUnboxedSumDataCon dc -- see #13276 - = Nothing - | otherwise - = Just rep_nm -tyConRepName_maybe _ = Nothing - --- | Make a 'Name' for the 'Typeable' representation of the given wired-in type -mkPrelTyConRepName :: Name -> TyConRepName --- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". -mkPrelTyConRepName tc_name -- Prelude tc_name is always External, - -- so nameModule will work - = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) - where - name_occ = nameOccName tc_name - name_mod = nameModule tc_name - name_uniq = nameUnique tc_name - rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq - | otherwise = dataConTyRepNameUnique name_uniq - (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ - --- | The name (and defining module) for the Typeable representation (TyCon) of a --- type constructor. --- --- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". -tyConRepModOcc :: Module -> OccName -> (Module, OccName) -tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ) - where - rep_module - | tc_module == gHC_PRIM = gHC_TYPES - | otherwise = tc_module - - -{- ********************************************************************* -* * - PrimRep -* * -************************************************************************ - -Note [rep swamp] -~~~~~~~~~~~~~~~~ -GHC has a rich selection of types that represent "primitive types" of -one kind or another. Each of them makes a different set of -distinctions, and mostly the differences are for good reasons, -although it's probably true that we could merge some of these. - -Roughly in order of "includes more information": - - - A Width ("GHC.Cmm.Type") is simply a binary value with the specified - number of bits. It may represent a signed or unsigned integer, a - floating-point value, or an address. - - data Width = W8 | W16 | W32 | W64 | W128 - - - Size, which is used in the native code generator, is Width + - floating point information. - - data Size = II8 | II16 | II32 | II64 | FF32 | FF64 - - it is necessary because e.g. the instruction to move a 64-bit float - on x86 (movsd) is different from the instruction to move a 64-bit - integer (movq), so the mov instruction is parameterised by Size. - - - CmmType wraps Width with more information: GC ptr, float, or - other value. - - data CmmType = CmmType CmmCat Width - - data CmmCat -- "Category" (not exported) - = GcPtrCat -- GC pointer - | BitsCat -- Non-pointer - | FloatCat -- Float - - It is important to have GcPtr information in Cmm, since we generate - info tables containing pointerhood for the GC from this. As for - why we have float (and not signed/unsigned) here, see Note [Signed - vs unsigned]. - - - ArgRep makes only the distinctions necessary for the call and - return conventions of the STG machine. It is essentially CmmType - + void. - - - PrimRep makes a few more distinctions than ArgRep: it divides - non-GC-pointers into signed/unsigned and addresses, information - that is necessary for passing these values to foreign functions. - -There's another tension here: whether the type encodes its size in -bytes, or whether its size depends on the machine word size. Width -and CmmType have the size built-in, whereas ArgRep and PrimRep do not. - -This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. - -On the other hand, CmmType includes some "nonsense" values, such as -CmmType GcPtrCat W32 on a 64-bit machine. - -The PrimRep type is closely related to the user-visible RuntimeRep type. -See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. - --} - --- | A 'PrimRep' is an abstraction of a type. 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 - | Int8Rep -- ^ Signed, 8-bit value - | Int16Rep -- ^ Signed, 16-bit value - | Int32Rep -- ^ Signed, 32-bit value - | Int64Rep -- ^ Signed, 64 bit value - | IntRep -- ^ Signed, word-sized value - | Word8Rep -- ^ Unsigned, 8 bit value - | Word16Rep -- ^ Unsigned, 16 bit value - | 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') - | FloatRep - | DoubleRep - | VecRep Int PrimElemRep -- ^ A vector - deriving( Data.Data, Eq, Ord, Show ) - -data PrimElemRep - = Int8ElemRep - | Int16ElemRep - | Int32ElemRep - | Int64ElemRep - | Word8ElemRep - | Word16ElemRep - | Word32ElemRep - | Word64ElemRep - | FloatElemRep - | DoubleElemRep - deriving( Data.Data, Eq, Ord, Show, Enum ) - -instance Outputable PrimRep where - ppr r = text (show r) - -instance Outputable PrimElemRep where - 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 Int8Rep = putByte bh 3 - put_ bh Int16Rep = putByte bh 4 - put_ bh Int32Rep = putByte bh 5 - put_ bh Int64Rep = putByte bh 6 - put_ bh IntRep = putByte bh 7 - put_ bh Word8Rep = putByte bh 8 - put_ bh Word16Rep = putByte bh 9 - put_ bh Word32Rep = putByte bh 10 - put_ bh Word64Rep = putByte bh 11 - put_ bh WordRep = putByte bh 12 - put_ bh AddrRep = putByte bh 13 - put_ bh FloatRep = putByte bh 14 - put_ bh DoubleRep = putByte bh 15 - put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per - get bh = do - h <- getByte bh - case h of - 0 -> pure VoidRep - 1 -> pure LiftedRep - 2 -> pure UnliftedRep - 3 -> pure Int8Rep - 4 -> pure Int16Rep - 5 -> pure Int32Rep - 6 -> pure Int64Rep - 7 -> pure IntRep - 8 -> pure Word8Rep - 9 -> pure Word16Rep - 10 -> pure Word32Rep - 11 -> pure Word64Rep - 12 -> pure WordRep - 13 -> pure AddrRep - 14 -> pure FloatRep - 15 -> pure DoubleRep - 16 -> VecRep <$> get bh <*> get bh - _ -> pprPanic "Binary:PrimRep" (int (fromIntegral h)) - -instance Binary PrimElemRep where - put_ bh per = putByte bh (fromIntegral (fromEnum per)) - get bh = toEnum . fromIntegral <$> getByte bh - -isVoidRep :: PrimRep -> Bool -isVoidRep VoidRep = True -isVoidRep _other = False - -isGcPtrRep :: PrimRep -> Bool -isGcPtrRep LiftedRep = True -isGcPtrRep UnliftedRep = 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. -primRepCompatible :: Platform -> PrimRep -> PrimRep -> Bool -primRepCompatible platform rep1 rep2 = - (isUnboxed rep1 == isUnboxed rep2) && - (primRepSizeB platform rep1 == primRepSizeB platform rep2) && - (primRepIsFloat rep1 == primRepIsFloat rep2) - where - isUnboxed = not . isGcPtrRep - --- More general version of `primRepCompatible` for types represented by zero or --- more than one PrimReps. -primRepsCompatible :: Platform -> [PrimRep] -> [PrimRep] -> Bool -primRepsCompatible platform reps1 reps2 = - length reps1 == length reps2 && - and (zipWith (primRepCompatible platform) reps1 reps2) - --- | The size of a 'PrimRep' in bytes. --- --- This applies also when used in a constructor, where we allow packing the --- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will --- take only 8 bytes, which for 64-bit arch will be equal to 1 word. --- See also mkVirtHeapOffsetsWithPadding for details of how data fields are --- laid out. -primRepSizeB :: Platform -> PrimRep -> Int -primRepSizeB platform = \case - IntRep -> platformWordSizeInBytes platform - WordRep -> platformWordSizeInBytes platform - Int8Rep -> 1 - Int16Rep -> 2 - Int32Rep -> 4 - Int64Rep -> 8 - Word8Rep -> 1 - Word16Rep -> 2 - Word32Rep -> 4 - Word64Rep -> 8 - FloatRep -> fLOAT_SIZE - DoubleRep -> dOUBLE_SIZE - AddrRep -> platformWordSizeInBytes platform - LiftedRep -> platformWordSizeInBytes platform - UnliftedRep -> platformWordSizeInBytes platform - VoidRep -> 0 - (VecRep len rep) -> len * primElemRepSizeB platform rep - -primElemRepSizeB :: Platform -> PrimElemRep -> Int -primElemRepSizeB platform = primRepSizeB platform . primElemRepToPrimRep - -primElemRepToPrimRep :: PrimElemRep -> PrimRep -primElemRepToPrimRep Int8ElemRep = Int8Rep -primElemRepToPrimRep Int16ElemRep = Int16Rep -primElemRepToPrimRep Int32ElemRep = Int32Rep -primElemRepToPrimRep Int64ElemRep = Int64Rep -primElemRepToPrimRep Word8ElemRep = Word8Rep -primElemRepToPrimRep Word16ElemRep = Word16Rep -primElemRepToPrimRep Word32ElemRep = Word32Rep -primElemRepToPrimRep Word64ElemRep = Word64Rep -primElemRepToPrimRep FloatElemRep = FloatRep -primElemRepToPrimRep DoubleElemRep = DoubleRep - --- | Return if Rep stands for floating type, --- returns Nothing for vector types. -primRepIsFloat :: PrimRep -> Maybe Bool -primRepIsFloat FloatRep = Just True -primRepIsFloat DoubleRep = Just True -primRepIsFloat (VecRep _ _) = Nothing -primRepIsFloat _ = Just False - --- Rep is one of the word reps. -primRepIsWord :: PrimRep -> Bool -primRepIsWord WordRep = True -primRepIsWord (Word8Rep) = True -primRepIsWord (Word16Rep) = True -primRepIsWord (Word32Rep) = True -primRepIsWord (Word64Rep) = True -primRepIsWord _ = False - --- Rep is one of the int reps. -primRepIsInt :: PrimRep -> Bool -primRepIsInt (IntRep) = True -primRepIsInt (Int8Rep) = True -primRepIsInt (Int16Rep) = True -primRepIsInt (Int32Rep) = True -primRepIsInt (Int64Rep) = True -primRepIsInt _ = False - -{- -************************************************************************ -* * - Field labels -* * -************************************************************************ --} - --- | The labels for the fields of this particular 'TyCon' -tyConFieldLabels :: TyCon -> [FieldLabel] -tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc - --- | The labels for the fields of this particular 'TyCon' -tyConFieldLabelEnv :: TyCon -> FieldLabelEnv -tyConFieldLabelEnv tc - | isAlgTyCon tc = algTcFields tc - | otherwise = emptyDFsEnv - --- | Look up a field label belonging to this 'TyCon' -lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel -lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl - --- | Make a map from strings to FieldLabels from all the data --- constructors of this algebraic tycon -fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv -fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl) - | fl <- dataConsFields (visibleDataCons rhs) ] - where - -- Duplicates in this list will be removed by 'mkFsEnv' - dataConsFields dcs = concatMap dataConFieldLabels dcs - - -{- -************************************************************************ -* * -\subsection{TyCon Construction} -* * -************************************************************************ - -Note: the TyCon constructors all take a Kind as one argument, even though -they could, in principle, work out their Kind from their other arguments. -But to do so they need functions from Types, and that makes a nasty -module mutual-recursion. And they aren't called from many places. -So we compromise, and move their Kind calculation to the call site. --} - --- | Given the name of the function type constructor and it's kind, create the --- corresponding 'TyCon'. It is recommended to use 'GHC.Builtin.Types.funTyCon' if you want --- this functionality -mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon -mkFunTyCon name binders rep_nm - = let tc = - FunTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConResKind = liftedTypeKind, - tyConKind = mkTyConKind binders liftedTypeKind, - tyConArity = length binders, - tyConNullaryTy = mkNakedTyConTy tc, - tcRepName = rep_nm - } - in tc - --- | This is the making of an algebraic 'TyCon'. -mkAlgTyCon :: Name - -> [TyConBinder] -- ^ Binders of the 'TyCon' - -> Kind -- ^ Result kind - -> [Role] -- ^ The roles for each TyVar - -> Maybe CType -- ^ The C type this type corresponds to - -- when using the CAPI FFI - -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' - -> AlgTyConRhs -- ^ Information about data constructors - -> AlgTyConFlav -- ^ What flavour is it? - -- (e.g. vanilla, type family) - -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? - -> TyCon -mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn - = let tc = - AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length binders, - tyConNullaryTy = mkNakedTyConTy tc, - tyConTyVars = binderVars binders, - tcRoles = roles, - tyConCType = cType, - algTcStupidTheta = stupid, - algTcRhs = rhs, - algTcFields = fieldsOfAlgTcRhs rhs, - algTcFlavour = assertPpr (okParent name parent) (ppr name $$ ppr parent) parent, - algTcGadtSyntax = gadt_syn - } - in tc - --- | Simpler specialization of 'mkAlgTyCon' for classes -mkClassTyCon :: Name -> [TyConBinder] - -> [Role] -> AlgTyConRhs -> Class - -> Name -> TyCon -mkClassTyCon name binders roles rhs clas tc_rep_name - = mkAlgTyCon name binders constraintKind roles Nothing [] rhs - (ClassTyCon clas tc_rep_name) - False - -mkTupleTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ Result kind of the 'TyCon' - -> Arity -- ^ Arity of the tuple 'TyCon' - -> DataCon - -> TupleSort -- ^ Whether the tuple is boxed or unboxed - -> AlgTyConFlav - -> TyCon -mkTupleTyCon name binders res_kind arity con sort parent - = let tc = - AlgTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConTyVars = binderVars binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = arity, - tyConNullaryTy = mkNakedTyConTy tc, - tcRoles = replicate arity Representational, - tyConCType = Nothing, - algTcGadtSyntax = False, - algTcStupidTheta = [], - algTcRhs = TupleTyCon { data_con = con, - tup_sort = sort }, - algTcFields = emptyDFsEnv, - algTcFlavour = parent - } - in tc - -mkSumTyCon :: Name - -> [TyConBinder] - -> Kind -- ^ Kind of the resulting 'TyCon' - -> Arity -- ^ Arity of the sum - -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' - -> [DataCon] - -> AlgTyConFlav - -> TyCon -mkSumTyCon name binders res_kind arity tyvars cons parent - = let tc = - AlgTyCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConBinders = binders, - tyConTyVars = tyvars, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = arity, - tyConNullaryTy = mkNakedTyConTy tc, - tcRoles = replicate arity Representational, - tyConCType = Nothing, - algTcGadtSyntax = False, - algTcStupidTheta = [], - algTcRhs = mkSumTyConRhs cons, - algTcFields = emptyDFsEnv, - algTcFlavour = parent - } - in tc - --- | Makes a tycon suitable for use during type-checking. It stores --- a variety of details about the definition of the TyCon, but no --- 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". -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 - -> TyCon -mkTcTyCon name binders res_kind scoped_tvs poly flav - = let tc = - TcTyCon { tyConUnique = getUnique name - , tyConName = name - , tyConTyVars = binderVars binders - , tyConBinders = binders - , tyConResKind = res_kind - , tyConKind = mkTyConKind binders res_kind - , tyConArity = length binders - , tyConNullaryTy = mkNakedTyConTy tc - , tcTyConScopedTyVars = scoped_tvs - , tcTyConIsPoly = poly - , tcTyConFlavour = flav } - in tc - --- | No scoped type variables (to be used with mkTcTyCon). -noTcTyConScopedTyVars :: [(Name, TcTyVar)] -noTcTyConScopedTyVars = [] - --- | 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] - -> Kind -- ^ /result/ kind - -- Must answer 'True' to 'isFixedRuntimeRepKind' (i.e., no representation polymorphism). - -- (If you need a representation-polymorphic PrimTyCon, - -- change tcHasFixedRuntimeRep, marshalablePrimTyCon, reifyTyCon for PrimTyCons.) - -> [Role] - -> TyCon -mkPrimTyCon name binders res_kind roles - = let tc = - PrimTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length roles, - tyConNullaryTy = mkNakedTyConTy tc, - tcRoles = roles, - primRepName = mkPrelTyConRepName name - } - in tc - --- | 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 - = let tc = - SynonymTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - tyConArity = length binders, - tyConNullaryTy = mkNakedTyConTy tc, - tyConTyVars = binderVars binders, - tcRoles = roles, - synTcRhs = rhs, - synIsTau = is_tau, - synIsFamFree = is_fam_free, - synIsForgetful = is_forgetful - } - in tc - --- | Create a type family 'TyCon' -mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind - -> Maybe Name -> FamTyConFlav - -> Maybe Class -> Injectivity -> TyCon -mkFamilyTyCon name binders res_kind resVar flav parent inj - = let tc = - FamilyTyCon - { tyConUnique = nameUnique name - , tyConName = name - , tyConBinders = binders - , tyConResKind = res_kind - , tyConKind = mkTyConKind binders res_kind - , tyConArity = length binders - , tyConNullaryTy = mkNakedTyConTy tc - , tyConTyVars = binderVars binders - , famTcResVar = resVar - , famTcFlav = flav - , famTcParent = classTyCon <$> parent - , famTcInj = inj - } - in tc - - --- | Create a promoted data constructor 'TyCon' --- Somewhat dodgily, we give it the same Name --- as the data constructor itself; when we pretty-print --- the TyCon we add a quote; see the Outputable TyCon instance -mkPromotedDataCon :: DataCon -> Name -> TyConRepName - -> [TyConTyCoBinder] -> Kind -> [Role] - -> RuntimeRepInfo -> TyCon -mkPromotedDataCon con name rep_name binders res_kind roles rep_info - = let tc = - PromotedDataCon { - tyConUnique = nameUnique name, - tyConName = name, - tyConArity = length roles, - tyConNullaryTy = mkNakedTyConTy tc, - tcRoles = roles, - tyConBinders = binders, - tyConResKind = res_kind, - tyConKind = mkTyConKind binders res_kind, - dataCon = con, - tcRepName = rep_name, - promDcRepInfo = rep_info - } - in tc - -isFunTyCon :: TyCon -> Bool -isFunTyCon (FunTyCon {}) = True -isFunTyCon _ = False - --- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) -isAbstractTyCon :: TyCon -> Bool -isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon {} }) = True -isAbstractTyCon _ = False - --- | Does this 'TyCon' represent something that cannot be defined in Haskell? -isPrimTyCon :: TyCon -> Bool -isPrimTyCon (PrimTyCon {}) = True -isPrimTyCon _ = False - --- | Returns @True@ if the supplied 'TyCon' resulted from either a --- @data@ or @newtype@ declaration -isAlgTyCon :: TyCon -> Bool -isAlgTyCon (AlgTyCon {}) = True -isAlgTyCon _ = False - --- | Returns @True@ for vanilla AlgTyCons -- that is, those created --- with a @data@ or @newtype@ declaration. -isVanillaAlgTyCon :: TyCon -> Bool -isVanillaAlgTyCon (AlgTyCon { algTcFlavour = VanillaAlgTyCon _ }) = True -isVanillaAlgTyCon _ = False - --- | Returns @True@ for the 'TyCon' of the 'Constraint' kind. -{-# INLINE isConstraintKindCon #-} -- See Note [Inlining coreView] in GHC.Core.Type -isConstraintKindCon :: TyCon -> Bool --- NB: We intentionally match on AlgTyCon, because 'constraintKindTyCon' is --- always an AlgTyCon (see 'pcTyCon' in TysWiredIn) and the record selector --- for 'tyConUnique' would generate unreachable code for every other data --- constructor of TyCon (see #18026). -isConstraintKindCon AlgTyCon { tyConUnique = u } = u == constraintKindTyConKey -isConstraintKindCon _ = False - -isDataTyCon :: 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 --- 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 (AlgTyCon {algTcRhs = rhs}) - = case rhs of - TupleTyCon { tup_sort = sort } - -> isBoxed (tupleSortBoxity sort) - SumTyCon {} -> False - DataTyCon {} -> True - NewTyCon {} -> False - AbstractTyCon {} -> False -- We don't know, so return False -isDataTyCon _ = False - --- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds --- (where X is the role passed in): --- If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2) --- (where X1, X2, and X3, are the roles given by tyConRolesX tc X) --- See also Note [Decomposing equality] in "GHC.Tc.Solver.Canonical" -isInjectiveTyCon :: TyCon -> Role -> Bool -isInjectiveTyCon _ Phantom = False -isInjectiveTyCon (FunTyCon {}) _ = True -isInjectiveTyCon (AlgTyCon {}) Nominal = True -isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational - = isGenInjAlgRhs rhs -isInjectiveTyCon (SynonymTyCon {}) _ = False -isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) - Nominal = True -isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj -isInjectiveTyCon (FamilyTyCon {}) _ = False -isInjectiveTyCon (PrimTyCon {}) _ = True -isInjectiveTyCon (PromotedDataCon {}) _ = True -isInjectiveTyCon (TcTyCon {}) _ = True - -- Reply True for TcTyCon to minimise knock on type errors - -- See Note [How TcTyCons work] item (1) in GHC.Tc.TyCl - --- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds --- (where X is the role passed in): --- If (T tys ~X t), then (t's head ~X T). --- See also Note [Decomposing equality] in "GHC.Tc.Solver.Canonical" -isGenerativeTyCon :: TyCon -> Role -> Bool -isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True -isGenerativeTyCon (FamilyTyCon {}) _ = False - -- in all other cases, injectivity implies generativity -isGenerativeTyCon tc 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 (AlgTyCon {algTcRhs = NewTyCon {}}) = True -isNewTyCon _ = False - --- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it --- expands into, and (possibly) a coercion from the representation type to the --- @newtype@. --- Returns @Nothing@ if this is not possible. -unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) -unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, - algTcRhs = NewTyCon { nt_co = co, - nt_rhs = rhs }}) - = Just (tvs, rhs, co) -unwrapNewTyCon_maybe _ = Nothing - -unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) -unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co, - nt_etad_rhs = (tvs,rhs) }}) - = Just (tvs, rhs, co) -unwrapNewTyConEtad_maybe _ = Nothing - --- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? -{-# INLINE isTypeSynonymTyCon #-} -- See Note [Inlining coreView] in GHC.Core.Type -isTypeSynonymTyCon :: TyCon -> Bool -isTypeSynonymTyCon (SynonymTyCon {}) = True -isTypeSynonymTyCon _ = False - -isTauTyCon :: TyCon -> Bool -isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau -isTauTyCon _ = True - --- | Is this tycon neither a type family nor a synonym that expands --- to a type family? -isFamFreeTyCon :: TyCon -> Bool -isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free -isFamFreeTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav -isFamFreeTyCon _ = True - --- | Is this a forgetful type synonym? If this is a type synonym whose --- RHS does not mention one (or more) of its bound variables, returns --- 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. -isForgetfulSynTyCon :: TyCon -> Bool -isForgetfulSynTyCon (SynonymTyCon { synIsForgetful = forget }) = forget -isForgetfulSynTyCon _ = False - --- 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. --- - --- | True iff we can decompose (T a b c) into ((T a b) c) --- I.e. is it injective and generative w.r.t nominal equality? --- That is, if (T a b) ~N d e f, is it always the case that --- (T ~N d), (a ~N e) and (b ~N f)? --- Specifically NOT true of synonyms (open and otherwise) --- --- It'd be unusual to call mustBeSaturated on a regular H98 --- type synonym, because you should probably have expanded it first --- But regardless, it's not decomposable -mustBeSaturated :: TyCon -> Bool -mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour - --- | Is this an algebraic 'TyCon' declared with the GADT syntax? -isGadtSyntaxTyCon :: TyCon -> Bool -isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res -isGadtSyntaxTyCon _ = False - --- | Is this an algebraic 'TyCon' which is just an enumeration of values? -isEnumerationTyCon :: TyCon -> Bool --- See Note [Enumeration types] in GHC.Core.TyCon -isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs }) - = case rhs of - DataTyCon { is_enum = res } -> res - TupleTyCon {} -> arity == 0 - _ -> False -isEnumerationTyCon _ = False - --- | Is this a 'TyCon', synonym or otherwise, that defines a family? -isFamilyTyCon :: TyCon -> Bool -isFamilyTyCon (FamilyTyCon {}) = True -isFamilyTyCon _ = False - --- | Is this a 'TyCon', synonym or otherwise, that defines a family with --- instances? -isOpenFamilyTyCon :: TyCon -> Bool -isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav }) - | OpenSynFamilyTyCon <- flav = True - | DataFamilyTyCon {} <- flav = True -isOpenFamilyTyCon _ = False - --- | Is this a synonym 'TyCon' that can have may have further instances appear? -isTypeFamilyTyCon :: TyCon -> Bool -isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav) -isTypeFamilyTyCon _ = False - --- | Is this a synonym 'TyCon' that can have may have further instances appear? -isDataFamilyTyCon :: TyCon -> Bool -isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav -isDataFamilyTyCon _ = False - --- | Is this an open type family TyCon? -isOpenTypeFamilyTyCon :: TyCon -> Bool -isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True -isOpenTypeFamilyTyCon _ = False - --- | Is this a non-empty closed type family? Returns 'Nothing' for --- abstract or empty closed families. -isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched) -isClosedSynFamilyTyConWithAxiom_maybe - (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb -isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing - --- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an --- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is --- injective), or 'NotInjective' otherwise. -tyConInjectivityInfo :: TyCon -> Injectivity -tyConInjectivityInfo tc - | FamilyTyCon { famTcInj = inj } <- tc - = inj - | isInjectiveTyCon tc Nominal - = Injective (replicate (tyConArity tc) True) - | otherwise - = NotInjective - -isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily -isBuiltInSynFamTyCon_maybe - (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops -isBuiltInSynFamTyCon_maybe _ = Nothing - -isDataFamFlav :: FamTyConFlav -> Bool -isDataFamFlav (DataFamilyTyCon {}) = True -- Data family -isDataFamFlav _ = False -- Type synonym family - --- | Is this TyCon for an associated type? -isTyConAssoc :: TyCon -> Bool -isTyConAssoc = isJust . tyConAssoc_maybe - --- | Get the enclosing class TyCon (if there is one) for the given TyCon. -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 -isTupleTyCon :: TyCon -> Bool --- ^ Does this 'TyCon' represent a tuple? --- --- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to --- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they --- get spat into the interface file as tuple tycons, so I don't think --- it matters. -isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True -isTupleTyCon _ = False - -tyConTuple_maybe :: TyCon -> Maybe TupleSort -tyConTuple_maybe (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort} <- rhs = Just sort -tyConTuple_maybe _ = Nothing - --- | Is this the 'TyCon' for an unboxed tuple? -isUnboxedTupleTyCon :: TyCon -> Bool -isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort } <- rhs - = not (isBoxed (tupleSortBoxity sort)) -isUnboxedTupleTyCon _ = False - --- | Is this the 'TyCon' for a boxed tuple? -isBoxedTupleTyCon :: TyCon -> Bool -isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) - | TupleTyCon { tup_sort = sort } <- rhs - = isBoxed (tupleSortBoxity sort) -isBoxedTupleTyCon _ = False - --- | Is this the 'TyCon' for an unboxed sum? -isUnboxedSumTyCon :: TyCon -> Bool -isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs }) - | SumTyCon {} <- rhs - = True -isUnboxedSumTyCon _ = False - -isLiftedAlgTyCon :: TyCon -> Bool -isLiftedAlgTyCon (AlgTyCon { tyConResKind = res_kind }) - = isLiftedTypeKind res_kind -isLiftedAlgTyCon _ = False - --- | Is this the 'TyCon' for a /promoted/ tuple? -isPromotedTupleTyCon :: TyCon -> Bool -isPromotedTupleTyCon tyCon - | Just dataCon <- isPromotedDataCon_maybe tyCon - , isTupleTyCon (dataConTyCon dataCon) = True - | otherwise = False - --- | Is this a PromotedDataCon? -isPromotedDataCon :: TyCon -> Bool -isPromotedDataCon (PromotedDataCon {}) = True -isPromotedDataCon _ = False - --- | Retrieves the promoted DataCon if this is a PromotedDataCon; -isPromotedDataCon_maybe :: TyCon -> Maybe DataCon -isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc -isPromotedDataCon_maybe _ = Nothing - --- | Is this tycon really meant for use at the kind level? That is, --- should it be permitted without -XDataKinds? -isKindTyCon :: TyCon -> Bool -isKindTyCon tc = getUnique tc `elementOfUniqSet` 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 ] ) - where - tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) - -isLiftedTypeKindTyConName :: Name -> Bool -isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) - --- | Identifies implicit tycons that, in particular, do not go into interface --- files (because they are implicitly reconstructed when the interface is --- read). --- --- Note that: --- --- * Associated families are implicit, as they are re-constructed from --- the class declaration in which they reside, and --- --- * Family instances are /not/ implicit as they represent the instance body --- (similar to a @dfun@ does that for a class instance). --- --- * Tuples are implicit iff they have a wired-in name --- (namely: boxed and unboxed tuples are wired-in and implicit, --- but constraint tuples are not) -isImplicitTyCon :: TyCon -> Bool -isImplicitTyCon (FunTyCon {}) = True -isImplicitTyCon (PrimTyCon {}) = True -isImplicitTyCon (PromotedDataCon {}) = True -isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) - | TupleTyCon {} <- rhs = isWiredInName name - | SumTyCon {} <- rhs = True - | otherwise = False -isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent -isImplicitTyCon (SynonymTyCon {}) = False -isImplicitTyCon (TcTyCon {}) = False - -tyConCType_maybe :: TyCon -> Maybe CType -tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc -tyConCType_maybe _ = Nothing - --- | Is this a TcTyCon? (That is, one only used during type-checking?) -isTcTyCon :: TyCon -> Bool -isTcTyCon (TcTyCon {}) = True -isTcTyCon _ = False - -setTcTyConKind :: TyCon -> Kind -> TyCon --- Update the Kind of a TcTyCon --- The new kind is always a zonked version of its previous --- kind, so we don't need to update any other fields. --- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType -setTcTyConKind tc@(TcTyCon {}) kind = let tc' = tc { tyConKind = kind - , tyConNullaryTy = mkNakedTyConTy tc' - -- see Note [Sharing nullary TyCons] - } - in tc' -setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc) - --- | Does this 'TyCon' have a syntactically fixed RuntimeRep when fully applied, --- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete? --- --- False is safe. True means we're sure. --- Does only a quick check, based on the TyCon's category. --- --- See Note [Representation-polymorphic TyCons] -tcHasFixedRuntimeRep :: TyCon -> Bool -tcHasFixedRuntimeRep FunTyCon{} = True -tcHasFixedRuntimeRep (AlgTyCon { algTcRhs = rhs }) = case rhs of - AbstractTyCon {} -> False - -- An abstract TyCon might not have a fixed runtime representation. - -- Note that this is an entirely different matter from the concreteness - -- of the 'TyCon', in the sense of 'isConcreteTyCon'. - - DataTyCon { data_fixed_lev = fixed_lev } -> fixed_lev - -- A datatype might not have a fixed levity with UnliftedDatatypes (#20423). - -- NB: the current representation-polymorphism checks require that - -- 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) - - SumTyCon {} -> False -- only unboxed sums here - - NewTyCon { nt_fixed_rep = fixed_rep } -> fixed_rep - -- A newtype might not have a fixed runtime representation - -- with UnliftedNewtypes (#17360) - -tcHasFixedRuntimeRep SynonymTyCon{} = False -- conservative choice -tcHasFixedRuntimeRep FamilyTyCon{} = False -tcHasFixedRuntimeRep PrimTyCon{} = True -tcHasFixedRuntimeRep TcTyCon{} = False -tcHasFixedRuntimeRep tc@PromotedDataCon{} = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc) - --- | Is this 'TyCon' concrete (i.e. not a synonym/type family)? --- --- Used for representation polymorphism checks. -isConcreteTyCon :: TyCon -> Bool -isConcreteTyCon = isConcreteTyConFlavour . tyConFlavour - --- | 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 - -{- ------------------------------------------------ --- Expand type-constructor applications ------------------------------------------------ --} - -expandSynTyCon_maybe - :: TyCon - -> [tyco] -- ^ Arguments to 'TyCon' - -> Maybe ([(TyVar,tyco)], - Type, - [tyco]) -- ^ Returns a 'TyVar' substitution, the body - -- type of the synonym (not yet substituted) - -- and any arguments remaining from the - -- application --- ^ Expand a type synonym application --- Return Nothing if the TyCon is not a synonym, --- or if not enough arguments are supplied -expandSynTyCon_maybe tc tys - | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc - = if arity == 0 - then Just ([], rhs, tys) -- Avoid a bit of work in the case of nullary synonyms - else case tys `listLengthCmp` arity of - GT -> Just (tvs `zip` tys, rhs, drop arity tys) - EQ -> Just (tvs `zip` tys, rhs, []) - LT -> Nothing - | otherwise - = Nothing - ----------------- - --- | Check if the tycon actually refers to a proper `data` or `newtype` --- with user defined constructors rather than one from a class or other --- construction. - --- NB: This is only used in GHC.Tc.Gen.Export.checkPatSynParent to determine if an --- exported tycon can have a pattern synonym bundled with it, e.g., --- module Foo (TyCon(.., PatSyn)) where -isTyConWithSrcDataCons :: TyCon -> Bool -isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcFlavour = parent }) = - case rhs of - DataTyCon {} -> isSrcParent - NewTyCon {} -> isSrcParent - TupleTyCon {} -> isSrcParent - _ -> False - where - isSrcParent = isNoParent parent -isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} }) - = True -- #14058 -isTyConWithSrcDataCons _ = False - - --- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no --- constructors could be found -tyConDataCons :: TyCon -> [DataCon] --- It's convenient for tyConDataCons to return the --- empty list for type synonyms etc -tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] - --- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' --- is the sort that can have any constructors (note: this does not include --- abstract algebraic types) -tyConDataCons_maybe :: TyCon -> Maybe [DataCon] -tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs}) - = 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 -tyConDataCons_maybe _ = Nothing - --- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ --- type with one alternative, a tuple type or a @newtype@ then that constructor --- is returned. If the 'TyCon' has more than one constructor, or represents a --- primitive or function type constructor then @Nothing@ is returned. -tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon -tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons = [c] } -> Just c - TupleTyCon { data_con = c } -> Just c - NewTyCon { data_con = c } -> Just c - _ -> Nothing -tyConSingleDataCon_maybe _ = Nothing - --- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'. -tyConSingleDataCon :: TyCon -> DataCon -tyConSingleDataCon tc - = case tyConSingleDataCon_maybe tc of - 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 -tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs }) - = case rhs of - DataTyCon { data_cons_size = size } -> size - NewTyCon {} -> 1 - TupleTyCon {} -> 1 - SumTyCon { data_cons_size = size } -> size - _ -> pprPanic "tyConFamilySize 1" (ppr tc) -tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc) - --- | Extract an 'AlgTyConRhs' with information about data constructors from an --- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' -algTyConRhs :: TyCon -> AlgTyConRhs -algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs -algTyConRhs other = pprPanic "algTyConRhs" (ppr other) - --- | Extract type variable naming the result of injective type family -tyConFamilyResVar_maybe :: TyCon -> Maybe Name -tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res -tyConFamilyResVar_maybe _ = Nothing - --- | Get the list of roles for the type parameters of a TyCon -tyConRoles :: TyCon -> [Role] --- See also Note [TyCon Role signatures] -tyConRoles tc - = case tc of - { FunTyCon {} -> [Nominal, Nominal, Nominal, Representational, Representational] - ; AlgTyCon { tcRoles = roles } -> roles - ; SynonymTyCon { tcRoles = roles } -> roles - ; FamilyTyCon {} -> const_role Nominal - ; PrimTyCon { tcRoles = roles } -> roles - ; PromotedDataCon { tcRoles = roles } -> roles - ; TcTyCon {} -> const_role Nominal - } - where - const_role r = replicate (tyConArity tc) r - --- | Extract the bound type variables and type expansion of a type synonym --- 'TyCon'. Panics if the 'TyCon' is not a synonym -newTyConRhs :: TyCon -> ([TyVar], Type) -newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) - = (tvs, rhs) -newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) - --- | The number of type parameters that need to be passed to a newtype to --- resolve it. May be less than in the definition if it can be eta-contracted. -newTyConEtadArity :: TyCon -> Int -newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) - = length (fst tvs_rhs) -newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon) - --- | Extract the bound type variables and type expansion of an eta-contracted --- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym -newTyConEtadRhs :: TyCon -> ([TyVar], Type) -newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs -newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) - --- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to --- construct something with the @newtype@s type from its representation type --- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns --- @Nothing@ -newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) -newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co -newTyConCo_maybe _ = Nothing - -newTyConCo :: TyCon -> CoAxiom Unbranched -newTyConCo tc = case newTyConCo_maybe tc of - Just co -> co - Nothing -> pprPanic "newTyConCo" (ppr tc) - -newTyConDataCon_maybe :: TyCon -> Maybe DataCon -newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con -newTyConDataCon_maybe _ = Nothing - --- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context --- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration --- @data Eq a => T a ...@. See @Note [The stupid context]@ in "GHC.Core.DataCon". -tyConStupidTheta :: TyCon -> [PredType] -tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid -tyConStupidTheta (FunTyCon {}) = [] -tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) - --- | Extract the 'TyVar's bound by a vanilla type synonym --- and the corresponding (unsubstituted) right hand side. -synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) -synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty}) - = Just (tyvars, ty) -synTyConDefn_maybe _ = Nothing - --- | Extract the information pertaining to the right hand side of a type synonym --- (@type@) declaration. -synTyConRhs_maybe :: TyCon -> Maybe Type -synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs -synTyConRhs_maybe _ = Nothing - --- | Extract the flavour of a type family (with all the extra information that --- it carries) -famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav -famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav -famTyConFlav_maybe _ = Nothing - --- | Is this 'TyCon' that for a class instance? -isClassTyCon :: TyCon -> Bool -isClassTyCon (AlgTyCon {algTcFlavour = ClassTyCon {}}) = True -isClassTyCon _ = False - --- | If this 'TyCon' is that for a class instance, return the class it is for. --- Otherwise returns @Nothing@ -tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {algTcFlavour = ClassTyCon clas _}) = Just clas -tyConClass_maybe _ = Nothing - --- | Return the associated types of the 'TyCon', if any -tyConATs :: TyCon -> [TyCon] -tyConATs (AlgTyCon {algTcFlavour = ClassTyCon clas _}) = classATs clas -tyConATs _ = [] - ----------------------------------------------------------------------------- --- | Is this 'TyCon' that for a data family instance? -isFamInstTyCon :: TyCon -> Bool -isFamInstTyCon (AlgTyCon {algTcFlavour = DataFamInstTyCon {} }) - = True -isFamInstTyCon _ = False - -tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) -tyConFamInstSig_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon ax f ts }) - = Just (f, ts, ax) -tyConFamInstSig_maybe _ = Nothing - --- | If this 'TyCon' is that of a data family instance, return the family in question --- and the instance types. Otherwise, return @Nothing@ -tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) -tyConFamInst_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon _ f ts }) - = Just (f, ts) -tyConFamInst_maybe _ = Nothing - --- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which --- represents a coercion identifying the representation type with the type --- instance family. Otherwise, return @Nothing@ -tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) -tyConFamilyCoercion_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon ax _ _ }) - = Just ax -tyConFamilyCoercion_maybe _ = Nothing - --- | Extract any 'RuntimeRepInfo' from this TyCon -tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo -tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri -tyConRuntimeRepInfo _ = NoRRI - -- could panic in that second case. But Douglas Adams told me not to. - -{- -Note [Constructor tag allocation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When typechecking we need to allocate constructor tags to constructors. -They are allocated based on the position in the data_cons field of TyCon, -with the first constructor getting fIRST_TAG. - -We used to pay linear cost per constructor, with each constructor looking up -its relative index in the constructor list. That was quadratic and prohibitive -for large data types with more than 10k constructors. - -The current strategy is to build a NameEnv with a mapping from constructor's -Name to ConTag and pass it down to buildDataCon for efficient lookup. - -Relevant ticket: #14657 --} - -mkTyConTagMap :: TyCon -> NameEnv ConTag -mkTyConTagMap tycon = - mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..] - -- See Note [Constructor tag allocation] - -{- -************************************************************************ -* * -\subsection[TyCon-instances]{Instance declarations for @TyCon@} -* * -************************************************************************ - -@TyCon@s are compared by comparing their @Unique@s. --} - -instance Eq TyCon where - a == b = getUnique a == getUnique b - a /= b = getUnique a /= getUnique b - -instance Uniquable TyCon where - getUnique tc = tyConUnique tc - -instance Outputable TyCon where - -- At the moment a promoted TyCon has the same Name as its - -- corresponding TyCon, so we add the quote to distinguish it here - ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc - where - pp_tc = getPprStyle $ \sty -> - getPprDebug $ \debug -> - if ((debug || dumpStyle sty) && isTcTyCon tc) - 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 (AlgTyCon { algTcFlavour = parent, algTcRhs = rhs }) - | ClassTyCon _ _ <- parent = ClassFlavour - | otherwise = case rhs of - TupleTyCon { tup_sort = sort } - -> TupleFlavour (tupleSortBoxity sort) - SumTyCon {} -> SumFlavour - DataTyCon {} -> DataTypeFlavour - NewTyCon {} -> NewtypeFlavour - AbstractTyCon {} -> AbstractTypeFlavour -tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent }) - = case flav of - DataFamilyTyCon{} -> DataFamilyFlavour parent - OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent - ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour - AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour - BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour -tyConFlavour (SynonymTyCon {}) = TypeSynonymFlavour -tyConFlavour (FunTyCon {}) = BuiltInTypeFlavour -tyConFlavour (PrimTyCon {}) = BuiltInTypeFlavour -tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour -tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav - --- | Can this flavour of 'TyCon' appear unsaturated? -tcFlavourMustBeSaturated :: TyConFlavour -> 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 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 ClosedTypeFamilyFlavour = False -tcFlavourIsOpen ClassFlavour = False -tcFlavourIsOpen DataTypeFlavour = False -tcFlavourIsOpen NewtypeFlavour = False -tcFlavourIsOpen TupleFlavour{} = False -tcFlavourIsOpen SumFlavour = False -tcFlavourIsOpen AbstractTypeFlavour {} = False -tcFlavourIsOpen BuiltInTypeFlavour = False -tcFlavourIsOpen PromotedDataConFlavour = False -tcFlavourIsOpen TypeSynonymFlavour = False - -pprPromotionQuote :: TyCon -> SDoc --- Promoted data constructors already have a tick in their OccName -pprPromotionQuote tc - = case tc of - PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types - _ -> empty + PromDataConInfo(..), TyConFlavour(..), + + -- * TyConBinder + TyConBinder, TyConBndrVis(..), TyConPiTyBinder, + mkNamedTyConBinder, mkNamedTyConBinders, + mkRequiredTyConBinder, + mkAnonTyConBinder, mkAnonTyConBinders, mkInvisAnonTyConBinder, + tyConBinderForAllTyFlag, tyConBndrVisForAllTyFlag, isNamedTyConBinder, + isVisibleTyConBinder, isInvisibleTyConBinder, isVisibleTcbVis, + + -- ** Field labels + tyConFieldLabels, lookupTyConFieldLabel, + + -- ** Constructing TyCons + mkAlgTyCon, + mkClassTyCon, + mkPrimTyCon, + mkTupleTyCon, + mkSumTyCon, + mkDataTyConRhs, + mkLevPolyDataTyConRhs, + mkSynonymTyCon, + mkFamilyTyCon, + mkPromotedDataCon, + mkTcTyCon, + noTcTyConScopedTyVars, + + -- ** Predicates on TyCons + isAlgTyCon, isVanillaAlgTyCon, + isClassTyCon, isFamInstTyCon, + isPrimTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, + isUnboxedSumTyCon, isPromotedTupleTyCon, + isLiftedAlgTyCon, + isTypeSynonymTyCon, + tyConMustBeSaturated, + isPromotedDataCon, isPromotedDataCon_maybe, + isDataKindsPromotedDataCon, + isKindTyCon, isLiftedTypeKindTyConName, + isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon, + + isDataTyCon, + isTypeDataTyCon, + isEnumerationTyCon, + isNewTyCon, isAbstractTyCon, + isFamilyTyCon, isOpenFamilyTyCon, + isTypeFamilyTyCon, isDataFamilyTyCon, + isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, + tyConInjectivityInfo, + isBuiltInSynFamTyCon_maybe, + isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, + isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, + isImplicitTyCon, + isTyConWithSrcDataCons, + isTcTyCon, setTcTyConKind, + tcHasFixedRuntimeRep, + isConcreteTyCon, + + -- ** Extracting information out of TyCons + tyConName, + tyConSkolem, + tyConKind, + tyConUnique, + tyConTyVars, tyConVisibleTyVars, + tyConCType_maybe, + tyConDataCons, tyConDataCons_maybe, + tyConSingleDataCon_maybe, tyConSingleDataCon, + tyConAlgDataCons_maybe, + tyConSingleAlgDataCon_maybe, + tyConFamilySize, + tyConStupidTheta, + tyConArity, + tyConNullaryTy, mkTyConTy, + tyConRoles, + tyConFlavour, + tyConTuple_maybe, tyConClass_maybe, tyConATs, + tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, + tyConFamilyResVar_maybe, + synTyConDefn_maybe, synTyConRhs_maybe, + famTyConFlav_maybe, + algTyConRhs, + newTyConRhs, newTyConEtadArity, newTyConEtadRhs, + unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, + newTyConDataCon_maybe, + algTcFields, + tyConPromDataConInfo, + tyConBinders, tyConResKind, tyConInvisTVBinders, + tcTyConScopedTyVars, isMonoTcTyCon, + tyConHasClosedResKind, + mkTyConTagMap, + + -- ** Manipulating TyCons + ExpandSynResult(..), + expandSynTyCon_maybe, + newTyConCo, newTyConCo_maybe, + pprPromotionQuote, mkTyConKind, + + -- ** Predicated on TyConFlavours + tcFlavourIsOpen, + + -- * Runtime type representation + TyConRepName, tyConRepName_maybe, + mkPrelTyConRepName, + tyConRepModOcc, + + -- * Primitive representations of Types + PrimRep(..), PrimElemRep(..), + primElemRepToPrimRep, + isVoidRep, isGcPtrRep, + primRepSizeB, + primElemRepSizeB, + primRepIsFloat, + primRepsCompatible, + primRepCompatible, + primRepIsWord, + primRepIsInt, + +) where + +import GHC.Prelude +import GHC.Platform + +import {-# SOURCE #-} GHC.Core.TyCo.Rep + ( Kind, Type, PredType, mkForAllTy, mkNakedFunTy, mkNakedTyConTy ) +import {-# SOURCE #-} GHC.Core.TyCo.FVs + ( noFreeVarsOfType ) +import {-# SOURCE #-} GHC.Core.TyCo.Ppr + ( pprType ) +import {-# SOURCE #-} GHC.Builtin.Types + ( runtimeRepTyCon, constraintKind, levityTyCon + , multiplicityTyCon + , vecCountTyCon, vecElemTyCon ) +import {-# SOURCE #-} GHC.Core.DataCon + ( DataCon, dataConFieldLabels + , dataConTyCon, dataConFullSig + , isUnboxedSumDataCon, isTypeDataCon ) +import {-# SOURCE #-} GHC.Core.Type + ( isLiftedTypeKind ) +import GHC.Builtin.Uniques + ( tyConRepNameUnique + , dataConTyRepNameUnique ) + +import GHC.Utils.Binary +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Core.Class +import GHC.Types.Basic +import GHC.Types.ForeignCall +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Core.Coercion.Axiom +import GHC.Builtin.Names +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 Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import qualified Data.Data as Data + +{- +----------------------------------------------- + Notes about type families +----------------------------------------------- + +Note [Type synonym families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Type synonym families, also known as "type functions", map directly + onto the type functions in FC: + + type family F a :: * + type instance F Int = Bool + ..etc... + +* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon + +* From the user's point of view (F Int) and Bool are simply + equivalent types. + +* A Haskell 98 type synonym is a degenerate form of a type synonym + family. + +* Type functions can't appear in the LHS of a type function: + type instance F (F Int) = ... -- BAD! + +* Translation of type family decl: + type family F a :: * + translates to + a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon + + type family G a :: * where + G Int = Bool + G Bool = Char + G a = () + translates to + a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the + appropriate CoAxiom representing the equations + +We also support injective type families -- see Note [Injective type families] + +Note [Data type families] +~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make + +* Data type families are declared thus + data family T a :: * + data instance T Int = T1 | T2 Bool + + Here T is the "family TyCon". + +* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon + +* The user does not see any "equivalent types" as they did with type + synonym families. They just see constructors with types + T1 :: T Int + T2 :: Bool -> T Int + +* Here's the FC version of the above declarations: + + data T a + data R:TInt = T1 | T2 Bool + axiom ax_ti : T Int ~R R:TInt + + Note that this is a *representational* coercion + The R:TInt is the "representation TyCons". + It has an AlgTyConFlav of + DataFamInstTyCon T [Int] ax_ti + +* The axiom ax_ti may be eta-reduced; see + Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + +* Data family instances may have a different arity than the data family. + See Note [Arity of data families] in GHC.Core.FamInstEnv + +* The data constructor T2 has a wrapper (which is what the + source-level "T2" invokes): + + $WT2 :: Bool -> T Int + $WT2 b = T2 b `cast` sym ax_ti + +* A data instance can declare a fully-fledged GADT: + + data instance T (a,b) where + X1 :: T (Int,Bool) + X2 :: a -> b -> T (a,b) + + Here's the FC version of the above declaration: + + data R:TPair a b where + X1 :: R:TPair Int Bool + X2 :: a -> b -> R:TPair a b + axiom ax_pr :: T (a,b) ~R R:TPair a b + + $WX1 :: forall a b. a -> b -> T (a,b) + $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) + + The R:TPair are the "representation TyCons". + We have a bit of work to do, to unpick the result types of the + data instance declaration for T (a,b), to get the result type in the + representation; e.g. T (a,b) --> R:TPair a b + + The representation TyCon R:TList, has an AlgTyConFlav of + + DataFamInstTyCon T [(a,b)] ax_pr + +* Notice that T is NOT translated to a FC type function; it just + becomes a "data type" with no constructors, which can be coerced + into R:TInt, R:TPair by the axioms. These axioms + axioms come into play when (and *only* when) you + - use a data constructor + - do pattern matching + Rather like newtype, in fact + + As a result + + - T behaves just like a data type so far as decomposition is concerned + + - (T Int) is not implicitly converted to R:TInt during type inference. + Indeed the latter type is unknown to the programmer. + + - There *is* an instance for (T Int) in the type-family instance + environment, but it is looked up (via tcLookupDataFamilyInst) + in can_eq_nc (via tcTopNormaliseNewTypeTF_maybe) when trying to + solve representational equalities like + T Int ~R# Bool + Here we look up (T Int), convert it to R:TInt, and then unwrap the + newtype R:TInt. + + It is also looked up in reduceTyFamApp_maybe. + + - It's fine to have T in the LHS of a type function: + type instance F (T a) = [a] + + It was this last point that confused me! The big thing is that you + 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 instance F (G Int) = Bool + is no good, even if G is injective, because consider + type instance G Int = Bool + type instance F Bool = Char + + So a data type family is not an injective type function. It's just a + data type with some axioms that connect it to other data types. + +* The tyConTyVars of the representation tycon are the tyvars that the + user wrote in the patterns. This is important in GHC.Tc.Deriv, where we + bring these tyvars into scope before type-checking the deriving + clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl. + +Note [Associated families and their parent class] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*Associated* families are just like *non-associated* families, except +that they have a famTcParent field of (Just cls_tc), which identifies the +parent class. + +However there is an important sharing relationship between + * the tyConTyVars of the parent Class + * the tyConTyVars of the associated TyCon + + class C a b where + data T p a + type F a q b + +Here the 'a' and 'b' are shared with the 'Class'; that is, they have +the same Unique. + +This is important. In an instance declaration we expect + * all the shared variables to be instantiated the same way + * the non-shared variables of the associated type should not + be instantiated at all + + instance C [x] (Tree y) where + data T p [x] = T1 x | T2 p + type F [x] q (Tree y) = (x,y,q) + +Note [TyCon Role signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every tycon has a role signature, assigning a role to each of the tyConTyVars +(or of equal length to the tyConArity, if there are no tyConTyVars). An +example demonstrates these best: say we have a tycon T, with parameters a at +nominal, b at representational, and c at phantom. Then, to prove +representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have +nominal equality between a1 and a2, representational equality between b1 and +b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This +might happen, say, with the following declaration: + + data T a b c where + MkT :: b -> T Int b c + +Data and class tycons have their roles inferred (see inferRoles in GHC.Tc.TyCl.Utils), +as do vanilla synonym tycons. Family tycons have all parameters at role N, +though it is conceivable that we could relax this restriction. (->)'s and +tuples' parameters are at role R. Each primitive tycon declares its roles; +it's worth noting that (~#)'s parameters are at role N. Promoted data +constructors' type arguments are at role R. All kind arguments are at role +N. + +Note [Unboxed tuple RuntimeRep vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The contents of an unboxed tuple may have any representation. Accordingly, +the kind of the unboxed tuple constructor is runtime-representation +polymorphic. + +Type constructor (2 kind arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). + TYPE q -> TYPE r -> TYPE (TupleRep [q, r]) +Data constructor (4 type arguments) + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep) + (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #) + +These extra tyvars (q and r) cause some delicate processing around tuples, +where we need to manually insert RuntimeRep arguments. +The same situation happens with unboxed sums: each alternative +has its own RuntimeRep. +For boxed tuples, there is no representation polymorphism, and therefore +we add RuntimeReps only for the unboxed version. + +Type constructor (no kind arguments) + (,) :: Type -> Type -> Type +Data constructor (2 type arguments) + (,) :: forall a b. a -> b -> (a, b) + + +Note [Injective type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow injectivity annotations for type families (both open and closed): + + type family F (a :: k) (b :: k) = r | r -> a + type family G a b = res | res -> a b where ... + +Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. +`famTcInj` maybe stores a list of Bools, where each entry corresponds to a +single element of `tyConTyVars` (both lists should have identical length). If no +injectivity annotation was provided `famTcInj` is Nothing. From this follows an +invariant that if `famTcInj` is a Just then at least one element in the list +must be True. + +See also: + * [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 + +Note [Sharing nullary TyConApps] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nullary type constructor applications are extremely common. For this reason +each TyCon carries with it a @TyConApp tycon []@. This ensures that +'mkTyConTy' does not need to allocate and eliminates quite a bit of heap +residency. Furthermore, we use 'mkTyConTy' in the nullary case of 'mkTyConApp', +ensuring that this function also benefits from sharing. + +This optimisation improves allocations in the Cabal test by around 0.3% and +decreased cache misses measurably. + +See #19367. + + +************************************************************************ +* * + TyConBinder, TyConPiTyBinder +* * +************************************************************************ +-} + +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 + +instance Outputable TyConBndrVis where + ppr (NamedTCB flag) = ppr flag + ppr (AnonTCB af) = ppr af + +mkAnonTyConBinder :: TyVar -> TyConBinder +-- Make a visible anonymous TyCon binder +mkAnonTyConBinder tv = assert (isTyVar tv) $ + Bndr tv (AnonTCB visArgTypeLike) + +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) $ + Bndr tv (NamedTCB vis) + +mkNamedTyConBinders :: ForAllTyFlag -> [TyVar] -> [TyConBinder] +-- The odd argument order supports currying +mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs + +-- | Make a Required TyConBinder. It chooses between NamedTCB and +-- AnonTCB based on whether the tv is mentioned in the dependent set +mkRequiredTyConBinder :: TyCoVarSet -- these are used dependently + -> TyVar + -> TyConBinder +mkRequiredTyConBinder dep_set tv + | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv + | otherwise = mkAnonTyConBinder tv + +tyConBinderForAllTyFlag :: TyConBinder -> 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 + +isNamedTyConBinder :: TyConBinder -> Bool +-- Identifies kind variables +-- E.g. data T k (a:k) = blah +-- Here 'k' is a NamedTCB, a variable used in the kind of other binders +isNamedTyConBinder (Bndr _ (NamedTCB {})) = True +isNamedTyConBinder _ = False + +isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis + +isVisibleTcbVis :: TyConBndrVis -> Bool +isVisibleTcbVis (NamedTCB vis) = isVisibleForAllTyFlag vis +isVisibleTcbVis (AnonTCB af) = isVisibleFunArg af + +isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) + +-- Build the 'tyConKind' from the binders and the result kind. +-- Keep in sync with 'mkTyConKind' in GHC.Iface.Type. +mkTyConKind :: [TyConBinder] -> Kind -> Kind +mkTyConKind bndrs res_kind = foldr mk res_kind bndrs + 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 + -- mkNakedFunTy: see Note [Naked FunTy] in GHC.Builtin.Types + +-- | (mkTyConTy tc) returns (TyConApp tc []) +-- but arranges to share that TyConApp among all calls +-- See Note [Sharing nullary TyConApps] +-- So it's just an alias for tyConNullaryTy! +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = tyConNullaryTy tycon + +tyConInvisTVBinders :: [TyConBinder] -- From the TyCon + -> [InvisTVBinder] -- Suitable for the foralls of a term function +-- See Note [Building TyVarBinders from TyConBinders] +tyConInvisTVBinders tc_bndrs + = map mk_binder tc_bndrs + where + 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 + NamedTCB Required -> SpecifiedSpec + NamedTCB (Invisible vis) -> vis + +-- Returns only tyvars, as covars are always inferred +tyConVisibleTyVars :: TyCon -> [TyVar] +tyConVisibleTyVars tc + = [ 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We sometimes need to build the quantified type of a value from +the TyConBinders of a type or class. For that we need not +TyConBinders but TyVarBinders (used in forall-type) E.g: + + * From data T a = MkT (Maybe a) + we are going to make a data constructor with type + MkT :: forall a. Maybe a -> T a + See the ForAllTyBinders passed to buildDataCon + + * From class C a where { op :: a -> Maybe a } + we are going to make a default method + $dmop :: forall a. C a => a -> Maybe a + See the ForAllTyBinders passed to mkSigmaTy in mkDefaultMethodType + +Both of these are user-callable. (NB: default methods are not callable +directly by the user but rather via the code generated by 'deriving', +which uses visible type application; see mkDefMethBind.) + +Since they are user-callable we must get their type-argument visibility +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 -> * + +The TyCon has + + tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), 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 + +That is, its ForAllTyBinders should be + + dataConUnivTyVarBinders = [ Bndr (k:*) Inferred + , Bndr (a:k->*) Specified + , Bndr (b:k) Specified ] + +So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: + - variable names from the TyConBinders + - 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 +-} + + +{- Note [The binders/kind/arity fields of a TyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All TyCons have this group of fields + tyConBinders :: [TyConBinder/TyConPiTyBinder] + tyConResKind :: Kind + tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders + -- NB: Currently (Aug 2018), TyCons that own this + -- field really only contain TyVars. So it is + -- [TyVar] instead of [TyCoVar]. + tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind + tyConArity :: Arity -- Cached = length tyConBinders + +They fit together like so: + +* tyConBinders gives the telescope of type/coercion 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 + , Bndr (b:k) AnonTCB ] + + Note that there are three binders here, including the + kind variable k. + + See Note [tyConBinders and lexical scoping] + +* 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 + 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 ] + 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 -> * + + We get a 'forall' in the kind for each NamedTCB, and an arrow + for each AnonTCB + + tyConKind is the full kind of the TyCon, not just the result kind + +* For type families, tyConArity is the arguments this TyCon must be + applied to, to be considered saturated. Here we mean "applied to in + the actual Type", not surface syntax; i.e. including implicit kind + variables. So it's just (length tyConBinders) + +* For an algebraic data type, or data instance, the tyConResKind is + always (TYPE r); that is, the tyConBinders are enough to saturate + the type constructor. I'm not quite sure why we have this invariant, + but it's enforced by splitTyConKind + +Note [tyConBinders and lexical scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a TyCon, and a PolyTcTyCon, we obey the following rule: + + The Name of the TyConBinder is precisely + the lexically scoped Name from the original declaration + (precisely = both OccName and Unique) + +For example, + data T a (b :: wombat) = MkT +We will get tyConBinders of [k, wombat, a::k, b::wombat] +The 'k' is made up; the user didn't specify it. But for the kind of 'b' +we must use 'wombat'. + +Why do we have this invariant? + +* Similarly, when typechecking default definitions for class methods, in + GHC.Tc.TyCl.Class.tcClassDecl2, we only have the (final) Class available; + but the variables bound in that class must be in scope. Example (#19738): + + type P :: k -> Type + data P a = MkP + + type T :: k -> Constraint + class T (a :: j) where + f :: P a + f = MkP @j @a -- 'j' must be in scope when we typecheck 'f' + +* When typechecking `deriving` clauses for top-level data declarations, the + tcTyConScopedTyVars are brought into scope in through the `di_scoped_tvs` + field of GHC.Tc.Deriv.DerivInfo. Example (#16731): + + class C x1 x2 + + type T :: a -> Type + data T (x :: z) deriving (C z) + + When typechecking `C z`, we want `z` to map to `a`, which is exactly what the + tcTyConScopedTyVars for T give us. +-} + +instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where + 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 (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) } + _ -> do { vis <- get bh; return (NamedTCB vis) } } + + +{- ********************************************************************* +* * + The TyCon type +* * +************************************************************************ +-} + + +-- | TyCons represent type constructors. Type constructors are introduced by +-- things such as: +-- +-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of +-- kind @*@ +-- +-- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor +-- +-- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor +-- of kind @* -> *@ +-- +-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor +-- of kind @*@ +-- +-- This data type also encodes a number of primitive, built in type constructors +-- such as those for function and tuple types. +-- +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint +data TyCon = TyCon { + tyConUnique :: !Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: !Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConHasClosedResKind :: Bool, + + -- Cached values + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + tyConNullaryTy :: Type, -- ^ A pre-allocated @TyConApp tycon []@ + + tyConRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + tyConDetails :: !TyConDetails } + +data TyConDetails = + -- | Algebraic data types, from + -- - @data@ declarations + -- - @newtype@ declarations + -- - data instance declarations + -- - type instance declarations + -- - the TyCon generated by a class declaration + -- - boxed tuples + -- - unboxed tuples + -- - constraint tuples + -- - unboxed sums + -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. + -- See 'AlgTyConRhs' for more information. + AlgTyCon { + -- The tyConTyVars scope over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in algTyConRhs.NewTyCon + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data + -- constructors. + + tyConCType :: Maybe CType,-- ^ The C type that should be used + -- for this type when using the FFI + -- and CAPI + + algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT + -- syntax? If so, that doesn't mean it's a + -- true GADT; only that the "where" form + -- was used. This field is used only to + -- guide pretty-printing + + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data + -- type (always empty for GADTs). A + -- \"stupid theta\" is the context to + -- the left of an algebraic type + -- declaration, e.g. @Eq a@ in the + -- declaration @data Eq a => T a ...@. + -- See @Note [The stupid context]@ in + -- "GHC.Core.DataCon". + + algTcRhs :: AlgTyConRhs, -- ^ Contains information about the + -- data constructors of the algebraic type + + algTcFields :: FieldLabelEnv, -- ^ Maps a label to information + -- about the field + + algTcFlavour :: AlgTyConFlav -- ^ The flavour of this algebraic tycon. + -- Gives the class or family declaration + -- 'TyCon' for derived 'TyCon's representing + -- class or family instances, respectively. + + } + + -- | Represents type synonyms + | SynonymTyCon { + -- tyConTyVars scope over: synTcRhs + + synTcRhs :: Type, -- ^ Contains information about the expansion + -- of the synonym + + synIsTau :: Bool, -- True <=> the RHS of this synonym does not + -- have any foralls, after expanding any + -- nested synonyms + synIsFamFree :: Bool, -- True <=> the RHS of this synonym does not mention + -- any type synonym families (data families + -- are fine), again after expanding any + -- nested synonyms + synIsForgetful :: Bool -- 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. + } + + -- | Represents families (both type and data) + -- Argument roles are all Nominal + | FamilyTyCon { + -- tyConTyVars connect an associated family TyCon + -- with its parent class; see GHC.Tc.Validity.checkConsistentFamInst + + famTcResVar :: Maybe Name, -- ^ Name of result type variable, used + -- for pretty-printing with --show-iface + -- and for reifying TyCon in Template + -- Haskell + + famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, + -- abstract, built-in. See comments for + -- FamTyConFlav + + famTcParent :: Maybe TyCon, -- ^ For *associated* type/data families + -- The class tycon in which the family is declared + -- See Note [Associated families and their parent class] + + famTcInj :: Injectivity -- ^ is this a type family injective in + -- its type variables? Nothing if no + -- injectivity annotation was given + } + + -- | Primitive types; cannot be defined in Haskell. This includes + -- the usual suspects (such as @Int#@) as well as foreign-imported + -- types and kinds (@*@, @#@, and @?@) + | PrimTyCon { + primRepName :: TyConRepName -- ^ The 'Typeable' representation. + -- A cached version of + -- @'mkPrelTyConRepName' ('tyConName' tc)@. + } + + -- | Represents promoted data constructor. + | 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" + | TcTyCon { + -- NB: the tyConArity of a TcTyCon must match + -- the number of Required (positional, user-specified) + -- arguments to the type constructor; see the use + -- of tyConArity in generaliseTcTyCon + + tctc_scoped_tvs :: [(Name,TcTyVar)], + -- ^ Scoped tyvars over the tycon's body + -- The range is always a skolem or TcTyVar, be + -- MonoTcTyCon only: see Note [Scoped tyvars in a TcTyCon] + + tctc_is_poly :: Bool, -- ^ Is this TcTyCon already generalized? + -- Used only to make zonking more efficient + + tctc_flavour :: TyConFlavour + -- ^ What sort of 'TyCon' this represents. + } + +{- Note [Scoped tyvars in a TcTyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The tcTyConScopedTyVars field records the lexicial-binding connection +between the original, user-specified Name (i.e. thing in scope) and +the TcTyVar that the Name is bound to. + +Order *does* matter; the tcTyConScopedTyVars list consists of + specified_tvs ++ required_tvs + +where + * specified ones first + * required_tvs the same as tyConTyVars + * 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. + +Note [Representation-polymorphic TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To check for representation-polymorphism directly in the typechecker, +e.g. when using GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep, +we need to compute whether a type has a syntactically fixed RuntimeRep, +as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. + +It's useful to have a quick way to check whether a saturated application +of a type constructor has a fixed RuntimeRep. That is, we want +to know, given a TyCon 'T' of arity 'n', does + + T a_1 ... a_n + +always have a fixed RuntimeRep? That is, is it always the case +that this application has a kind of the form + + T a_1 ... a_n :: TYPE rep + +in which 'rep' is a concrete 'RuntimeRep'? +('Concrete' in the sense of Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete: +it contains no type-family applications or type variables.) + +To answer this question, we have 'tcHasFixedRuntimeRep'. +If 'tcHasFixedRuntimeRep' returns 'True', it means we're sure that +every saturated application of `T` has a fixed RuntimeRep. +However, if it returns 'False', we don't know: perhaps some application might not +have a fixed RuntimeRep. + +Examples: + + - For type families, we won't know in general whether an application + will have a fixed RuntimeRep: + + type F :: k -> k + type family F a where {..} + + `tcHasFixedRuntimeRep F = False' + + - For newtypes, we're usually OK: + + newtype N a b c = MkN Int + + No matter what arguments we apply `N` to, we always get something of + kind `Type`, which has a fixed RuntimeRep. + Thus `tcHasFixedRuntimeRep N = True`. + + However, with `-XUnliftedNewtypes`, we can have representation-polymorphic + newtypes: + + type UN :: TYPE rep -> TYPE rep + newtype UN a = MkUN a + + `tcHasFixedRuntimeRep UN = False` + + For example, `UN @Int8Rep Int8#` is represented by an 8-bit value, + while `UN @LiftedRep Int` is represented by a heap pointer. + + To distinguish whether we are dealing with a representation-polymorphic newtype, + we keep track of which situation we are in using the 'nt_fixed_rep' + field of the 'NewTyCon' constructor of 'AlgTyConRhs', and read this field + to compute 'tcHasFixedRuntimeRep'. + + - A similar story can be told for datatypes: we're usually OK, + except with `-XUnliftedDatatypes` which allows for levity polymorphism, + e.g.: + + type UC :: TYPE (BoxedRep l) -> TYPE (BoxedRep l) + type UC a = MkUC a + + `tcHasFixedRuntimeRep UC = False` + + Here, we keep track of whether we are dealing with a levity-polymorphic + unlifted datatype using the 'data_fixed_lev' field of the 'DataTyCon' + constructor of 'AlgTyConRhs'. + + N.B.: technically, the representation of a datatype is fixed, + as it is always a pointer. However, we currently require that we + know the specific `RuntimeRep`: knowing that it's `BoxedRep l` + for a type-variable `l` isn't enough. See #15532. +-} + +-- | Represents right-hand-sides of 'TyCon's for algebraic types +data AlgTyConRhs + + -- | Says that we know nothing about this data type, except that + -- it's represented by a pointer. Used when we export a data type + -- abstractly into an .hi file. + = AbstractTyCon + + -- | Information about those 'TyCon's derived from a @data@ + -- declaration. This includes data types with no constructors at + -- all. + | DataTyCon { + data_cons :: [DataCon], + -- ^ The data type constructors; can be empty if the + -- user declares the type to have no constructors + -- + -- INVARIANT: Kept in order of increasing 'DataCon' + -- tag (see the tag assignment in mkTyConTagMap) + data_cons_size :: Int, + -- ^ Cached value: length data_cons + is_enum :: Bool, -- ^ Cached value: is this an enumeration type? + -- See Note [Enumeration types] + is_type_data :: Bool, + -- from a "type data" declaration + -- See Note [Type data declarations] in GHC.Rename.Module + data_fixed_lev :: Bool + -- ^ 'True' if the data type constructor has + -- a known, fixed levity when fully applied + -- to its arguments, False otherwise. + -- + -- This can only be 'False' with UnliftedDatatypes, + -- e.g. + -- + -- > data A :: TYPE (BoxedRep l) where { MkA :: Int -> A } + -- + -- This boolean is cached to make it cheaper to check + -- for levity and representation-polymorphism in + -- tcHasFixedRuntimeRep. + } + + | TupleTyCon { -- A boxed, unboxed, or constraint tuple + data_con :: DataCon, -- NB: it can be an *unboxed* tuple + tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint + -- tuple? + } + + -- | An unboxed sum type. + | SumTyCon { + data_cons :: [DataCon], + data_cons_size :: Int -- ^ Cached value: length data_cons + } + + -- | Information about those 'TyCon's derived from a @newtype@ declaration + | NewTyCon { + data_con :: DataCon, -- ^ The unique constructor for the @newtype@. + -- It has no existentials + + nt_rhs :: Type, -- ^ Cached value: the argument type of the + -- constructor, which is just the representation + -- type of the 'TyCon' (remember that @newtype@s + -- do not exist at runtime so need a different + -- representation type). + -- + -- The free 'TyVar's of this type are the + -- 'tyConTyVars' from the corresponding 'TyCon' + + nt_etad_rhs :: ([TyVar], Type), + -- ^ Same as the 'nt_rhs', but this time eta-reduced. + -- Hence the list of 'TyVar's in this field may be + -- shorter than the declared arity of the 'TyCon'. + + -- See Note [Newtype eta] + nt_co :: CoAxiom Unbranched, + -- The axiom coercion that creates the @newtype@ + -- from the representation 'Type'. The axiom witnesses + -- a representational coercion: + -- nt_co :: N ty1 ~R# rep_tys + + -- See Note [Newtype coercions] + -- Invariant: arity = #tvs in nt_etad_rhs; + -- See Note [Newtype eta] + -- Watch out! If any newtypes become transparent + -- again check #1072. + nt_fixed_rep :: Bool + -- ^ 'True' if the newtype has a known, fixed representation + -- when fully applied to its arguments, 'False' otherwise. + -- This can only ever be 'False' with UnliftedNewtypes. + -- + -- Example: + -- + -- > newtype N (a :: TYPE r) = MkN a + -- + -- Invariant: nt_fixed_rep nt = tcHasFixedRuntimeRep (nt_rhs nt) + -- + -- This boolean is cached to make it cheaper to check if a + -- variable binding is representation-polymorphic + -- in tcHasFixedRuntimeRep. + } + +mkSumTyConRhs :: [DataCon] -> AlgTyConRhs +mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) + +-- | Create an 'AlgTyConRhs' from the data constructors, +-- for a potentially levity-polymorphic datatype (with `UnliftedDatatypes`). +mkLevPolyDataTyConRhs :: Bool -- ^ whether the 'DataCon' has a fixed levity + -> Bool -- ^ True if this is a "type data" declaration + -- See Note [Type data declarations] + -- in GHC.Rename.Module + -> [DataCon] + -> AlgTyConRhs +mkLevPolyDataTyConRhs fixed_lev type_data cons + = DataTyCon { + data_cons = cons, + data_cons_size = length cons, + is_enum = not (null cons) && all is_enum_con cons, + -- See Note [Enumeration types] in GHC.Core.TyCon + is_type_data = type_data, + data_fixed_lev = fixed_lev + } + where + is_enum_con con + | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) + <- dataConFullSig con + = null ex_tvs && null eq_spec && null theta && null arg_tys + +-- | Create an 'AlgTyConRhs' from the data constructors. +-- +-- Use 'mkLevPolyDataConRhs' if the datatype can be levity-polymorphic +-- or if it comes from a "data type" declaration +mkDataTyConRhs :: [DataCon] -> AlgTyConRhs +mkDataTyConRhs = mkLevPolyDataTyConRhs True False + +-- | Some promoted datacons signify extra info relevant to GHC. For example, +-- the `IntRep` constructor of `RuntimeRep` corresponds to the 'IntRep' +-- constructor of 'PrimRep'. This data structure allows us to store this +-- information right in the 'TyCon'. The other approach would be to look +-- up things like `RuntimeRep`'s `PrimRep` by known-key every time. +-- See also Note [Getting from RuntimeRep to PrimRep] in "GHC.Types.RepType" +data PromDataConInfo + = NoPromInfo -- ^ an ordinary promoted data con + | RuntimeRep ([Type] -> [PrimRep]) + -- ^ A constructor of `RuntimeRep`. The argument to the function should + -- be the list of arguments to the promoted datacon. + + | VecCount Int -- ^ A constructor of `VecCount` + + | VecElem PrimElemRep -- ^ A constructor of `VecElem` + + | Levity Levity -- ^ A constructor of `Levity` + +-- | Extract those 'DataCon's that we are able to learn about. Note +-- 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 + +-- | Describes the flavour of an algebraic type constructor. For +-- classes and data families, this flavour includes a reference to +-- the parent 'TyCon'. +data AlgTyConFlav + = -- | An ordinary algebraic type constructor. This includes unlifted and + -- representation-polymorphic datatypes and newtypes and unboxed tuples, + -- but NOT unboxed sums; see UnboxedSumTyCon. + VanillaAlgTyCon + TyConRepName -- For Typeable + + -- | An unboxed sum type constructor. This is distinct from VanillaAlgTyCon + -- because we currently don't allow unboxed sums to be Typeable since + -- there are too many of them. See #13276. + | UnboxedSumTyCon + + -- | Type constructors representing a class dictionary. + -- See Note [ATyCon for classes] in "GHC.Core.TyCo.Rep" + | ClassTyCon + Class -- INVARIANT: the classTyCon of this Class is the + -- current tycon + TyConRepName + + -- | Type constructors representing an *instance* of a *data* family. + -- Parameters: + -- + -- 1) The type family in question + -- + -- 2) Instance types; free variables are the 'tyConTyVars' + -- of the current 'TyCon' (not the family one). INVARIANT: + -- the number of types matches the arity of the family 'TyCon' + -- + -- 3) A 'CoTyCon' identifying the representation + -- type with the type instance family + | DataFamInstTyCon -- See Note [Data type families] + (CoAxiom Unbranched) -- The coercion axiom. + -- A *Representational* coercion, + -- of kind T ty1 ty2 ~R R:T a b c + -- where T is the family TyCon, + -- and R:T is the representation TyCon (ie this one) + -- and a,b,c are the tyConTyVars of this TyCon + -- + -- BUT may be eta-reduced; see + -- Note [Eta reduction for data families] in + -- GHC.Core.Coercion.Axiom + + -- Cached fields of the CoAxiom, but adjusted to + -- use the tyConTyVars of this TyCon + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- No shorter in length than the tyConTyVars of the family TyCon + -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv + + -- E.g. data instance T [a] = ... + -- gives a representation tycon: + -- data R:TList a = ... + -- axiom co a :: T [a] ~ R:TList a + -- with R:TList's algTcFlavour = DataFamInstTyCon T [a] co + +instance Outputable AlgTyConFlav where + ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" + ppr (UnboxedSumTyCon {}) = text "Unboxed sum" + ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls + ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" + <+> ppr tc <+> sep (map pprType tys) + +-- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class +-- name, if any +okParent :: Name -> AlgTyConFlav -> Bool +okParent _ (VanillaAlgTyCon {}) = True +okParent _ (UnboxedSumTyCon {}) = True +okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) +okParent _ (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc + +isNoParent :: AlgTyConFlav -> Bool +isNoParent (VanillaAlgTyCon {}) = True +isNoParent _ = False + +-------------------- + +data Injectivity + = NotInjective + | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) + deriving( Eq ) + +-- | Information pertaining to the expansion of a type synonym (@type@) +data FamTyConFlav + = -- | Represents an open type family without a fixed right hand + -- side. Additional instances can appear at any time. + -- + -- These are introduced by either a top level declaration: + -- + -- > data family T a :: * + -- + -- Or an associated data type declaration, within a class declaration: + -- + -- > class C a b where + -- > data T b :: * + DataFamilyTyCon + TyConRepName + + -- | An open type synonym family e.g. @type family F x y :: * -> *@ + | OpenSynFamilyTyCon + + -- | A closed type synonym family e.g. + -- @type family F x where { F Int = Bool }@ + | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched)) + -- See Note [Closed type families] + + -- | A closed type synonym family declared in an hs-boot file with + -- type family F a where .. + | AbstractClosedSynFamilyTyCon + + -- | Built-in type family used by the TypeNats solver + | BuiltInSynFamTyCon BuiltInSynFamily + +instance Outputable FamTyConFlav where + ppr (DataFamilyTyCon n) = text "data family" <+> ppr n + ppr OpenSynFamilyTyCon = text "open type family" + ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family" + ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax + ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family" + ppr (BuiltInSynFamTyCon _) = text "built-in type family" + +{- Note [Closed type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* In an open type family you can add new instances later. This is the + usual case. + +* In a closed type family you can only put equations where the family + is defined. + +A non-empty closed type family has a single axiom with multiple +branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed +type family with no equations does not have an axiom, because there is +nothing for the axiom to prove! + + +Note [Promoted data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All data constructors can be promoted to become a type constructor, +via the PromotedDataCon alternative in GHC.Core.TyCon. + +* The TyCon promoted from a DataCon has the *same* Name and Unique as + the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78) + is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) + +* We promote the *user* type of the DataCon. Eg + data T = MkT {-# UNPACK #-} !(Bool, Bool) + The promoted kind is + 'MkT :: (Bool,Bool) -> T + *not* + 'MkT :: Bool -> Bool -> T + +* Similarly for GADTs: + data G a where + MkG :: forall b. b -> G [b] + The promoted data constructor has kind + 'MkG :: forall b. b -> G [b] + *not* + 'MkG :: forall a b. (a ~# [b]) => b -> G a + +Note [Enumeration types] +~~~~~~~~~~~~~~~~~~~~~~~~ +We define datatypes with no constructors to *not* be +enumerations; this fixes trac #2578, Otherwise we +end up generating an empty table for + __closure_tbl +which is used by tagToEnum# to map Int# to constructors +in an enumeration. The empty table apparently upset +the linker. + +Moreover, all the data constructor must be enumerations, meaning +they have type (forall abc. T a b c). GADTs are not enumerations. +For example consider + data T a where + T1 :: T Int + T2 :: T Bool + T3 :: T a +What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. +See #4528. + +Note [Newtype coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +The NewTyCon field nt_co is a CoAxiom which is used for coercing from +the representation type of the newtype, to the newtype itself. For +example, + + newtype T a = MkT (a -> a) + +the NewTyCon for T will contain nt_co = CoT where CoT :: forall a. T a ~ a -> a. + +We might also eta-contract the axiom: see Note [Newtype eta]. + +Note [Newtype eta] +~~~~~~~~~~~~~~~~~~ +Consider + newtype Parser a = MkParser (IO a) deriving Monad +Are these two types equal? That is, does a coercion exist between them? + Monad Parser + Monad IO +(We need this coercion to make the derived instance for Monad Parser.) + +Well, yes. But to see that easily we eta-reduce the RHS type of +Parser, in this case to IO, so that even unsaturated applications of +Parser will work right. So instead of + axParser :: forall a. Parser a ~ IO a +we generate an eta-reduced axiom + axParser :: Parser ~ IO + +This eta reduction is done when the type constructor is built, in +GHC.Tc.TyCl.Build.mkNewTyConRhs, and cached in NewTyCon. + +Here's an example that I think showed up in practice. +Source code: + newtype T a = MkT [a] + newtype Foo m = MkFoo (forall a. m a -> Int) + + w1 :: Foo [] + w1 = ... + + w2 :: Foo T + w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) + +After desugaring, and discarding the data constructors for the newtypes, +we would like to get: + w2 = w1 `cast` Foo axT + +so that w2 and w1 share the same code. To do this, the coercion axiom +axT must have + kind: axT :: T ~ [] + and arity: 0 + +See also Note [Newtype eta and homogeneous axioms] in GHC.Tc.TyCl.Build. + +************************************************************************ +* * + TyConRepName +* * +********************************************************************* -} + +type TyConRepName = Name + -- The Name of the top-level declaration for the Typeable world + -- $tcMaybe :: Data.Typeable.Internal.TyCon + -- $tcMaybe = TyCon { tyConName = "Maybe", ... } + +tyConRepName_maybe :: TyCon -> Maybe TyConRepName +tyConRepName_maybe (TyCon { tyConDetails = details }) = get_rep_nm details + where + get_rep_nm (PrimTyCon { primRepName = rep_nm }) + = Just rep_nm + get_rep_nm (AlgTyCon { algTcFlavour = parent }) + = case parent of + VanillaAlgTyCon rep_nm -> Just rep_nm + UnboxedSumTyCon -> Nothing + ClassTyCon _ rep_nm -> Just rep_nm + DataFamInstTyCon {} -> Nothing + get_rep_nm (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) + = Just rep_nm + get_rep_nm (PromotedDataCon { dataCon = dc, tcRepName = rep_nm }) + | isUnboxedSumDataCon dc -- see #13276 + = Nothing + | otherwise + = Just rep_nm + get_rep_nm _ = Nothing + +-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type +mkPrelTyConRepName :: Name -> TyConRepName +-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". +mkPrelTyConRepName tc_name -- Prelude tc_name is always External, + -- so nameModule will work + = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) + where + name_occ = nameOccName tc_name + name_mod = nameModule tc_name + name_uniq = nameUnique tc_name + rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq + | otherwise = dataConTyRepNameUnique name_uniq + (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ + +-- | The name (and defining module) for the Typeable representation (TyCon) of a +-- type constructor. +-- +-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable". +tyConRepModOcc :: Module -> OccName -> (Module, OccName) +tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ) + where + rep_module + | tc_module == gHC_PRIM = gHC_TYPES + | otherwise = tc_module + + +{- ********************************************************************* +* * + PrimRep +* * +************************************************************************ + +Note [rep swamp] +~~~~~~~~~~~~~~~~ +GHC has a rich selection of types that represent "primitive types" of +one kind or another. Each of them makes a different set of +distinctions, and mostly the differences are for good reasons, +although it's probably true that we could merge some of these. + +Roughly in order of "includes more information": + + - A Width ("GHC.Cmm.Type") is simply a binary value with the specified + number of bits. It may represent a signed or unsigned integer, a + floating-point value, or an address. + + data Width = W8 | W16 | W32 | W64 | W128 + + - Size, which is used in the native code generator, is Width + + floating point information. + + data Size = II8 | II16 | II32 | II64 | FF32 | FF64 + + it is necessary because e.g. the instruction to move a 64-bit float + on x86 (movsd) is different from the instruction to move a 64-bit + integer (movq), so the mov instruction is parameterised by Size. + + - CmmType wraps Width with more information: GC ptr, float, or + other value. + + data CmmType = CmmType CmmCat Width + + data CmmCat -- "Category" (not exported) + = GcPtrCat -- GC pointer + | BitsCat -- Non-pointer + | FloatCat -- Float + + It is important to have GcPtr information in Cmm, since we generate + info tables containing pointerhood for the GC from this. As for + why we have float (and not signed/unsigned) here, see Note [Signed + vs unsigned]. + + - ArgRep makes only the distinctions necessary for the call and + return conventions of the STG machine. It is essentially CmmType + + void. + + - PrimRep makes a few more distinctions than ArgRep: it divides + non-GC-pointers into signed/unsigned and addresses, information + that is necessary for passing these values to foreign functions. + +There's another tension here: whether the type encodes its size in +bytes, or whether its size depends on the machine word size. Width +and CmmType have the size built-in, whereas ArgRep and PrimRep do not. + +This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. + +On the other hand, CmmType includes some "nonsense" values, such as +CmmType GcPtrCat W32 on a 64-bit machine. + +The PrimRep type is closely related to the user-visible RuntimeRep type. +See Note [RuntimeRep and PrimRep] in GHC.Types.RepType. + +-} + +-- | A 'PrimRep' is an abstraction of a type. 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 + | Int8Rep -- ^ Signed, 8-bit value + | Int16Rep -- ^ Signed, 16-bit value + | Int32Rep -- ^ Signed, 32-bit value + | Int64Rep -- ^ Signed, 64 bit value + | IntRep -- ^ Signed, word-sized value + | Word8Rep -- ^ Unsigned, 8 bit value + | Word16Rep -- ^ Unsigned, 16 bit value + | 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') + | FloatRep + | DoubleRep + | VecRep Int PrimElemRep -- ^ A vector + deriving( Data.Data, Eq, Ord, Show ) + +data PrimElemRep + = Int8ElemRep + | Int16ElemRep + | Int32ElemRep + | Int64ElemRep + | Word8ElemRep + | Word16ElemRep + | Word32ElemRep + | Word64ElemRep + | FloatElemRep + | DoubleElemRep + deriving( Data.Data, Eq, Ord, Show, Enum ) + +instance Outputable PrimRep where + ppr r = text (show r) + +instance Outputable PrimElemRep where + 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 Int8Rep = putByte bh 3 + put_ bh Int16Rep = putByte bh 4 + put_ bh Int32Rep = putByte bh 5 + put_ bh Int64Rep = putByte bh 6 + put_ bh IntRep = putByte bh 7 + put_ bh Word8Rep = putByte bh 8 + put_ bh Word16Rep = putByte bh 9 + put_ bh Word32Rep = putByte bh 10 + put_ bh Word64Rep = putByte bh 11 + put_ bh WordRep = putByte bh 12 + put_ bh AddrRep = putByte bh 13 + put_ bh FloatRep = putByte bh 14 + put_ bh DoubleRep = putByte bh 15 + put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per + get bh = do + h <- getByte bh + case h of + 0 -> pure VoidRep + 1 -> pure LiftedRep + 2 -> pure UnliftedRep + 3 -> pure Int8Rep + 4 -> pure Int16Rep + 5 -> pure Int32Rep + 6 -> pure Int64Rep + 7 -> pure IntRep + 8 -> pure Word8Rep + 9 -> pure Word16Rep + 10 -> pure Word32Rep + 11 -> pure Word64Rep + 12 -> pure WordRep + 13 -> pure AddrRep + 14 -> pure FloatRep + 15 -> pure DoubleRep + 16 -> VecRep <$> get bh <*> get bh + _ -> pprPanic "Binary:PrimRep" (int (fromIntegral h)) + +instance Binary PrimElemRep where + put_ bh per = putByte bh (fromIntegral (fromEnum per)) + get bh = toEnum . fromIntegral <$> getByte bh + +isVoidRep :: PrimRep -> Bool +isVoidRep VoidRep = True +isVoidRep _other = False + +isGcPtrRep :: PrimRep -> Bool +isGcPtrRep LiftedRep = True +isGcPtrRep UnliftedRep = 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. +primRepCompatible :: Platform -> PrimRep -> PrimRep -> Bool +primRepCompatible platform rep1 rep2 = + (isUnboxed rep1 == isUnboxed rep2) && + (primRepSizeB platform rep1 == primRepSizeB platform rep2) && + (primRepIsFloat rep1 == primRepIsFloat rep2) + where + isUnboxed = not . isGcPtrRep + +-- More general version of `primRepCompatible` for types represented by zero or +-- more than one PrimReps. +primRepsCompatible :: Platform -> [PrimRep] -> [PrimRep] -> Bool +primRepsCompatible platform reps1 reps2 = + length reps1 == length reps2 && + and (zipWith (primRepCompatible platform) reps1 reps2) + +-- | The size of a 'PrimRep' in bytes. +-- +-- This applies also when used in a constructor, where we allow packing the +-- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will +-- take only 8 bytes, which for 64-bit arch will be equal to 1 word. +-- See also mkVirtHeapOffsetsWithPadding for details of how data fields are +-- laid out. +primRepSizeB :: Platform -> PrimRep -> Int +primRepSizeB platform = \case + IntRep -> platformWordSizeInBytes platform + WordRep -> platformWordSizeInBytes platform + Int8Rep -> 1 + Int16Rep -> 2 + Int32Rep -> 4 + Int64Rep -> 8 + Word8Rep -> 1 + Word16Rep -> 2 + Word32Rep -> 4 + Word64Rep -> 8 + FloatRep -> fLOAT_SIZE + DoubleRep -> dOUBLE_SIZE + AddrRep -> platformWordSizeInBytes platform + LiftedRep -> platformWordSizeInBytes platform + UnliftedRep -> platformWordSizeInBytes platform + VoidRep -> 0 + (VecRep len rep) -> len * primElemRepSizeB platform rep + +primElemRepSizeB :: Platform -> PrimElemRep -> Int +primElemRepSizeB platform = primRepSizeB platform . primElemRepToPrimRep + +primElemRepToPrimRep :: PrimElemRep -> PrimRep +primElemRepToPrimRep Int8ElemRep = Int8Rep +primElemRepToPrimRep Int16ElemRep = Int16Rep +primElemRepToPrimRep Int32ElemRep = Int32Rep +primElemRepToPrimRep Int64ElemRep = Int64Rep +primElemRepToPrimRep Word8ElemRep = Word8Rep +primElemRepToPrimRep Word16ElemRep = Word16Rep +primElemRepToPrimRep Word32ElemRep = Word32Rep +primElemRepToPrimRep Word64ElemRep = Word64Rep +primElemRepToPrimRep FloatElemRep = FloatRep +primElemRepToPrimRep DoubleElemRep = DoubleRep + +-- | Return if Rep stands for floating type, +-- returns Nothing for vector types. +primRepIsFloat :: PrimRep -> Maybe Bool +primRepIsFloat FloatRep = Just True +primRepIsFloat DoubleRep = Just True +primRepIsFloat (VecRep _ _) = Nothing +primRepIsFloat _ = Just False + +-- Rep is one of the word reps. +primRepIsWord :: PrimRep -> Bool +primRepIsWord WordRep = True +primRepIsWord (Word8Rep) = True +primRepIsWord (Word16Rep) = True +primRepIsWord (Word32Rep) = True +primRepIsWord (Word64Rep) = True +primRepIsWord _ = False + +-- Rep is one of the int reps. +primRepIsInt :: PrimRep -> Bool +primRepIsInt (IntRep) = True +primRepIsInt (Int8Rep) = True +primRepIsInt (Int16Rep) = True +primRepIsInt (Int32Rep) = True +primRepIsInt (Int64Rep) = True +primRepIsInt _ = False + +{- +************************************************************************ +* * + Field labels +* * +************************************************************************ +-} + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabels :: TyCon -> [FieldLabel] +tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabelEnv :: TyCon -> FieldLabelEnv +tyConFieldLabelEnv (TyCon { tyConDetails = details }) + | AlgTyCon { algTcFields = fields } <- details = fields + | otherwise = emptyDFsEnv + +-- | Look up a field label belonging to this 'TyCon' +lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel +lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) (field_label lbl) + +-- | Make a map from strings to FieldLabels from all the data +-- constructors of this algebraic tycon +fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv +fieldsOfAlgTcRhs rhs = mkDFsEnv [ (field_label $ flLabel fl, fl) + | fl <- dataConsFields (visibleDataCons rhs) ] + where + -- Duplicates in this list will be removed by 'mkFsEnv' + dataConsFields dcs = concatMap dataConFieldLabels dcs + + +{- +************************************************************************ +* * +\subsection{TyCon Construction} +* * +************************************************************************ + +Note: the TyCon constructors all take a Kind as one argument, even though +they could, in principle, work out their Kind from their other arguments. +But to do so they need functions from Types, and that makes a nasty +module mutual-recursion. And they aren't called from many places. +So we compromise, and move their Kind calculation to the call site. +-} + +mkTyCon :: Name -> [TyConBinder] -> Kind -> [Role] -> TyConDetails -> TyCon +mkTyCon name binders res_kind roles details + = tc + where + -- Recurisve binding because of tcNullaryTy + tc = TyCon { tyConName = name + , tyConUnique = nameUnique name + , tyConBinders = binders + , tyConResKind = res_kind + , tyConRoles = roles + , tyConDetails = details + + -- Cached things + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tyConNullaryTy = mkNakedTyConTy tc + , tyConHasClosedResKind = noFreeVarsOfType res_kind + , tyConTyVars = binderVars binders } + +-- | This is the making of an algebraic 'TyCon'. +mkAlgTyCon :: Name + -> [TyConBinder] -- ^ Binders of the 'TyCon' + -> Kind -- ^ Result kind + -> [Role] -- ^ The roles for each TyVar + -> Maybe CType -- ^ The C type this type corresponds to + -- when using the CAPI FFI + -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' + -> AlgTyConRhs -- ^ Information about data constructors + -> AlgTyConFlav -- ^ What flavour is it? + -- (e.g. vanilla, type family) + -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? + -> TyCon +mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn + = mkTyCon name binders res_kind roles $ + AlgTyCon { tyConCType = cType + , algTcStupidTheta = stupid + , algTcRhs = rhs + , algTcFields = fieldsOfAlgTcRhs rhs + , algTcFlavour = assertPpr (okParent name parent) + (ppr name $$ ppr parent) parent + , algTcGadtSyntax = gadt_syn } + +-- | Simpler specialization of 'mkAlgTyCon' for classes +mkClassTyCon :: Name -> [TyConBinder] + -> [Role] -> AlgTyConRhs -> Class + -> Name -> TyCon +mkClassTyCon name binders roles rhs clas tc_rep_name + = mkAlgTyCon name binders constraintKind roles Nothing [] rhs + (ClassTyCon clas tc_rep_name) + False + +mkTupleTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Result kind of the 'TyCon' + -> DataCon + -> TupleSort -- ^ Whether the tuple is boxed or unboxed + -> AlgTyConFlav + -> TyCon +mkTupleTyCon name binders res_kind con sort parent + = mkTyCon name binders res_kind (constRoles binders Representational) $ + AlgTyCon { tyConCType = Nothing + , algTcGadtSyntax = False + , algTcStupidTheta = [] + , algTcRhs = TupleTyCon { data_con = con + , tup_sort = sort } + , algTcFields = emptyDFsEnv + , algTcFlavour = parent } + +constRoles :: [TyConBinder] -> Role -> [Role] +constRoles bndrs role = [role | _ <- bndrs] + +mkSumTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Kind of the resulting 'TyCon' + -> [DataCon] + -> AlgTyConFlav + -> TyCon +mkSumTyCon name binders res_kind cons parent + = mkTyCon name binders res_kind (constRoles binders Representational) $ + AlgTyCon { tyConCType = Nothing + , algTcGadtSyntax = False + , algTcStupidTheta = [] + , algTcRhs = mkSumTyConRhs cons + , algTcFields = emptyDFsEnv + , algTcFlavour = parent } + +-- | Makes a tycon suitable for use during type-checking. It stores +-- a variety of details about the definition of the TyCon, but no +-- 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". +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 + -> TyCon +mkTcTyCon name binders res_kind scoped_tvs poly flav + = mkTyCon name binders res_kind (constRoles binders Nominal) $ + TcTyCon { tctc_scoped_tvs = scoped_tvs + , tctc_is_poly = poly + , tctc_flavour = flav } + +-- | No scoped type variables (to be used with mkTcTyCon). +noTcTyConScopedTyVars :: [(Name, TcTyVar)] +noTcTyConScopedTyVars = [] + +-- | 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] + -> Kind -- ^ /result/ kind + -- Must answer 'True' to 'isFixedRuntimeRepKind' (i.e., no representation polymorphism). + -- (If you need a representation-polymorphic PrimTyCon, + -- change tcHasFixedRuntimeRep, marshalablePrimTyCon, reifyTyCon for PrimTyCons.) + -> [Role] + -> TyCon +mkPrimTyCon name binders res_kind roles + = mkTyCon name binders res_kind roles $ + PrimTyCon { primRepName = mkPrelTyConRepName name } + +-- | 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 + = mkTyCon name binders res_kind roles $ + SynonymTyCon { synTcRhs = rhs + , synIsTau = is_tau + , synIsFamFree = is_fam_free + , synIsForgetful = is_forgetful } + +-- | Create a type family 'TyCon' +mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> Maybe Name -> FamTyConFlav + -> Maybe Class -> Injectivity -> TyCon +mkFamilyTyCon name binders res_kind resVar flav parent inj + = mkTyCon name binders res_kind (constRoles binders Nominal) $ + FamilyTyCon { famTcResVar = resVar + , famTcFlav = flav + , famTcParent = classTyCon <$> parent + , famTcInj = inj } + +-- | Create a promoted data constructor 'TyCon' +-- Somewhat dodgily, we give it the same Name +-- 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] + -> PromDataConInfo -> TyCon +mkPromotedDataCon con name rep_name binders res_kind roles rep_info + = mkTyCon name binders res_kind roles $ + PromotedDataCon { dataCon = con + , tcRepName = rep_name + , promDcInfo = rep_info } + +-- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) +isAbstractTyCon :: TyCon -> Bool +isAbstractTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = AbstractTyCon {} } <- details = True + | otherwise = False + +-- | Does this 'TyCon' represent something that cannot be defined in Haskell? +isPrimTyCon :: TyCon -> Bool +isPrimTyCon (TyCon { tyConDetails = details }) + | PrimTyCon {} <- details = True + | otherwise = False + +-- | Returns @True@ if the supplied 'TyCon' resulted from either a +-- @data@ or @newtype@ declaration +isAlgTyCon :: TyCon -> Bool +isAlgTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {} <- details = True + | otherwise = False + +-- | Returns @True@ for vanilla AlgTyCons -- that is, those created +-- with a @data@ or @newtype@ declaration. +isVanillaAlgTyCon :: TyCon -> Bool +isVanillaAlgTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcFlavour = VanillaAlgTyCon _ } <- details = True + | otherwise = False + +isDataTyCon :: 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 +-- 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 }) + | AlgTyCon {algTcRhs = rhs} <- details + = case rhs of + TupleTyCon { tup_sort = sort } + -> isBoxed (tupleSortBoxity sort) + SumTyCon {} -> False + -- Constructors from "type data" declarations exist only at + -- the type level. + -- See Note [Type data declarations] in GHC.Rename.Module. + DataTyCon { is_type_data = type_data } -> not type_data + NewTyCon {} -> False + AbstractTyCon {} -> False -- We don't know, so return False +isDataTyCon _ = False + +-- | Was this 'TyCon' declared as "type data"? +-- See Note [Type data declarations] in GHC.Rename.Module. +isTypeDataTyCon :: TyCon -> Bool +isTypeDataTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = DataTyCon {is_type_data = type_data }} <- details + = type_data + | otherwise = False + +-- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds +-- (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" +isInjectiveTyCon :: TyCon -> Role -> Bool +isInjectiveTyCon (TyCon { tyConDetails = details }) role + = go details role + 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 (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 + + -- Reply True for TcTyCon to minimise knock on type errors + -- See Note [How TcTyCons work] item (1) in GHC.Tc.TyCl + + +-- | '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" +isGenerativeTyCon :: TyCon -> Role -> Bool +isGenerativeTyCon tc@(TyCon { tyConDetails = details }) role + = go role details + where + go Nominal (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) = True + go _ (FamilyTyCon {}) = False + + -- 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 }) + | AlgTyCon {algTcRhs = NewTyCon {}} <- details = True + | otherwise = False + +-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it +-- expands into, and (possibly) a coercion from the representation type to the +-- @newtype@. +-- Returns @Nothing@ if this is not possible. +unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyCon_maybe (TyCon { tyConTyVars = tvs, tyConDetails = details }) + | AlgTyCon { algTcRhs = NewTyCon { nt_co = co, nt_rhs = rhs }} <- details + = Just (tvs, rhs, co) + | otherwise = Nothing + +unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyConEtad_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = NewTyCon { nt_co = co + , nt_etad_rhs = (tvs,rhs) }} <- details + = Just (tvs, rhs, co) + | otherwise = Nothing + +-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? +{-# INLINE isTypeSynonymTyCon #-} -- See Note [Inlining coreView] in GHC.Core.Type +isTypeSynonymTyCon :: TyCon -> Bool +isTypeSynonymTyCon (TyCon { tyConDetails = details }) + | SynonymTyCon {} <- details = True + | otherwise = False + +isTauTyCon :: TyCon -> Bool +isTauTyCon (TyCon { tyConDetails = details }) + | SynonymTyCon { synIsTau = is_tau } <- details = is_tau + | otherwise = True + +-- | Is this tycon neither a type family nor a synonym that expands +-- to a type family? +isFamFreeTyCon :: TyCon -> Bool +isFamFreeTyCon (TyCon { tyConDetails = details }) + | SynonymTyCon { synIsFamFree = fam_free } <- details = fam_free + | FamilyTyCon { famTcFlav = flav } <- details = isDataFamFlav flav + | otherwise = True + +-- | Is this a forgetful type synonym? If this is a type synonym whose +-- RHS does not mention one (or more) of its bound variables, returns +-- 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. +isForgetfulSynTyCon :: TyCon -> Bool +isForgetfulSynTyCon (TyCon { tyConDetails = details }) + | SynonymTyCon { synIsForgetful = forget } <- details = forget + | otherwise = False + +-- 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. +-- + +-- | True iff we can decompose (T a b c) into ((T a b) c) +-- I.e. is it injective and generative w.r.t nominal equality? +-- That is, if (T a b) ~N d e f, is it always the case that +-- (T ~N d), (a ~N e) and (b ~N f)? +-- Specifically NOT true of synonyms (open and otherwise) +-- +-- It'd be unusual to call tyConMustBeSaturated on a regular H98 +-- type synonym, because you should probably have expanded it first +-- But regardless, it's not decomposable +tyConMustBeSaturated :: TyCon -> Bool +tyConMustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour + +-- | Is this an algebraic 'TyCon' declared with the GADT syntax? +isGadtSyntaxTyCon :: TyCon -> Bool +isGadtSyntaxTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcGadtSyntax = res } <- details = res + | otherwise = False + +-- | Is this an algebraic 'TyCon' which is just an enumeration of values? +isEnumerationTyCon :: TyCon -> Bool +-- See Note [Enumeration types] in GHC.Core.TyCon +isEnumerationTyCon (TyCon { tyConArity = arity, tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + = case rhs of + DataTyCon { is_enum = res } -> res + TupleTyCon {} -> arity == 0 + _ -> False + | otherwise = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family? +isFamilyTyCon :: TyCon -> Bool +isFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon {} <- details = True + | otherwise = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family with +-- instances? +isOpenFamilyTyCon :: TyCon -> Bool +isOpenFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = flav } <- details + = case flav of + OpenSynFamilyTyCon -> True + DataFamilyTyCon {} -> True + _ -> False + | otherwise = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +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? +isDataFamilyTyCon :: TyCon -> Bool +isDataFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon { famTcFlav = flav } <- details = isDataFamFlav flav + | otherwise = False + +-- | Is this an open type family TyCon? +isOpenTypeFamilyTyCon :: TyCon -> Bool +isOpenTypeFamilyTyCon (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = OpenSynFamilyTyCon } <- details = True + | otherwise = False + +-- | Is this a non-empty closed type family? Returns 'Nothing' for +-- abstract or empty closed families. +isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched) +isClosedSynFamilyTyConWithAxiom_maybe (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb} <- details = mb + | otherwise = Nothing + +isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily +isBuiltInSynFamTyCon_maybe (TyCon { tyConDetails = details }) + | 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 + +-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an +-- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is +-- injective), or 'NotInjective' otherwise. +tyConInjectivityInfo :: TyCon -> Injectivity +tyConInjectivityInfo tc@(TyCon { tyConDetails = details }) + | FamilyTyCon { famTcInj = inj } <- details + = inj + | isInjectiveTyCon tc Nominal + = Injective (replicate (tyConArity tc) True) + | otherwise + = NotInjective + +isDataFamFlav :: FamTyConFlav -> Bool +isDataFamFlav (DataFamilyTyCon {}) = True -- Data family +isDataFamFlav _ = False -- Type synonym family + +-- | Is this TyCon for an associated type? +isTyConAssoc :: TyCon -> Bool +isTyConAssoc = isJust . tyConAssoc_maybe + +-- | Get the enclosing class TyCon (if there is one) for the given TyCon. +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 +isTupleTyCon :: TyCon -> Bool +-- ^ Does this 'TyCon' represent a tuple? +-- +-- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to +-- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they +-- get spat into the interface file as tuple tycons, so I don't think +-- it matters. +isTupleTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = TupleTyCon {} } <- details = True + | otherwise = False + +tyConTuple_maybe :: TyCon -> Maybe TupleSort +tyConTuple_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + , TupleTyCon { tup_sort = sort} <- rhs = Just sort + | otherwise = Nothing + +-- | Is this the 'TyCon' for an unboxed tuple? +isUnboxedTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + , TupleTyCon { tup_sort = sort } <- rhs + = not (isBoxed (tupleSortBoxity sort)) + | otherwise = False + +-- | Is this the 'TyCon' for a boxed tuple? +isBoxedTupleTyCon :: TyCon -> Bool +isBoxedTupleTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + , TupleTyCon { tup_sort = sort } <- rhs + = isBoxed (tupleSortBoxity sort) + | otherwise = False + +-- | Is this the 'TyCon' for an unboxed sum? +isUnboxedSumTyCon :: TyCon -> Bool +isUnboxedSumTyCon (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + , SumTyCon {} <- rhs + = True + | otherwise = False + +isLiftedAlgTyCon :: TyCon -> Bool +isLiftedAlgTyCon (TyCon { tyConResKind = res_kind, tyConDetails = details }) + | AlgTyCon {} <- details = isLiftedTypeKind res_kind + | otherwise = False + +-- | Retrieves the promoted DataCon if this is a PromotedDataCon; +isPromotedDataCon_maybe :: TyCon -> Maybe DataCon +isPromotedDataCon_maybe (TyCon { tyConDetails = details }) + | PromotedDataCon { dataCon = dc } <- details = Just dc + | otherwise = Nothing + +-- | Is this the 'TyCon' for a /promoted/ tuple? +isPromotedTupleTyCon :: TyCon -> Bool +isPromotedTupleTyCon tyCon + | Just dataCon <- isPromotedDataCon_maybe tyCon + , isTupleTyCon (dataConTyCon dataCon) = True + | otherwise = False + +-- | Is this a PromotedDataCon? +isPromotedDataCon :: TyCon -> Bool +isPromotedDataCon (TyCon { tyConDetails = details }) + | PromotedDataCon {} <- details = True + | otherwise = False + +-- | This function identifies PromotedDataCon's from data constructors in +-- `data T = K1 | K2`, promoted by -XDataKinds. These type constructors +-- are printed with a tick mark 'K1 and 'K2, and similarly have a tick +-- mark added to their OccName's. +-- +-- In contrast, constructors in `type data T = K1 | K2` are printed and +-- represented with their original undecorated names. +-- See Note [Type data declarations] in GHC.Rename.Module +isDataKindsPromotedDataCon :: TyCon -> Bool +isDataKindsPromotedDataCon (TyCon { tyConDetails = details }) + | PromotedDataCon { dataCon = dc } <- details + = not (isTypeDataCon dc) + | otherwise = False + +-- | Is this tycon really meant for use at the kind level? That is, +-- should it be permitted without -XDataKinds? +isKindTyCon :: TyCon -> Bool +isKindTyCon tc = getUnique tc `elementOfUniqSet` 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 ] ) + where + tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) + +isLiftedTypeKindTyConName :: Name -> Bool +isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) + +-- | Identifies implicit tycons that, in particular, do not go into interface +-- files (because they are implicitly reconstructed when the interface is +-- read). +-- +-- Note that: +-- +-- * Associated families are implicit, as they are re-constructed from +-- the class declaration in which they reside, and +-- +-- * Family instances are /not/ implicit as they represent the instance body +-- (similar to a @dfun@ does that for a class instance). +-- +-- * Tuples are implicit iff they have a wired-in name +-- (namely: boxed and unboxed tuples are wired-in and implicit, +-- but constraint tuples are not) +isImplicitTyCon :: TyCon -> Bool +isImplicitTyCon (TyCon { tyConName = name, tyConDetails = details }) = go details + where + go (PrimTyCon {}) = True + go (PromotedDataCon {}) = True + go (SynonymTyCon {}) = False + go (TcTyCon {}) = False + go (FamilyTyCon { famTcParent = parent }) = isJust parent + go (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon {} <- rhs = isWiredInName name + | SumTyCon {} <- rhs = True + | otherwise = False + +tyConCType_maybe :: TyCon -> Maybe CType +tyConCType_maybe (TyCon { tyConDetails = details }) + | AlgTyCon { tyConCType = mb_ctype} <- details = mb_ctype + | otherwise = Nothing + +-- | Does this 'TyCon' have a syntactically fixed RuntimeRep when fully applied, +-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete? +-- +-- False is safe. True means we're sure. +-- Does only a quick check, based on the TyCon's category. +-- +-- See Note [Representation-polymorphic TyCons] +tcHasFixedRuntimeRep :: TyCon -> Bool +tcHasFixedRuntimeRep tc@(TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + = case rhs of + AbstractTyCon {} -> False + -- An abstract TyCon might not have a fixed runtime representation. + -- Note that this is an entirely different matter from the concreteness + -- of the 'TyCon', in the sense of 'isConcreteTyCon'. + + DataTyCon { data_fixed_lev = fixed_lev } -> fixed_lev + -- A datatype might not have a fixed levity with UnliftedDatatypes (#20423). + -- NB: the current representation-polymorphism checks require that + -- 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) + + SumTyCon {} -> False -- only unboxed sums here + + NewTyCon { nt_fixed_rep = fixed_rep } -> fixed_rep + -- A newtype might not have a fixed runtime representation + -- with UnliftedNewtypes (#17360) + + | SynonymTyCon {} <- details = False -- conservative choice + | FamilyTyCon{} <- details = False + | PrimTyCon{} <- details = True + | TcTyCon{} <- details = False + | PromotedDataCon{} <- details = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc) + +-- | Is this 'TyCon' concrete (i.e. not a synonym/type family)? +-- +-- Used for representation polymorphism checks. +isConcreteTyCon :: TyCon -> Bool +isConcreteTyCon = isConcreteTyConFlavour . tyConFlavour + +-- | 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 + +{- +----------------------------------------------- +-- TcTyCon +----------------------------------------------- +-} + +-- | Is this a TcTyCon? (That is, one only used during type-checking?) +isTcTyCon :: TyCon -> Bool +isTcTyCon (TyCon { tyConDetails = details }) + | TcTyCon {} <- details = True + | otherwise = False + +setTcTyConKind :: TyCon -> Kind -> TyCon +-- Update the Kind of a TcTyCon +-- The new kind is always a zonked version of its previous +-- kind, so we don't need to update any other fields. +-- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType +setTcTyConKind tc kind + = assert (isMonoTcTyCon tc) $ + let tc' = tc { tyConKind = kind + , tyConNullaryTy = mkNakedTyConTy tc' } + -- See Note [Sharing nullary TyConApps] + in tc' + +isMonoTcTyCon :: TyCon -> Bool +isMonoTcTyCon (TyCon { tyConDetails = details }) + | TcTyCon { tctc_is_poly = is_poly } <- details = not is_poly + | otherwise = False + +tcTyConScopedTyVars :: TyCon -> [(Name,TcTyVar)] +tcTyConScopedTyVars tc@(TyCon { tyConDetails = details }) + | TcTyCon { tctc_scoped_tvs = scoped_tvs } <- details = scoped_tvs + | otherwise = pprPanic "tcTyConScopedTyVars" (ppr tc) + +{- +----------------------------------------------- +-- Expand type-constructor applications +----------------------------------------------- +-} + +data ExpandSynResult tyco + = NoExpansion + | ExpandsSyn [(TyVar,tyco)] Type [tyco] + +expandSynTyCon_maybe + :: TyCon + -> [tyco] -- ^ Arguments to 'TyCon' + -> ExpandSynResult tyco -- ^ Returns a 'TyVar' substitution, the body + -- type of the synonym (not yet substituted) + -- and any arguments remaining from the + -- application +-- ^ Expand a type synonym application +-- Return Nothing if the TyCon is not a synonym, +-- or if not enough arguments are supplied +expandSynTyCon_maybe (TyCon { tyConTyVars = tvs, tyConArity = arity + , tyConDetails = details }) tys + | SynonymTyCon { synTcRhs = rhs } <- details + = if arity == 0 + then ExpandsSyn [] rhs tys -- Avoid a bit of work in the case of nullary synonyms + else case tys `listLengthCmp` arity of + GT -> ExpandsSyn (tvs `zip` tys) rhs (drop arity tys) + EQ -> ExpandsSyn (tvs `zip` tys) rhs [] + LT -> NoExpansion + | otherwise + = NoExpansion + +---------------- + +-- | Check if the tycon actually refers to a proper `data` or `newtype` +-- with user defined constructors rather than one from a class or other +-- construction. + +-- NB: This is only used in GHC.Tc.Gen.Export.checkPatSynParent to determine if an +-- exported tycon can have a pattern synonym bundled with it, e.g., +-- module Foo (TyCon(.., PatSyn)) where +isTyConWithSrcDataCons :: TyCon -> Bool +isTyConWithSrcDataCons (TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs, algTcFlavour = parent } <- details + , let isSrcParent = isNoParent parent + = case rhs of + DataTyCon {} -> isSrcParent + NewTyCon {} -> isSrcParent + TupleTyCon {} -> isSrcParent + _ -> False + | FamilyTyCon { famTcFlav = DataFamilyTyCon {} } <- details + = True -- #14058 + | otherwise = False + + +-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no +-- constructors could be found +tyConDataCons :: TyCon -> [DataCon] +-- It's convenient for tyConDataCons to return the +-- empty list for type synonyms etc +tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] + +-- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' +-- is the sort that can have any constructors (note: this does not include +-- abstract algebraic types) +tyConDataCons_maybe :: TyCon -> Maybe [DataCon] +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 +tyConDataCons_maybe _ = Nothing + +-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ +-- type with one alternative, a tuple type or a @newtype@ then that constructor +-- is returned. If the 'TyCon' has more than one constructor, or represents a +-- primitive or function type constructor then @Nothing@ is returned. +tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon +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 + +-- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'. +tyConSingleDataCon :: TyCon -> DataCon +tyConSingleDataCon tc + = case tyConSingleDataCon_maybe tc of + 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 +tyConFamilySize tc@(TyCon { tyConDetails = details }) + | AlgTyCon { algTcRhs = rhs } <- details + = case rhs of + DataTyCon { data_cons_size = size } -> size + NewTyCon {} -> 1 + TupleTyCon {} -> 1 + SumTyCon { data_cons_size = size } -> size + _ -> pprPanic "tyConFamilySize 1" (ppr tc) + | otherwise = pprPanic "tyConFamilySize 2" (ppr tc) + +-- | Extract an 'AlgTyConRhs' with information about data constructors from an +-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' +algTyConRhs :: TyCon -> AlgTyConRhs +algTyConRhs tc@(TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = rhs} <- details = rhs + | otherwise = pprPanic "algTyConRhs" (ppr tc) + +-- | Extract the bound type variables and type expansion of a type synonym +-- 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConRhs :: TyCon -> ([TyVar], Type) +newTyConRhs tc@(TyCon { tyConTyVars = tvs, tyConDetails = details }) + | AlgTyCon { algTcRhs = NewTyCon { nt_rhs = rhs }} <- details + = (tvs, rhs) + | otherwise + = pprPanic "newTyConRhs" (ppr tc) + +-- | The number of type parameters that need to be passed to a newtype to +-- resolve it. May be less than in the definition if it can be eta-contracted. +newTyConEtadArity :: TyCon -> Int +newTyConEtadArity tc@(TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }} <- details + = length (fst tvs_rhs) + | otherwise + = pprPanic "newTyConEtadArity" (ppr tc) + +-- | Extract the bound type variables and type expansion of an eta-contracted +-- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConEtadRhs :: TyCon -> ([TyVar], Type) +newTyConEtadRhs tc@(TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }} <- details = tvs_rhs + | otherwise = pprPanic "newTyConEtadRhs" (ppr tc) + +-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to +-- construct something with the @newtype@s type from its representation type +-- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns +-- @Nothing@ +newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +newTyConCo_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon { nt_co = co }} <- details = Just co + | otherwise = Nothing + +newTyConCo :: TyCon -> CoAxiom Unbranched +newTyConCo tc = case newTyConCo_maybe tc of + Just co -> co + Nothing -> pprPanic "newTyConCo" (ppr tc) + +newTyConDataCon_maybe :: TyCon -> Maybe DataCon +newTyConDataCon_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcRhs = NewTyCon { data_con = con }} <- details = Just con + | otherwise = Nothing + +-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context +-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration +-- @data Eq a => T a ...@. See @Note [The stupid context]@ in "GHC.Core.DataCon". +tyConStupidTheta :: TyCon -> [PredType] +tyConStupidTheta tc@(TyCon { tyConDetails = details }) + | AlgTyCon {algTcStupidTheta = stupid} <- details = stupid + | PrimTyCon {} <- details = [] + | otherwise = pprPanic "tyConStupidTheta" (ppr tc) + +-- | Extract the 'TyVar's bound by a vanilla type synonym +-- and the corresponding (unsubstituted) right hand side. +synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) +synTyConDefn_maybe (TyCon { tyConTyVars = tyvars, tyConDetails = details }) + | SynonymTyCon {synTcRhs = ty} <- details + = Just (tyvars, ty) + | otherwise + = Nothing + +-- | Extract the information pertaining to the right hand side of a type synonym +-- (@type@) declaration. +synTyConRhs_maybe :: TyCon -> Maybe Type +synTyConRhs_maybe (TyCon { tyConDetails = details }) + | SynonymTyCon {synTcRhs = rhs} <- details = Just rhs + | otherwise = Nothing + +-- | Extract the flavour of a type family (with all the extra information that +-- it carries) +famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav +famTyConFlav_maybe (TyCon { tyConDetails = details }) + | FamilyTyCon {famTcFlav = flav} <- details = Just flav + | otherwise = Nothing + +-- | Is this 'TyCon' that for a class instance? +isClassTyCon :: TyCon -> Bool +isClassTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = ClassTyCon {}} <- details = True + | otherwise = False + +-- | If this 'TyCon' is that for a class instance, return the class it is for. +-- Otherwise returns @Nothing@ +tyConClass_maybe :: TyCon -> Maybe Class +tyConClass_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = ClassTyCon clas _} <- details = Just clas + | otherwise = Nothing + +-- | Return the associated types of the 'TyCon', if any +tyConATs :: TyCon -> [TyCon] +tyConATs (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = ClassTyCon clas _} <- details = classATs clas + | otherwise = [] + +---------------------------------------------------------------------------- +-- | Is this 'TyCon' that for a data family instance? +isFamInstTyCon :: TyCon -> Bool +isFamInstTyCon (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = DataFamInstTyCon {} } <- details = True + | otherwise = False + +tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) +tyConFamInstSig_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = DataFamInstTyCon ax f ts } <- details = Just (f, ts, ax) + | otherwise = Nothing + +-- | If this 'TyCon' is that of a data family instance, return the family in question +-- and the instance types. Otherwise, return @Nothing@ +tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) +tyConFamInst_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = DataFamInstTyCon _ f ts } <- details = Just (f, ts) + | otherwise = Nothing + +-- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which +-- represents a coercion identifying the representation type with the type +-- instance family. Otherwise, return @Nothing@ +tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +tyConFamilyCoercion_maybe (TyCon { tyConDetails = details }) + | AlgTyCon {algTcFlavour = DataFamInstTyCon ax _ _ } <- details = Just ax + | otherwise = Nothing + +-- | Extract any 'RuntimeRepInfo' from this TyCon +tyConPromDataConInfo :: TyCon -> PromDataConInfo +tyConPromDataConInfo (TyCon { tyConDetails = details }) + | PromotedDataCon { promDcInfo = rri } <- details = rri + | otherwise = NoPromInfo + -- could panic in that second case. But Douglas Adams told me not to. + +{- +Note [Constructor tag allocation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking we need to allocate constructor tags to constructors. +They are allocated based on the position in the data_cons field of TyCon, +with the first constructor getting fIRST_TAG. + +We used to pay linear cost per constructor, with each constructor looking up +its relative index in the constructor list. That was quadratic and prohibitive +for large data types with more than 10k constructors. + +The current strategy is to build a NameEnv with a mapping from constructor's +Name to ConTag and pass it down to buildDataCon for efficient lookup. + +Relevant ticket: #14657 +-} + +mkTyConTagMap :: TyCon -> NameEnv ConTag +mkTyConTagMap tycon = + mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..] + -- See Note [Constructor tag allocation] + +{- +************************************************************************ +* * +\subsection[TyCon-instances]{Instance declarations for @TyCon@} +* * +************************************************************************ + +@TyCon@s are compared by comparing their @Unique@s. +-} + +instance Eq TyCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable TyCon where + getUnique tc = tyConUnique tc + +instance Outputable TyCon where + -- At the moment a promoted TyCon has the same Name as its + -- corresponding TyCon, so we add the quote to distinguish it here + ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc + where + pp_tc = getPprStyle $ \sty -> + getPprDebug $ \debug -> + if ((debug || dumpStyle sty) && isTcTyCon tc) + 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 { tyConDetails = details }) + | AlgTyCon { algTcFlavour = parent, algTcRhs = rhs } <- details + = case parent of + ClassTyCon {} -> ClassFlavour + _ -> case rhs of + TupleTyCon { tup_sort = sort } + -> TupleFlavour (tupleSortBoxity sort) + SumTyCon {} -> SumFlavour + DataTyCon {} -> DataTypeFlavour + NewTyCon {} -> NewtypeFlavour + AbstractTyCon {} -> AbstractTypeFlavour + + | FamilyTyCon { famTcFlav = flav, famTcParent = parent } <- details + = case flav of + DataFamilyTyCon{} -> DataFamilyFlavour parent + OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent + ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour + AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour + BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour + + | SynonymTyCon {} <- details = TypeSynonymFlavour + | PrimTyCon {} <- details = BuiltInTypeFlavour + | PromotedDataCon {} <- details = PromotedDataConFlavour + | TcTyCon { tctc_flavour = flav } <-details = flav + +-- | Can this flavour of 'TyCon' appear unsaturated? +tcFlavourMustBeSaturated :: TyConFlavour -> 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 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 ClosedTypeFamilyFlavour = False +tcFlavourIsOpen ClassFlavour = False +tcFlavourIsOpen DataTypeFlavour = False +tcFlavourIsOpen NewtypeFlavour = False +tcFlavourIsOpen TupleFlavour{} = False +tcFlavourIsOpen SumFlavour = False +tcFlavourIsOpen AbstractTypeFlavour {} = False +tcFlavourIsOpen BuiltInTypeFlavour = False +tcFlavourIsOpen PromotedDataConFlavour = False +tcFlavourIsOpen TypeSynonymFlavour = False + +pprPromotionQuote :: TyCon -> SDoc +-- Promoted data constructors already have a tick in their OccName +pprPromotionQuote tc = + getPprStyle $ \sty -> + let + name = getOccName tc + ticked = isDataKindsPromotedDataCon tc && promTick sty (PromotedItemDataCon name) + in + if ticked + then char '\'' + else empty instance NamedThing TyCon where getName = tyConName 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 @@ -14,7 +14,6 @@ isTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon :: TyCon -> Bool -isFunTyCon :: TyCon -> Bool tyConRepName_maybe :: TyCon -> Maybe TyConRepName mkPrelTyConRepName :: Name -> TyConRepName diff --git a/GHC/Core/Type.hs b/GHC/Core/Type.hs --- a/GHC/Core/Type.hs +++ b/GHC/Core/Type.hs @@ -3,3923 +3,3312 @@ -- -- Type - public interface -{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - --- | Main functions for manipulating types and type-related things -module GHC.Core.Type ( - -- Note some of this is just re-exports from TyCon.. - - -- * Main data types representing Types - -- $type_classification - - -- $representation_types - Type, ArgFlag(..), AnonArgFlag(..), - Specificity(..), - KindOrType, PredType, ThetaType, FRRType, - Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, - Mult, Scaled, - KnotTied, - - -- ** Constructing and deconstructing types - mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, - getCastedTyVar_maybe, tyVarKind, varType, - - mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys, - splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, - - mkFunTy, mkVisFunTy, mkInvisFunTy, - mkVisFunTys, - mkVisFunTyMany, mkInvisFunTyMany, - mkVisFunTysMany, mkInvisFunTysMany, - splitFunTy, splitFunTy_maybe, - splitFunTys, funResultTy, funArgTy, - - mkTyConApp, mkTyConTy, mkTYPEapp, - tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, - tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, - splitTyConApp_maybe, splitTyConApp, tyConAppArgN, - tcSplitTyConApp_maybe, - splitListTyConApp_maybe, - repSplitTyConApp_maybe, - tcRepSplitTyConApp_maybe, - - mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, - mkSpecForAllTy, mkSpecForAllTys, - mkVisForAllTys, mkTyCoInvForAllTy, - mkInfForAllTy, mkInfForAllTys, - splitForAllTyCoVars, splitForAllTyVars, - splitForAllReqTVBinders, splitForAllInvisTVBinders, - splitForAllTyCoVarBinders, - splitForAllTyCoVar_maybe, splitForAllTyCoVar, - splitForAllTyVar_maybe, splitForAllCoVar_maybe, - splitPiTy_maybe, splitPiTy, splitPiTys, - getRuntimeArgTys, - mkTyConBindersPreferAnon, - mkPiTy, mkPiTys, - piResultTy, piResultTys, - applyTysX, dropForAlls, - mkFamilyTyConApp, - buildSynTyCon, - - mkNumLitTy, isNumLitTy, - mkStrLitTy, isStrLitTy, - mkCharLitTy, isCharLitTy, - isLitTy, - - isPredTy, - - getRuntimeRep_maybe, kindRep_maybe, kindRep, - - mkCastTy, mkCoercionTy, splitCastTy_maybe, - - userTypeError_maybe, pprUserTypeErrorTy, - - coAxNthLHS, - stripCoercionTy, - - splitInvisPiTys, splitInvisPiTysN, - invisibleTyBndrCount, - filterOutInvisibleTypes, filterOutInferredTypes, - partitionInvisibleTypes, partitionInvisibles, - tyConArgFlags, appTyArgFlags, - - -- ** Analyzing types - TyCoMapper(..), mapTyCo, mapTyCoX, - TyCoFolder(..), foldTyCo, noView, - - -- (Newtypes) - newTyConInstRhs, - - -- ** Binders - sameVis, - mkTyCoVarBinder, mkTyCoVarBinders, - mkTyVarBinder, mkTyVarBinders, - tyVarSpecToBinders, - mkAnonBinder, - isAnonTyCoBinder, - binderVar, binderVars, binderType, binderArgFlag, - tyCoBinderType, tyCoBinderVar_maybe, - tyBinderType, - binderRelevantType_maybe, - isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, - isInvisibleBinder, isNamedBinder, - tyConBindersTyCoBinders, - - -- ** Common type constructors - funTyCon, unrestrictedFunTyCon, - - -- ** Predicates on types - isTyVarTy, isFunTy, isCoercionTy, - isCoercionTy_maybe, isForAllTy, - isForAllTy_ty, isForAllTy_co, - isPiTy, isTauTy, isFamFreeTy, - isCoVarType, isAtomicTy, - - isValidJoinPointType, - tyConAppNeedsKindSig, - - -- *** Levity and boxity - typeLevity_maybe, - isLiftedTypeKind, isUnliftedTypeKind, isBoxedTypeKind, pickyIsLiftedTypeKind, - isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe, - isBoxedRuntimeRep, - isLiftedLevity, isUnliftedLevity, - isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType, - mightBeLiftedType, mightBeUnliftedType, - isStateType, - isAlgType, isDataFamilyAppType, - isPrimitiveType, isStrictType, - isLevityTy, isLevityVar, - isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, - dropRuntimeRepArgs, - getRuntimeRep, getLevity, getLevity_maybe, - - -- * Multiplicity - - isMultiplicityTy, isMultiplicityVar, - unrestricted, linear, tymult, - mkScaled, irrelevantMult, scaledSet, - pattern One, pattern Many, - isOneDataConTy, isManyDataConTy, - isLinearType, - - -- * Main data types representing Kinds - Kind, - - -- ** Finding the kind of a type - typeKind, tcTypeKind, typeHasFixedRuntimeRep, resultHasFixedRuntimeRep, - tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind, - tcIsBoxedTypeKind, tcIsRuntimeTypeKind, - - -- ** Common Kind - liftedTypeKind, unliftedTypeKind, - - -- * Type free variables - tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, - tyCoVarsOfType, tyCoVarsOfTypes, - tyCoVarsOfTypeDSet, - coVarsOfType, - coVarsOfTypes, - - anyFreeVarsOfType, anyFreeVarsOfTypes, - noFreeVarsOfType, - splitVisVarsOfType, splitVisVarsOfTypes, - expandTypeSynonyms, - typeSize, occCheckExpand, - - -- ** Closing over kinds - closeOverKindsDSet, closeOverKindsList, - closeOverKinds, - - -- * Well-scoped lists of variables - scopedSort, tyCoVarsOfTypeWellScoped, - tyCoVarsOfTypesWellScoped, - - -- * Type comparison - eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX, - nonDetCmpTypesX, nonDetCmpTc, - eqVarBndrs, - - -- * Forcing evaluation of types - seqType, seqTypes, - - -- * Other views onto Types - coreView, tcView, - - tyConsOfType, - - -- * Main type substitution data types - TvSubstEnv, -- Representation widely visible - TCvSubst(..), -- Representation visible to a few friends - - -- ** Manipulating type substitutions - emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, - - mkTCvSubst, zipTvSubst, mkTvSubstPrs, - zipTCvSubst, - notElemTCvSubst, - getTvSubstEnv, setTvSubstEnv, - zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs, - extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, - extendTCvSubst, extendCvSubst, - extendTvSubst, extendTvSubstBinderAndInScope, - extendTvSubstList, extendTvSubstAndInScope, - extendTCvSubstList, - extendTvSubstWithClone, - extendTCvSubstWithClone, - isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, - isEmptyTCvSubst, unionTCvSubst, - - -- ** Performing substitution on types and kinds - substTy, substTys, substScaledTy, substScaledTys, substTyWith, substTysWith, substTheta, - substTyAddInScope, - substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked, - substThetaUnchecked, substTyWithUnchecked, - substCoUnchecked, substCoWithUnchecked, - substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, - substVarBndr, substVarBndrs, - substTyCoBndr, - cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, - - -- * Tidying type related things up for printing - tidyType, tidyTypes, - tidyOpenType, tidyOpenTypes, - tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, - tidyOpenTyCoVar, tidyOpenTyCoVars, - tidyTyCoVarOcc, - tidyTopType, - tidyTyCoVarBinder, tidyTyCoVarBinders, - - -- * Kinds - isConstraintKindCon, - classifiesTypeWithValues, - isConcrete, isFixedRuntimeRepKind, - ) where - -import GHC.Prelude - -import GHC.Types.Basic - --- We import the representation and primitive functions from GHC.Core.TyCo.Rep. --- Many things are reexported, but not the representation! - -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 -import {-# SOURCE #-} GHC.Builtin.Types - ( charTy, naturalTy, listTyCon - , typeSymbolKind, liftedTypeKind, unliftedTypeKind - , liftedRepTy, unliftedRepTy, zeroBitRepTy - , boxedRepDataConTyCon - , constraintKind, zeroBitTypeKind - , unrestrictedFunTyCon - , manyDataConTy, oneDataConTy ) -import GHC.Types.Name( Name ) -import GHC.Builtin.Names -import GHC.Core.Coercion.Axiom -import {-# SOURCE #-} GHC.Core.Coercion - ( mkNomReflCo, mkGReflCo, mkReflCo - , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo - , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo - , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo - , mkKindCo, mkSubCo - , decomposePiCos, coercionKind, coercionLKind - , coercionRKind, coercionType - , isReflexiveCo, seqCo - , topNormaliseNewType_maybe - ) -import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isConcreteTyVar ) - --- others -import GHC.Utils.Misc -import GHC.Utils.FV -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Data.FastString -import GHC.Data.Pair -import GHC.Data.List.SetOps -import GHC.Types.Unique ( nonDetCmpUnique ) - -import GHC.Data.Maybe ( orElse, expectJust ) -import Data.Maybe ( isJust ) -import Control.Monad ( guard ) --- import GHC.Utils.Trace - --- $type_classification --- #type_classification# --- --- Types are any, but at least one, of: --- --- [Boxed] Iff its representation is a pointer to an object on the --- GC'd heap. Operationally, heap objects can be entered as --- a means of evaluation. --- --- [Lifted] Iff it has bottom as an element: An instance of a --- lifted type might diverge when evaluated. --- GHC Haskell's unboxed types are unlifted. --- An unboxed, but lifted type is not very useful. --- (Example: A byte-represented type, where evaluating 0xff --- computes the 12345678th collatz number modulo 0xff.) --- Only lifted types may be unified with a type variable. --- --- [Algebraic] Iff it is a type with one or more constructors, whether --- declared with @data@ or @newtype@. --- An algebraic type is one that can be deconstructed --- with a case expression. There are algebraic types that --- are not lifted types, like unlifted data types or --- unboxed tuples. --- --- [Data] Iff it is a type declared with @data@, or a boxed tuple. --- There are also /unlifted/ data types. --- --- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. --- --- [Unlifted] Anything that isn't lifted is considered unlifted. --- --- Currently, all primitive types are unlifted, but that's not necessarily --- the case: for example, @Int@ could be primitive. --- --- Some primitive types are unboxed, such as @Int#@, whereas some are boxed --- but unlifted (such as @ByteArray#@). The only primitive types that we --- classify as algebraic are the unboxed tuples. --- --- Some examples of type classifications that may make this a bit clearer are: --- --- @ --- Type primitive boxed lifted algebraic --- ----------------------------------------------------------------------------- --- Int# Yes No No No --- ByteArray# Yes Yes No No --- (\# a, b \#) Yes No No Yes --- (\# a | b \#) Yes No No Yes --- ( a, b ) No Yes Yes Yes --- [a] No Yes Yes Yes --- @ - --- $representation_types --- A /source type/ is a type that is a separate type as far as the type checker is --- concerned, but which has a more low-level representation as far as Core-to-Core --- passes and the rest of the back end is concerned. --- --- You don't normally have to worry about this, as the utility functions in --- this module will automatically convert a source into a representation type --- if they are spotted, to the best of its abilities. If you don't want this --- to happen, use the equivalent functions from the "TcType" module. - -{- -************************************************************************ -* * - Type representation -* * -************************************************************************ - -Note [coreView vs tcView] -~~~~~~~~~~~~~~~~~~~~~~~~~ -So far as the typechecker is concerned, 'Constraint' and 'TYPE -LiftedRep' are distinct kinds. - -But in Core these two are treated as identical. - -We implement this by making 'coreView' convert 'Constraint' to 'TYPE -LiftedRep' on the fly. The function tcView (used in the type checker) -does not do this. Accordingly, tcView is used in type-checker-oriented -functions (including the pure unifier, used in instance resolution), -while coreView is used during e.g. optimisation passes. - -See also #11715, which tracks removing this inconsistency. - -In order to prevent users from discerning between Type and Constraint -(which could create inconsistent axioms -- see #21092), we say that -Type and Constraint are not SurelyApart in the pure unifier. See -GHC.Core.Unify.unify_ty, where this case produces MaybeApart. - -One annoying consequence of this inconsistency is that we can get ill-kinded -updates to metavariables. #20356 is a case in point. Simplifying somewhat, -we end up with - [W] (alpha :: Constraint) ~ (Int :: Type) -This is heterogeneous, so we produce - [W] co :: (Constraint ~ Type) -and transform our original wanted to become - [W] alpha ~ Int |> sym co -in accordance with Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical. -Our transformed wanted is now homogeneous (both sides have kind Constraint) -and so we unify alpha := Int |> sym co. - -However, it's not so easy: when we build the cast (Int |> sym co), we actually -just get Int back. This is because we forbid reflexive casts (invariant (EQ2) of -Note [Respecting definitional equality] in GHC.Core.TyCo.Rep), and co looks -reflexive: it relates Type and Constraint, even though these are considered -identical in Core. Above, when we tried to say alpha := Int |> sym co, we -really ended up doing alpha := Int -- even though alpha :: Constraint and -Int :: Type have different kinds. Nothing has really gone wrong, though: -we still emitted [W] co :: (Constraint ~ Type), which will be insoluble -and lead to a decent error message. We simply need not to fall over at the -moment of unification, because all will be OK in the end. We thus use the -Core eqType, not the Haskell tcEqType, in the kind check for a meta-tyvar -unification in GHC.Tc.Utils.TcMType.writeMetaTyVarRef. - --} - --- | Gives the typechecker view of a type. This unwraps synonyms but --- leaves 'Constraint' alone. c.f. 'coreView', which turns 'Constraint' into --- 'Type'. Returns 'Nothing' if no unwrapping happens. --- See also Note [coreView vs tcView] -tcView :: Type -> Maybe Type -tcView (TyConApp tc tys) - | res@(Just _) <- expandSynTyConApp_maybe tc tys - = res -tcView _ = Nothing --- See Note [Inlining coreView]. -{-# INLINE tcView #-} - -coreView :: Type -> Maybe Type --- ^ This function strips off the /top layer only/ of a type synonym --- application (if any) its underlying representation type. --- Returns 'Nothing' if there is nothing to look through. --- This function considers 'Constraint' to be a synonym of @Type@. --- --- This function does not look through type family applications. --- --- By being non-recursive and inlined, this case analysis gets efficiently --- joined onto the case analysis that the caller is already doing -coreView ty@(TyConApp tc tys) - | res@(Just _) <- expandSynTyConApp_maybe tc tys - = res - - -- At the Core level, Constraint = Type - -- See Note [coreView vs tcView] - | isConstraintKindCon tc - = assertPpr (null tys) (ppr ty) $ - Just liftedTypeKind - -coreView _ = Nothing --- See Note [Inlining coreView]. -{-# INLINE coreView #-} - ------------------------------------------------ - --- | @expandSynTyConApp_maybe tc tys@ expands the RHS of type synonym @tc@ --- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a --- synonym. -expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type -{-# INLINE expandSynTyConApp_maybe #-} --- This INLINE will inline the call to expandSynTyConApp_maybe in coreView, --- which will eliminate the allocat ion Just/Nothing in the result --- Don't be tempted to make `expand_syn` (which is NOINLIN) return the --- Just/Nothing, else you'll increase allocation -expandSynTyConApp_maybe tc arg_tys - | Just (tvs, rhs) <- synTyConDefn_maybe tc - , arg_tys `lengthAtLeast` (tyConArity tc) - = Just (expand_syn tvs rhs arg_tys) - | otherwise - = Nothing - --- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path --- into call-sites. --- --- Precondition: the call is saturated or over-saturated; --- i.e. length tvs <= length arg_tys -expand_syn :: [TyVar] -- ^ the variables bound by the synonym - -> Type -- ^ the RHS of the synonym - -> [Type] -- ^ the type arguments the synonym is instantiated at. - -> Type -{-# NOINLINE expand_syn #-} -- We never want to inline this cold-path. - -expand_syn tvs rhs arg_tys - -- No substitution necessary if either tvs or tys is empty - -- This is both more efficient, and steers clear of an infinite - -- loop; see Note [Care using synonyms to compress types] - | null arg_tys = assert (null tvs) rhs - | null tvs = mkAppTys rhs arg_tys - | otherwise = go empty_subst tvs arg_tys - where - empty_subst = mkEmptyTCvSubst in_scope - in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ arg_tys - -- The free vars of 'rhs' should all be bound by 'tenv', - -- so we only need the free vars of tys - -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. - - go subst [] tys - | null tys = rhs' -- Exactly Saturated - | otherwise = mkAppTys rhs' tys - -- Its important to use mkAppTys, rather than (foldl AppTy), - -- because the function part might well return a - -- partially-applied type constructor; indeed, usually will! - where - rhs' = substTy subst rhs - - go subst (tv:tvs) (ty:tys) = go (extendTvSubst subst tv ty) tvs tys - - go _ (_:_) [] = pprPanic "expand_syn" (ppr tvs $$ ppr rhs $$ ppr arg_tys) - -- Under-saturated, precondition failed - - - -coreFullView :: Type -> Type --- ^ Iterates 'coreView' until there is no more to synonym to expand. --- See Note [Inlining coreView]. -coreFullView ty@(TyConApp tc _) - | isTypeSynonymTyCon tc || isConstraintKindCon tc = go ty - where - go ty - | Just ty' <- coreView ty = go ty' - | otherwise = ty - -coreFullView ty = ty -{-# INLINE coreFullView #-} - -{- Note [Inlining coreView] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It is very common to have a function - - f :: Type -> ... - f ty | Just ty' <- coreView ty = f ty' - f (TyVarTy ...) = ... - f ... = ... - -If f is not otherwise recursive, the initial call to coreView -causes f to become recursive, which kills the possibility of -inlining. Instead, for non-recursive functions, we prefer to -use coreFullView, which guarantees to unwrap top-level type -synonyms. It can be inlined and is efficient and non-allocating -in its fast path. For this to really be fast, all calls made -on its fast path must also be inlined, linked back to this Note. --} - ------------------------------------------------ -expandTypeSynonyms :: Type -> Type --- ^ Expand out all type synonyms. Actually, it'd suffice to expand out --- just the ones that discard type variables (e.g. type Funny a = Int) --- But we don't know which those are currently, so we just expand all. --- --- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type, --- not in the kinds of any TyCon or TyVar mentioned in the type. --- --- Keep this synchronized with 'synonymTyConsOfType' -expandTypeSynonyms ty - = go (mkEmptyTCvSubst in_scope) ty - where - in_scope = mkInScopeSet (tyCoVarsOfType ty) - - go subst (TyConApp tc tys) - | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys - = let subst' = mkTvSubst in_scope (mkVarEnv tenv) - -- Make a fresh substitution; rhs has nothing to - -- do with anything that has happened so far - -- NB: if you make changes here, be sure to build an - -- /idempotent/ substitution, even in the nested case - -- type T a b = a -> b - -- type S x y = T y x - -- (#11665) - in mkAppTys (go subst' rhs) tys' - | otherwise - = TyConApp tc expanded_tys - where - expanded_tys = (map (go subst) tys) - - go _ (LitTy l) = LitTy l - go subst (TyVarTy tv) = substTyVar subst tv - go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) - go subst ty@(FunTy _ mult arg res) - = ty { ft_mult = go subst mult, ft_arg = go subst arg, ft_res = go subst res } - go subst (ForAllTy (Bndr tv vis) t) - = let (subst', tv') = substVarBndrUsing go subst tv in - ForAllTy (Bndr tv' vis) (go subst' t) - go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) - go subst (CoercionTy co) = mkCoercionTy (go_co subst co) - - go_mco _ MRefl = MRefl - go_mco subst (MCo co) = MCo (go_co subst co) - - go_co subst (Refl ty) - = mkNomReflCo (go subst ty) - go_co subst (GRefl r ty mco) - = mkGReflCo r (go subst ty) (go_mco subst mco) - -- NB: coercions are always expanded upon creation - go_co subst (TyConAppCo r tc args) - = 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) - = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in - mkForAllCo tv' kind_co' (go_co subst' co) - go_co subst (FunCo r w co1 co2) - = mkFunCo r (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 (SymCo co) - = mkSymCo (go_co subst co) - go_co subst (TransCo co1 co2) - = mkTransCo (go_co subst co1) (go_co subst co2) - go_co subst (NthCo r n co) - = mkNthCo r n (go_co subst co) - go_co subst (LRCo lr co) - = mkLRCo lr (go_co subst co) - go_co subst (InstCo co arg) - = mkInstCo (go_co subst co) (go_co subst arg) - go_co subst (KindCo co) - = 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 - --- | An INLINE helper for function such as 'kindRep_maybe' below. --- --- @isTyConKeyApp_maybe key ty@ returns @Just tys@ iff --- the type @ty = T tys@, where T's unique = key -isTyConKeyApp_maybe :: Unique -> Type -> Maybe [Type] -isTyConKeyApp_maybe key ty - | TyConApp tc args <- coreFullView ty - , tc `hasKey` key - = Just args - | otherwise - = Nothing -{-# INLINE isTyConKeyApp_maybe #-} - --- | Extract the RuntimeRep classifier of a type from its kind. For example, --- @kindRep * = LiftedRep@; Panics if this is not possible. --- Treats * and Constraint as the same -kindRep :: HasDebugCallStack => Kind -> Type -kindRep k = case kindRep_maybe k of - Just r -> r - Nothing -> pprPanic "kindRep" (ppr k) - --- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. --- For example, @kindRep_maybe * = Just LiftedRep@ --- Returns 'Nothing' if the kind is not of form (TYPE rr) --- Treats * and Constraint as the same -kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type -kindRep_maybe kind - | Just [arg] <- isTyConKeyApp_maybe tYPETyConKey kind = Just arg - | otherwise = Nothing - --- | Returns True if the kind classifies types which are allocated on --- the GC'd heap and False otherwise. Note that this returns False for --- representation-polymorphic kinds, which may be specialized to a kind that --- classifies AddrRep or even unboxed kinds. -isBoxedTypeKind :: Kind -> Bool -isBoxedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isBoxedRuntimeRep rep - Nothing -> False - --- | This version considers Constraint to be the same as *. Returns True --- if the argument is equivalent to Type/Constraint and False otherwise. --- See Note [Kind Constraint and kind Type] -isLiftedTypeKind :: Kind -> Bool -isLiftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isLiftedRuntimeRep rep - Nothing -> False - -pickyIsLiftedTypeKind :: Kind -> Bool --- Checks whether the kind is literally --- TYPE LiftedRep --- or TYPE ('BoxedRep 'Lifted) --- or Type --- without expanding type synonyms or anything --- Used only when deciding whether to suppress the ":: *" in --- (a :: *) when printing kinded type variables --- See Note [Suppressing * kinds] in GHC.Core.TyCo.Ppr -pickyIsLiftedTypeKind kind - | TyConApp tc [arg] <- kind - , tc `hasKey` tYPETyConKey - , TyConApp rr_tc rr_args <- arg = case rr_args of - [] -> rr_tc `hasKey` liftedRepTyConKey - [rr_arg] - | rr_tc `hasKey` boxedRepDataConKey - , TyConApp lev [] <- rr_arg - , lev `hasKey` liftedDataConKey -> True - _ -> False - | TyConApp tc [] <- kind - , tc `hasKey` liftedTypeKindTyConKey = True - | otherwise = False - --- | Returns True if the kind classifies unlifted types (like 'Int#') and False --- otherwise. Note that this returns False for representation-polymorphic --- kinds, which may be specialized to a kind that classifies unlifted types. -isUnliftedTypeKind :: Kind -> Bool -isUnliftedTypeKind kind - = case kindRep_maybe kind of - Just rep -> isUnliftedRuntimeRep rep - Nothing -> False - --- | See 'isBoxedRuntimeRep_maybe'. -isBoxedRuntimeRep :: Type -> Bool -isBoxedRuntimeRep rep = isJust (isBoxedRuntimeRep_maybe rep) - --- | `isBoxedRuntimeRep_maybe (rep :: RuntimeRep)` returns `Just lev` if `rep` --- expands to `Boxed lev` and returns `Nothing` otherwise. --- --- Types with this runtime rep are represented by pointers on the GC'd heap. -isBoxedRuntimeRep_maybe :: Type -> Maybe Type -isBoxedRuntimeRep_maybe rep - | Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep - = Just lev - | otherwise - = Nothing - --- | Check whether a type of kind 'RuntimeRep' is lifted, unlifted, or unknown. --- --- @isLiftedRuntimeRep rr@ returns: --- --- * @Just Lifted@ if @rr@ is @LiftedRep :: RuntimeRep@ --- * @Just Unlifted@ if @rr@ is definitely unlifted, e.g. @IntRep@ --- * @Nothing@ if not known (e.g. it's a type variable or a type family application). -runtimeRepLevity_maybe :: Type -> Maybe Levity -runtimeRepLevity_maybe rep - | TyConApp rr_tc args <- coreFullView rep - , isPromotedDataCon rr_tc = - -- NB: args might be non-empty e.g. TupleRep [r1, .., rn] - if (rr_tc `hasKey` boxedRepDataConKey) - then case args of - [lev] | isLiftedLevity lev -> Just Lifted - | isUnliftedLevity lev -> Just Unlifted - _ -> Nothing - else Just Unlifted - -- Avoid searching all the unlifted RuntimeRep type cons - -- In the RuntimeRep data type, only LiftedRep is lifted - -- But be careful of type families (F tys) :: RuntimeRep, - -- hence the isPromotedDataCon rr_tc -runtimeRepLevity_maybe _ = Nothing - --- | Check whether a type of kind 'RuntimeRep' is lifted. --- --- 'isLiftedRuntimeRep' is: --- --- * True of @LiftedRep :: RuntimeRep@ --- * False of type variables, type family applications, --- and of other reps such as @IntRep :: RuntimeRep@. -isLiftedRuntimeRep :: Type -> Bool -isLiftedRuntimeRep rep = - runtimeRepLevity_maybe rep == Just Lifted - --- | Check whether a type of kind 'RuntimeRep' is unlifted. --- --- * True of definitely unlifted 'RuntimeRep's such as --- 'UnliftedRep', 'IntRep', 'FloatRep', ... --- * False of 'LiftedRep', --- * False for type variables and type family applications. -isUnliftedRuntimeRep :: Type -> Bool -isUnliftedRuntimeRep rep = - runtimeRepLevity_maybe rep == Just Unlifted - --- | An INLINE helper for functions such as 'isLiftedLevity' and 'isUnliftedLevity'. --- --- Checks whether the type is a nullary 'TyCon' application, --- for a 'TyCon' with the given 'Unique'. -isNullaryTyConKeyApp :: Unique -> Type -> Bool -isNullaryTyConKeyApp key ty - | Just args <- isTyConKeyApp_maybe key ty - = assert (null args) True - | otherwise - = False -{-# INLINE isNullaryTyConKeyApp #-} - -isLiftedLevity :: Type -> Bool -isLiftedLevity = isNullaryTyConKeyApp liftedDataConKey - -isUnliftedLevity :: Type -> Bool -isUnliftedLevity = isNullaryTyConKeyApp unliftedDataConKey - --- | Is this the type 'Levity'? -isLevityTy :: Type -> Bool -isLevityTy = isNullaryTyConKeyApp levityTyConKey - --- | Is this the type 'RuntimeRep'? -isRuntimeRepTy :: Type -> Bool -isRuntimeRepTy = isNullaryTyConKeyApp runtimeRepTyConKey - --- | Is a tyvar of type 'RuntimeRep'? -isRuntimeRepVar :: TyVar -> Bool -isRuntimeRepVar = isRuntimeRepTy . tyVarKind - --- | Is a tyvar of type 'Levity'? -isLevityVar :: TyVar -> Bool -isLevityVar = isLevityTy . tyVarKind - --- | Is this the type 'Multiplicity'? -isMultiplicityTy :: Type -> Bool -isMultiplicityTy = isNullaryTyConKeyApp multiplicityTyConKey - --- | Is a tyvar of type 'Multiplicity'? -isMultiplicityVar :: TyVar -> Bool -isMultiplicityVar = isMultiplicityTy . tyVarKind - -{- ********************************************************************* -* * - mapType -* * -************************************************************************ - -These functions do a map-like operation over types, performing some operation -on all variables and binding sites. Primarily used for zonking. - -Note [Efficiency for ForAllCo case of mapTyCoX] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -As noted in Note [Forall coercions] 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. - -The problem is that tcm_tybinder will affect the TyCoVar's kind and -mapCoercion will affect the Coercion, and we hope that the results will be -the same. Even if they are the same (which should generally happen with -correct algorithms), then there is an efficiency issue. In particular, -this problem seems to make what should be a linear algorithm into a potentially -exponential one. But it's only going to be bad in the case where there's -lots of foralls in the kinds of other foralls. Like this: - - forall a : (forall b : (forall c : ...). ...). ... - -This construction seems unlikely. So we'll do the inefficient, easy way -for now. - -Note [Specialising mappers] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These INLINE pragmas are indispensable. mapTyCo and mapTyCoX are used -to implement zonking, and it's vital that they get specialised to the TcM -monad and the particular mapper in use. - -Even specialising to the monad alone made a 20% allocation difference -in perf/compiler/T5030. - -See Note [Specialising foldType] in "GHC.Core.TyCo.Rep" for more details of this -idiom. --} - --- | This describes how a "map" operation over a type/coercion should behave -data TyCoMapper env m - = TyCoMapper - { tcm_tyvar :: env -> TyVar -> m Type - , tcm_covar :: env -> CoVar -> m Coercion - , tcm_hole :: env -> CoercionHole -> m Coercion - -- ^ What to do with coercion holes. - -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". - - , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar) - -- ^ The returned env is used in the extended scope - - , tcm_tycon :: TyCon -> m TyCon - -- ^ This is used only for TcTyCons - -- a) To zonk TcTyCons - -- b) To turn TcTyCons into TyCons. - -- See Note [Type checking recursive type and class declarations] - -- in "GHC.Tc.TyCl" - } - -{-# INLINE mapTyCo #-} -- See Note [Specialising mappers] -mapTyCo :: Monad m => TyCoMapper () m - -> ( 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 - -> ( env -> Type -> m Type - , env -> [Type] -> m [Type] - , env -> Coercion -> m Coercion - , env -> [Coercion] -> m[Coercion]) -mapTyCoX (TyCoMapper { tcm_tyvar = tyvar - , tcm_tycobinder = tycobinder - , tcm_tycon = tycon - , tcm_covar = covar - , 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 - - 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) - = 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) - | isTcTyCon tc - = do { tc' <- tycon tc - ; mkTyConApp tc' <$> go_tys env tys } - - -- Not a TcTyCon - | null tys -- Avoid allocation in this very - = return ty -- common case (E.g. Int, LiftedRep etc) - - | otherwise - = mkTyConApp tc <$> go_tys env tys - - go_ty env (ForAllTy (Bndr tv vis) inner) - = do { (env', tv') <- tycobinder env tv vis - ; 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 - - 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 cw c1 c2) = mkFunCo r <$> 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 (NthCo r i co) = mkNthCo r i <$> go_co env co - go_co env (LRCo lr co) = mkLRCo lr <$> go_co env co - go_co env (InstCo co arg) = mkInstCo <$> go_co env co <*> go_co env arg - go_co env (KindCo co) = mkKindCo <$> go_co env co - go_co env (SubCo co) = mkSubCo <$> go_co env co - go_co env (AxiomInstCo ax i cos) = mkAxiomInstCo ax i <$> go_cos env cos - go_co env co@(TyConAppCo r tc cos) - | isTcTyCon tc - = do { tc' <- tycon tc - ; mkTyConAppCo r tc' <$> go_cos env cos } - - -- Not a TcTyCon - | null cos -- Avoid allocation in this very - = return co -- common case (E.g. Int, LiftedRep etc) - - | otherwise - = mkTyConAppCo r tc <$> go_cos env cos - go_co env (ForAllCo tv kind_co co) - = do { kind_co' <- go_co env kind_co - ; (env', tv') <- tycobinder env tv Inferred - ; co' <- go_co env' co - ; return $ mkForAllCo tv' 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 - - -{- -************************************************************************ -* * -\subsection{Constructor-specific functions} -* * -************************************************************************ - - ---------------------------------------------------------------------- - TyVarTy - ~~~~~~~ --} - --- | Attempts to obtain the type variable underlying a 'Type', and panics with the --- given message if this is not a type variable type. See also 'getTyVar_maybe' -getTyVar :: String -> Type -> TyVar -getTyVar msg ty = case getTyVar_maybe ty of - Just tv -> tv - Nothing -> panic ("getTyVar: " ++ msg) - -isTyVarTy :: Type -> Bool -isTyVarTy ty = isJust (getTyVar_maybe ty) - --- | Attempts to obtain the type variable underlying a 'Type' -getTyVar_maybe :: Type -> Maybe TyVar -getTyVar_maybe = repGetTyVar_maybe . coreFullView - --- | If the type is a tyvar, possibly under a cast, returns it, along --- with the coercion. Thus, the co is :: kind tv ~N kind ty -getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) -getCastedTyVar_maybe ty = case coreFullView ty of - CastTy (TyVarTy tv) co -> Just (tv, co) - TyVarTy tv -> Just (tv, mkReflCo Nominal (tyVarKind tv)) - _ -> Nothing - --- | Attempts to obtain the type variable underlying a 'Type', without --- any expansion -repGetTyVar_maybe :: Type -> Maybe TyVar -repGetTyVar_maybe (TyVarTy tv) = Just tv -repGetTyVar_maybe _ = Nothing - -{- ---------------------------------------------------------------------- - AppTy - ~~~~~ -We need to be pretty careful with AppTy to make sure we obey the -invariant that a TyConApp is always visibly so. mkAppTy maintains the -invariant: use it. - -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 -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 - i p = typeRep p - - j = i (Proxy :: Proxy (Eq Int => Int)) -The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, -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 repSplitAppTy_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@ -mkAppTy :: Type -> Type -> Type - -- See Note [Respecting definitional equality], invariant (EQ1). -mkAppTy (CastTy fun_ty co) arg_ty - | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty] - = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co - -mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) -mkAppTy ty1 ty2 = AppTy ty1 ty2 - -- Note that the TyConApp could be an - -- under-saturated type synonym. GHC allows that; e.g. - -- type Foo k = k a -> k a - -- type Id x = x - -- foo :: Foo Id -> Foo Id - -- - -- Here Id is partially applied in the type sig for Foo, - -- but once the type synonyms are expanded all is well - -- - -- Moreover in GHC.Tc.Types.tcInferTyApps we build up a type - -- (T t1 t2 t3) one argument at a type, thus forming - -- (T t1), (T t1 t2), etc - -mkAppTys :: Type -> [Type] -> Type -mkAppTys ty1 [] = ty1 -mkAppTys (CastTy fun_ty co) arg_tys -- much more efficient then nested mkAppTy - -- Why do this? See (EQ1) of - -- Note [Respecting definitional equality] - -- in GHC.Core.TyCo.Rep - = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers - where - (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys - (args_to_cast, leftovers) = splitAtList arg_cos arg_tys - casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos -mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) -mkAppTys ty1 tys2 = foldl' AppTy ty1 tys2 - -------------- -splitAppTy_maybe :: Type -> Maybe (Type, Type) --- ^ Attempt to take a type application apart, whether it is a --- function, type constructor, or plain type application. Note --- that type family applications are NEVER unsaturated by this! -splitAppTy_maybe = repSplitAppTy_maybe . coreFullView - -------------- -repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) --- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that --- any Core view stuff is already done -repSplitAppTy_maybe (FunTy _ w ty1 ty2) - = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - -repSplitAppTy_maybe (AppTy ty1 ty2) - = Just (ty1, ty2) - -repSplitAppTy_maybe (TyConApp tc tys) - | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc - , Just (tys', ty') <- snocView tys - = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! - -repSplitAppTy_maybe _other = Nothing - --- This one doesn't break apart (c => t). --- See Note [Decomposing fat arrow c=>t] --- Defined here to avoid module loops between Unify and TcType. -tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type) --- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that --- any coreView stuff is already done. Refuses to look through (c => t) -tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_mult = w, ft_arg = ty1, ft_res = ty2 }) - | VisArg <- af -- See Note [Decomposing fat arrow c=>t] - - -- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType, - -- Wrinkle around FunTy - , Just rep1 <- getRuntimeRep_maybe ty1 - , Just rep2 <- getRuntimeRep_maybe ty2 - = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2) - - | otherwise - = Nothing - -tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) -tcRepSplitAppTy_maybe (TyConApp tc tys) - | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc - , Just (tys', ty') <- snocView tys - = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! -tcRepSplitAppTy_maybe _other = Nothing - -------------- -splitAppTy :: Type -> (Type, Type) --- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', --- and panics if this is not possible -splitAppTy ty = case splitAppTy_maybe ty of - Just pr -> pr - Nothing -> panic "splitAppTy" - -------------- -splitAppTys :: 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. -splitAppTys ty = split ty ty [] - where - split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args - split _ (AppTy ty arg) args = split ty ty (arg:args) - split _ (TyConApp tc tc_args) args - = let -- keep type families saturated - n | mustBeSaturated tc = tyConArity tc - | otherwise = 0 - (tc_args1, tc_args2) = splitAt n tc_args - in - (TyConApp tc tc_args1, tc_args2 ++ args) - split _ (FunTy _ w ty1 ty2) args - = assert (null args ) - (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2]) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - - split orig_ty _ args = (orig_ty, args) - --- | Like 'splitAppTys', but doesn't look through type synonyms -repSplitAppTys :: HasDebugCallStack => Type -> (Type, [Type]) -repSplitAppTys ty = split ty [] - where - split (AppTy ty arg) args = split ty (arg:args) - split (TyConApp tc tc_args) args - = let n | mustBeSaturated tc = tyConArity tc - | otherwise = 0 - (tc_args1, tc_args2) = splitAt n tc_args - in - (TyConApp tc tc_args1, tc_args2 ++ args) - split (FunTy _ w ty1 ty2) args - = assert (null args ) - (TyConApp funTyCon [], [w, rep1, rep2, ty1, ty2]) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 - - split ty args = (ty, args) - -{- - LitTy - ~~~~~ --} - -mkNumLitTy :: Integer -> Type -mkNumLitTy n = LitTy (NumTyLit n) - --- | Is this a numeric literal. We also look through type synonyms. -isNumLitTy :: Type -> Maybe Integer -isNumLitTy ty - | LitTy (NumTyLit n) <- coreFullView ty = Just n - | otherwise = Nothing - -mkStrLitTy :: FastString -> Type -mkStrLitTy s = LitTy (StrTyLit s) - --- | Is this a symbol literal. We also look through type synonyms. -isStrLitTy :: Type -> Maybe FastString -isStrLitTy ty - | LitTy (StrTyLit s) <- coreFullView ty = Just s - | otherwise = Nothing - -mkCharLitTy :: Char -> Type -mkCharLitTy c = LitTy (CharTyLit c) - --- | Is this a char literal? We also look through type synonyms. -isCharLitTy :: Type -> Maybe Char -isCharLitTy ty - | LitTy (CharTyLit s) <- coreFullView ty = Just s - | otherwise = Nothing - - --- | Is this a type literal (symbol, numeric, or char)? -isLitTy :: Type -> Maybe TyLit -isLitTy ty - | LitTy l <- coreFullView ty = Just l - | otherwise = Nothing - --- | 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 - -- There may be more than 2 arguments, if the type error is - -- used as a type constructor (e.g. at kind `Type -> Type`). - - ; guard (tyConName tc == errorMessageTypeErrorFamName) - ; return msg } - --- | Render a type corresponding to a user type error into a SDoc. -pprUserTypeErrorTy :: Type -> SDoc -pprUserTypeErrorTy ty = - case splitTyConApp_maybe ty of - - -- Text "Something" - Just (tc,[txt]) - | tyConName tc == typeErrorTextDataConName - , Just str <- isStrLitTy txt -> ftext str - - -- ShowType t - Just (tc,[_k,t]) - | tyConName tc == typeErrorShowTypeDataConName -> ppr t - - -- t1 :<>: t2 - Just (tc,[t1,t2]) - | tyConName tc == typeErrorAppendDataConName -> - pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 - - -- t1 :$$: t2 - Just (tc,[t1,t2]) - | tyConName tc == typeErrorVAppendDataConName -> - pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 - - -- An unevaluated type function - _ -> ppr ty - - - - -{- ---------------------------------------------------------------------- - FunTy - ~~~~~ - -Note [Representation of function types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Functions (e.g. Int -> Char) can be thought of as being applications -of funTyCon (known in Haskell surface syntax as (->)), (note that -`RuntimeRep' quantifiers are left inferred) - - (->) :: forall {r1 :: RuntimeRep} {r2 :: RuntimeRep} - (a :: TYPE r1) (b :: TYPE r2). - a -> b -> Type - -However, for efficiency's sake we represent saturated applications of (->) -with FunTy. For instance, the type, - - (->) r1 r2 a b - -is equivalent to, - - FunTy (Anon a) b - -Note how the RuntimeReps are implied in the FunTy representation. For this -reason we must be careful when reconstructing the TyConApp representation (see, -for instance, splitTyConApp_maybe). - -In the compiler we maintain the invariant that all saturated applications of -(->) are represented with FunTy. - -See #11714. --} - -splitFunTy :: Type -> (Mult, Type, Type) --- ^ Attempts to extract the multiplicity, argument and result types from a type, --- and panics if that is not possible. See also 'splitFunTy_maybe' -splitFunTy = expectJust "splitFunTy" . splitFunTy_maybe - -{-# INLINE splitFunTy_maybe #-} -splitFunTy_maybe :: Type -> Maybe (Mult, Type, Type) --- ^ Attempts to extract the multiplicity, argument and result types from a type -splitFunTy_maybe ty - | FunTy _ w arg res <- coreFullView ty = Just (w, arg, res) - | otherwise = Nothing - -splitFunTys :: Type -> ([Scaled Type], Type) -splitFunTys ty = split [] ty ty - where - -- common case first - split args _ (FunTy _ w arg res) = split ((Scaled w arg):args) res res - split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' - split args orig_ty _ = (reverse args, orig_ty) - -funResultTy :: HasDebugCallStack => Type -> Type --- ^ Extract the function result type and panic if that is not possible -funResultTy ty - | FunTy { ft_res = res } <- coreFullView ty = res - | otherwise = pprPanic "funResultTy" (ppr ty) - -funArgTy :: Type -> Type --- ^ Extract the function argument type and panic if that is not possible -funArgTy ty - | FunTy { ft_arg = arg } <- coreFullView ty = arg - | otherwise = pprPanic "funArgTy" (ppr ty) - --- ^ Just like 'piResultTys' but for a single argument --- Try not to iterate 'piResultTy', because it's inefficient to substitute --- one variable at a time; instead use 'piResultTys" -piResultTy :: HasDebugCallStack => Type -> Type -> Type -piResultTy ty arg = case piResultTy_maybe ty arg of - Just res -> res - Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) - -piResultTy_maybe :: Type -> Type -> Maybe Type --- We don't need a 'tc' version, because --- this function behaves the same for Type and Constraint -piResultTy_maybe ty arg = case coreFullView ty of - FunTy { ft_res = res } -> Just res - - ForAllTy (Bndr tv _) res - -> let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfTypes [arg,res] - in Just (substTy (extendTCvSubst empty_subst tv arg) res) - - _ -> Nothing - --- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) --- where f :: f_ty --- 'piResultTys' is interesting because: --- 1. 'f_ty' may have more for-alls than there are args --- 2. Less obviously, it may have fewer for-alls --- For case 2. think of: --- piResultTys (forall a.a) [forall b.b, Int] --- This really can happen, but only (I think) in situations involving --- undefined. For example: --- undefined :: forall a. a --- Term: undefined @(forall b. b->b) @Int --- This term should have type (Int -> Int), but notice that --- there are more type args than foralls in 'undefined's type. - --- If you edit this function, you may need to update the GHC formalism --- See Note [GHC Formalism] in GHC.Core.Lint - --- This is a heavily used function (e.g. from typeKind), --- so we pay attention to efficiency, especially in the special case --- where there are no for-alls so we are just dropping arrows from --- a function type/kind. -piResultTys :: HasDebugCallStack => Type -> [Type] -> Type -piResultTys ty [] = ty -piResultTys ty orig_args@(arg:args) - | FunTy { ft_res = res } <- ty - = piResultTys res args - - | ForAllTy (Bndr tv _) res <- ty - = go (extendTCvSubst init_subst tv arg) res args - - | Just ty' <- coreView ty - = piResultTys ty' orig_args - - | otherwise - = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) - where - init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) - - go :: TCvSubst -> Type -> [Type] -> Type - go subst ty [] = substTyUnchecked subst ty - - go subst ty all_args@(arg:args) - | FunTy { ft_res = res } <- ty - = go subst res args - - | ForAllTy (Bndr tv _) res <- ty - = go (extendTCvSubst subst tv arg) res args - - | Just ty' <- coreView ty - = go subst ty' all_args - - | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] - = go init_subst - (substTy subst ty) - all_args - - | otherwise - = -- We have not run out of arguments, but the function doesn't - -- have the right kind to apply to them; so panic. - -- Without the explicit isEmptyVarEnv test, an ill-kinded type - -- would give an infinite loop, which is very unhelpful - -- c.f. #15473 - pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) - -applyTysX :: [TyVar] -> Type -> [Type] -> Type --- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys --- Assumes that (/\tvs. body_ty) is closed -applyTysX tvs body_ty arg_tys - = assertPpr (tvs `leLength` arg_tys) pp_stuff $ - assertPpr (tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs) pp_stuff $ - mkAppTys (substTyWith tvs arg_tys_prefix body_ty) - arg_tys_rest - where - pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys] - (arg_tys_prefix, arg_tys_rest) = splitAtList tvs arg_tys - - - -{- Note [Care with kind instantiation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have - T :: forall k. k -and we are finding the kind of - T (forall b. b -> b) * Int -Then - T (forall b. b->b) :: k[ k :-> forall b. b->b] - :: forall b. b -> b -So - T (forall b. b->b) * :: (b -> b)[ b :-> *] - :: * -> * - -In other words we must instantiate the forall! - -Similarly (#15428) - S :: forall k f. k -> f k -and we are finding the kind of - S * (* ->) Int Bool -We have - S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)] - :: * -> * -> * -So again we must instantiate. - -The same thing happens in GHC.CoreToIface.toIfaceAppArgsX. - ---------------------------------------------------------------------- - TyConApp - ~~~~~~~~ --} - --- splitTyConApp "looks through" synonyms, because they don't --- mean a distinct type, but all other type-constructor applications --- including functions are returned as Just .. - --- | Retrieve the tycon heading this type, if there is one. Does /not/ --- look through synonyms. -tyConAppTyConPicky_maybe :: Type -> Maybe TyCon -tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc -tyConAppTyConPicky_maybe (FunTy {}) = Just funTyCon -tyConAppTyConPicky_maybe _ = Nothing - - --- | The same as @fst . splitTyConApp@ -{-# INLINE tyConAppTyCon_maybe #-} -tyConAppTyCon_maybe :: Type -> Maybe TyCon -tyConAppTyCon_maybe ty = case coreFullView ty of - TyConApp tc _ -> Just tc - FunTy {} -> Just funTyCon - _ -> Nothing - -tyConAppTyCon :: HasDebugCallStack => Type -> TyCon -tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) - --- | The same as @snd . splitTyConApp@ -tyConAppArgs_maybe :: Type -> Maybe [Type] -tyConAppArgs_maybe ty = case coreFullView ty of - TyConApp _ tys -> Just tys - FunTy _ w arg res - | Just rep1 <- getRuntimeRep_maybe arg - , Just rep2 <- getRuntimeRep_maybe res - -> Just [w, rep1, rep2, arg, res] - _ -> Nothing - -tyConAppArgs :: HasCallStack => Type -> [Type] -tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) - -tyConAppArgN :: Int -> Type -> Type --- Executing Nth -tyConAppArgN n ty - = case tyConAppArgs_maybe ty of - Just tys -> tys `getNth` n - Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty) - --- | Attempts to tease a type apart into a type constructor and the application --- of a number of arguments to that constructor. Panics if that is not possible. --- See also 'splitTyConApp_maybe' -splitTyConApp :: Type -> (TyCon, [Type]) -splitTyConApp ty = case splitTyConApp_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "splitTyConApp" (ppr ty) - --- | Attempts to tease a type apart into a type constructor and the application --- of a number of arguments to that constructor -splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -splitTyConApp_maybe = repSplitTyConApp_maybe . coreFullView - --- | Split a type constructor application into its type constructor and --- applied types. Note that this may fail in the case 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@). Consequently, you may need to zonk your --- type before using this function. --- --- This does *not* split types headed with (=>), as that's not a TyCon in the --- type-checker. --- --- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'. -tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) --- Defined here to avoid module loops between Unify and TcType. -tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty' - | otherwise = tcRepSplitTyConApp_maybe ty - -------------------- -repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) --- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This --- assumes the synonyms have already been dealt with. -repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -repSplitTyConApp_maybe (FunTy _ w arg res) - -- NB: we're in Core, so no check for VisArg - = Just (funTyCon, [w, arg_rep, res_rep, arg, res]) - where - arg_rep = getRuntimeRep arg - res_rep = getRuntimeRep res -repSplitTyConApp_maybe _ = Nothing - -tcRepSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) --- ^ Like 'tcSplitTyConApp_maybe', but doesn't look through synonyms. This --- assumes the synonyms have already been dealt with. --- --- Moreover, for a FunTy, it only succeeds if the argument types --- have enough info to extract the runtime-rep arguments that --- the funTyCon requires. This will usually be true; --- but may be temporarily false during canonicalization: --- see Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical --- and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType, --- Wrinkle around FunTy -tcRepSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -tcRepSplitTyConApp_maybe (FunTy VisArg w arg res) - -- NB: VisArg. See Note [Decomposing fat arrow c=>t] - | Just arg_rep <- getRuntimeRep_maybe arg - , Just res_rep <- getRuntimeRep_maybe res - = Just (funTyCon, [w, arg_rep, res_rep, arg, res]) -tcRepSplitTyConApp_maybe _ = Nothing - -------------------- --- | Attempts to tease a list type apart and gives the type of the elements if --- successful (looks through type synonyms) -splitListTyConApp_maybe :: Type -> Maybe Type -splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of - Just (tc,[e]) | tc == listTyCon -> Just e - _other -> Nothing - -newTyConInstRhs :: TyCon -> [Type] -> Type --- ^ Unwrap one 'layer' of newtype on a type constructor and its --- arguments, using an eta-reduced version of the @newtype@ if possible. --- This requires tys to have at least @newTyConInstArity tycon@ elements. -newTyConInstRhs tycon tys - = assertPpr (tvs `leLength` tys) (ppr tycon $$ ppr tys $$ ppr tvs) $ - applyTysX tvs rhs tys - where - (tvs, rhs) = newTyConEtadRhs tycon - -{- ---------------------------------------------------------------------- - CastTy - ~~~~~~ -A casted type has its *kind* casted into something new. --} - -splitCastTy_maybe :: Type -> Maybe (Type, Coercion) -splitCastTy_maybe ty - | CastTy ty' co <- coreFullView ty = Just (ty', co) - | otherwise = Nothing - --- | Make a 'CastTy'. The Coercion must be nominal. Checks the --- Coercion for reflexivity, dropping it if it's reflexive. --- See @Note [Respecting definitional equality]@ in "GHC.Core.TyCo.Rep" -mkCastTy :: Type -> Coercion -> Type -mkCastTy orig_ty co | isReflexiveCo co = orig_ty -- (EQ2) from the Note --- NB: Do the slow check here. This is important to keep the splitXXX --- functions working properly. Otherwise, we may end up with something --- like (((->) |> something_reflexive_but_not_obviously_so) biz baz) --- fails under splitFunTy_maybe. This happened with the cheaper check --- in test dependent/should_compile/dynamic-paper. -mkCastTy orig_ty co = mk_cast_ty orig_ty co - --- | Like 'mkCastTy', but avoids checking the coercion for reflexivity, --- as that can be expensive. -mk_cast_ty :: Type -> Coercion -> Type -mk_cast_ty orig_ty co = go orig_ty - where - go :: Type -> Type - -- See Note [Using coreView in mk_cast_ty] - go ty | Just ty' <- coreView ty = go ty' - - go (CastTy ty co1) - -- (EQ3) from the Note - = mkCastTy ty (co1 `mkTransCo` co) - -- call mkCastTy again for the reflexivity check - - go (ForAllTy (Bndr tv vis) inner_ty) - -- (EQ4) from the Note - -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep. - | isTyVar tv - , let fvs = tyCoVarsOfCo co - = -- have to make sure that pushing the co in doesn't capture the bound var! - if tv `elemVarSet` fvs - then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) - (subst, tv') = substVarBndr empty_subst tv - in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mk_cast_ty` co) - else ForAllTy (Bndr tv vis) (inner_ty `mk_cast_ty` co) - - go _ = CastTy orig_ty co -- NB: orig_ty: preserve synonyms if possible - -{- -Note [Using coreView in mk_cast_ty] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Invariants (EQ3) and (EQ4) of Note [Respecting definitional equality] in -GHC.Core.TyCo.Rep must apply regardless of type synonyms. For instance, -consider this example (#19742): - - type EqSameNat = () |> co - useNatEq :: EqSameNat |> sym co - -(Those casts aren't visible in the user-source code, of course; see #19742 for -what the user might write.) - -The type `EqSameNat |> sym co` looks as if it satisfies (EQ3), as it has no -nested casts, but if we expand EqSameNat, we see that it doesn't. -And then Bad Things happen. - -The solution is easy: just use `coreView` when establishing (EQ3) and (EQ4) in -`mk_cast_ty`. --} - -tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder] --- Return the tyConBinders in TyCoBinder form -tyConBindersTyCoBinders = map to_tyb - where - to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) - to_tyb (Bndr tv (AnonTCB af)) = Anon af (tymult (varType tv)) - --- | (mkTyConTy tc) returns (TyConApp tc []) --- but arranges to share that TyConApp among all calls --- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon -mkTyConTy :: TyCon -> Type -mkTyConTy tycon = tyConNullaryTy tycon - --- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to --- its arguments. Applies its arguments to the constructor from left to right. -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon [] - = -- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon - mkTyConTy tycon - -mkTyConApp tycon tys@(ty1:rest) - | key == funTyConKey - = case tys of - [w, _rep1,_rep2,arg,res] -> FunTy { ft_af = VisArg, ft_mult = w - , ft_arg = arg, ft_res = res } - _ -> bale_out - - -- See Note [Using synonyms to compress types] - | key == tYPETyConKey - = assert (null rest) $ --- mkTYPEapp_maybe ty1 `orElse` bale_out - case mkTYPEapp_maybe ty1 of - Just ty -> ty -- pprTrace "mkTYPEapp:yes" (ppr ty) ty - Nothing -> bale_out -- pprTrace "mkTYPEapp:no" (ppr bale_out) bale_out - - -- See Note [Using synonyms to compress types] - | key == boxedRepDataConTyConKey - = assert (null rest) $ --- mkBoxedRepApp_maybe ty1 `orElse` bale_out - case mkBoxedRepApp_maybe ty1 of - Just ty -> ty -- pprTrace "mkBoxedRepApp:yes" (ppr ty) ty - Nothing -> bale_out -- pprTrace "mkBoxedRepApp:no" (ppr bale_out) bale_out - - | key == tupleRepDataConTyConKey - = case mkTupleRepApp_maybe ty1 of - Just ty -> ty -- pprTrace "mkTupleRepApp:yes" (ppr ty) ty - Nothing -> bale_out -- pprTrace "mkTupleRepApp:no" (ppr bale_out) bale_out - - -- The catch-all case - | otherwise - = bale_out - where - key = tyConUnique tycon - bale_out = TyConApp tycon tys - -mkTYPEapp :: Type -> Type -mkTYPEapp rr - = case mkTYPEapp_maybe rr of - Just ty -> ty - Nothing -> TyConApp tYPETyCon [rr] - -mkTYPEapp_maybe :: Type -> Maybe Type --- ^ Given a @RuntimeRep@, applies @TYPE@ to it. --- On the fly it rewrites --- TYPE LiftedRep --> liftedTypeKind (a synonym) --- TYPE UnliftedRep --> unliftedTypeKind (ditto) --- TYPE ZeroBitRep --> zeroBitTypeKind (ditto) --- NB: no need to check for TYPE (BoxedRep Lifted), TYPE (BoxedRep Unlifted) --- because those inner types should already have been rewritten --- to LiftedRep and UnliftedRep respectively, by mkTyConApp --- --- see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. --- See Note [Using synonyms to compress types] in GHC.Core.Type -{-# NOINLINE mkTYPEapp_maybe #-} -mkTYPEapp_maybe (TyConApp tc args) - | key == liftedRepTyConKey = assert (null args) $ Just liftedTypeKind -- TYPE LiftedRep - | key == unliftedRepTyConKey = assert (null args) $ Just unliftedTypeKind -- TYPE UnliftedRep - | key == zeroBitRepTyConKey = assert (null args) $ Just zeroBitTypeKind -- TYPE ZeroBitRep - where - key = tyConUnique tc -mkTYPEapp_maybe _ = Nothing - -mkBoxedRepApp_maybe :: Type -> Maybe Type --- ^ Given a `Levity`, apply `BoxedRep` to it --- On the fly, rewrite --- BoxedRep Lifted --> liftedRepTy (a synonym) --- BoxedRep Unlifted --> unliftedRepTy (ditto) --- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. --- See Note [Using synonyms to compress types] in GHC.Core.Type -{-# NOINLINE mkBoxedRepApp_maybe #-} -mkBoxedRepApp_maybe (TyConApp tc args) - | key == liftedDataConKey = assert (null args) $ Just liftedRepTy -- BoxedRep Lifted - | key == unliftedDataConKey = assert (null args) $ Just unliftedRepTy -- BoxedRep Unlifted - where - key = tyConUnique tc -mkBoxedRepApp_maybe _ = Nothing - -mkTupleRepApp_maybe :: Type -> Maybe Type --- ^ Given a `[RuntimeRep]`, apply `TupleRep` to it --- On the fly, rewrite --- TupleRep [] -> zeroBitRepTy (a synonym) --- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim. --- See Note [Using synonyms to compress types] in GHC.Core.Type -{-# NOINLINE mkTupleRepApp_maybe #-} -mkTupleRepApp_maybe (TyConApp tc args) - | key == nilDataConKey = assert (isSingleton args) $ Just zeroBitRepTy -- ZeroBitRep - where - key = tyConUnique tc -mkTupleRepApp_maybe _ = Nothing - -{- Note [Using synonyms to compress types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Was: Prefer Type over TYPE (BoxedRep Lifted)] - -The Core of nearly any program will have numerous occurrences of the Types - - TyConApp BoxedRep [TyConApp Lifted []] -- Synonym LiftedRep - TyConApp BoxedRep [TyConApp Unlifted []] -- Synonym UnliftedREp - TyConApp TYPE [TyConApp LiftedRep []] -- Synonym Type - TyConApp TYPE [TyConApp UnliftedRep []] -- Synonym UnliftedType - -While investigating #17292 we found that these constituted a majority -of all TyConApp constructors on the heap: - - (From a sample of 100000 TyConApp closures) - 0x45f3523 - 28732 - `Type` - 0x420b840702 - 9629 - generic type constructors - 0x42055b7e46 - 9596 - 0x420559b582 - 9511 - 0x420bb15a1e - 9509 - 0x420b86c6ba - 9501 - 0x42055bac1e - 9496 - 0x45e68fd - 538 - `TYPE ...` - -Consequently, we try hard to ensure that operations on such types are -efficient. Specifically, we strive to - - a. Avoid heap allocation of such types; use a single static TyConApp - b. Use a small (shallow in the tree-depth sense) representation - for such types - -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". - -To accomplish these we use a number of tricks, implemented by mkTyConApp. - - 1. Instead of (TyConApp BoxedRep [TyConApp Lifted []]), - we prefer a statically-allocated (TyConApp LiftedRep []) - where `LiftedRep` is a type synonym: - type LiftedRep = BoxedRep Lifted - Similarly for UnliftedRep - - 2. Instead of (TyConApp TYPE [TyConApp LiftedRep []]) - we prefer the statically-allocated (TyConApp Type []) - where `Type` is a type synonym - type Type = TYPE LiftedRep - Similarly for UnliftedType - -These serve goal (b) since there are no applied type arguments to traverse, -e.g., during comparison. - - 3. We have a single, statically allocated top-level binding to - represent `TyConApp GHC.Types.Type []` (namely - 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we don't - need to allocate such types (goal (a)). See functions - mkTYPEapp and mkBoxedRepApp - - 4. We use the sharing mechanism described in Note [Sharing nullary TyConApps] - in GHC.Core.TyCon to ensure that we never need to allocate such - nullary applications (goal (a)). - -See #17958, #20541 - -Note [Care using synonyms to compress types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Using a synonym to compress a types has a tricky wrinkle. Consider -coreView applied to (TyConApp LiftedRep []) - -* coreView expands the LiftedRep synonym: - type LiftedRep = BoxedRep Lifted - -* Danger: we might apply the empty substitution to the RHS of the - synonym. And substTy calls mkTyConApp BoxedRep [Lifted]. And - mkTyConApp compresses that back to LiftedRep. Loop! - -* Solution: in expandSynTyConApp_maybe, don't call substTy for nullary - type synonyms. That's more efficient anyway. --} - - - -{- --------------------------------------------------------------------- - CoercionTy - ~~~~~~~~~~ -CoercionTy allows us to inject coercions into types. A CoercionTy -should appear only in the right-hand side of an application. --} - -mkCoercionTy :: Coercion -> Type -mkCoercionTy = CoercionTy - -isCoercionTy :: Type -> Bool -isCoercionTy (CoercionTy _) = True -isCoercionTy _ = False - -isCoercionTy_maybe :: Type -> Maybe Coercion -isCoercionTy_maybe (CoercionTy co) = Just co -isCoercionTy_maybe _ = Nothing - -stripCoercionTy :: Type -> Coercion -stripCoercionTy (CoercionTy co) = co -stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) - -{- ---------------------------------------------------------------------- - SynTy - ~~~~~ - -Notes on type synonyms -~~~~~~~~~~~~~~~~~~~~~~ -The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try -to return type synonyms wherever possible. Thus - - type Foo a = a -> a - -we want - splitFunTys (a -> Foo a) = ([a], Foo a) -not ([a], a -> a) - -The reason is that we then get better (shorter) type signatures in -interfaces. Notably this plays a role in tcTySigs in GHC.Tc.Gen.Bind. - - ---------------------------------------------------------------------- - ForAllTy - ~~~~~~~~ --} - --- | Make a dependent forall over an 'Inferred' variable -mkTyCoInvForAllTy :: TyCoVar -> Type -> Type -mkTyCoInvForAllTy tv ty - | isCoVar tv - , not (tv `elemVarSet` tyCoVarsOfType ty) - = mkVisFunTyMany (varType tv) ty - | otherwise - = ForAllTy (Bndr tv Inferred) ty - --- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar -mkInfForAllTy :: TyVar -> Type -> Type -mkInfForAllTy tv ty = assert (isTyVar tv ) - ForAllTy (Bndr tv Inferred) ty - --- | Like 'mkForAllTys', but assumes all variables are dependent and --- 'Inferred', a common case -mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type -mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs - --- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar -mkInfForAllTys :: [TyVar] -> Type -> Type -mkInfForAllTys tvs ty = foldr mkInfForAllTy ty tvs - --- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', --- a common case -mkSpecForAllTy :: TyVar -> Type -> Type -mkSpecForAllTy tv ty = assert (isTyVar tv ) - -- covar is always Inferred, so input should be tyvar - ForAllTy (Bndr tv Specified) ty - --- | Like 'mkForAllTys', but assumes all variables are dependent and --- 'Specified', a common case -mkSpecForAllTys :: [TyVar] -> Type -> Type -mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs - --- | Like mkForAllTys, but assumes all variables are dependent and visible -mkVisForAllTys :: [TyVar] -> Type -> Type -mkVisForAllTys tvs = assert (all isTyVar tvs ) - -- covar is always Inferred, so all inputs should be tyvar - mkForAllTys [ Bndr tv Required | tv <- tvs ] - --- | Given a list of type-level vars and the free vars of a result kind, --- makes TyCoBinders, preferring anonymous binders --- if the variable is, in fact, not dependent. --- e.g. mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k) --- We want (k:*) Named, (b:k) Anon, (c:k) Anon --- --- All non-coercion binders are /visible/. -mkTyConBindersPreferAnon :: [TyVar] -- ^ binders - -> TyCoVarSet -- ^ free variables of result - -> [TyConBinder] -mkTyConBindersPreferAnon vars inner_tkvs = assert (all isTyVar vars) - fst (go vars) - where - go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars - go [] = ([], inner_tkvs) - go (v:vs) | v `elemVarSet` fvs - = ( Bndr v (NamedTCB Required) : binders - , fvs `delVarSet` v `unionVarSet` kind_vars ) - | otherwise - = ( Bndr v (AnonTCB VisArg) : binders - , fvs `unionVarSet` kind_vars ) - where - (binders, fvs) = go vs - kind_vars = tyCoVarsOfType $ tyVarKind v - --- | Take a ForAllTy apart, returning the list of tycovars and the result type. --- This always succeeds, even if it returns only an empty list. Note that the --- result type returned may have free variables that were bound by a forall. -splitForAllTyCoVars :: Type -> ([TyCoVar], Type) -splitForAllTyCoVars ty = split ty ty [] - where - split _ (ForAllTy (Bndr tv _) ty) tvs = split ty ty (tv:tvs) - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split orig_ty _ tvs = (reverse tvs, orig_ty) - --- | Splits the longest initial sequence of 'ForAllTy's that satisfy --- @argf_pred@, returning the binders transformed by @argf_pred@ -splitSomeForAllTyCoVarBndrs :: (ArgFlag -> Maybe af) -> Type -> ([VarBndr TyCoVar af], Type) -splitSomeForAllTyCoVarBndrs argf_pred ty = split ty ty [] - where - split _ (ForAllTy (Bndr tcv argf) ty) tvs - | Just argf' <- argf_pred argf = split ty ty (Bndr tcv argf' : tvs) - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split orig_ty _ tvs = (reverse tvs, orig_ty) - --- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Required' type --- variable binders. Furthermore, each returned tyvar is annotated with '()'. -splitForAllReqTVBinders :: Type -> ([ReqTVBinder], Type) -splitForAllReqTVBinders ty = splitSomeForAllTyCoVarBndrs argf_pred ty - where - argf_pred :: ArgFlag -> Maybe () - argf_pred Required = Just () - argf_pred (Invisible {}) = Nothing - --- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Invisible' type --- variable binders. Furthermore, each returned tyvar is annotated with its --- 'Specificity'. -splitForAllInvisTVBinders :: Type -> ([InvisTVBinder], Type) -splitForAllInvisTVBinders ty = splitSomeForAllTyCoVarBndrs argf_pred ty - where - argf_pred :: ArgFlag -> Maybe Specificity - argf_pred Required = Nothing - argf_pred (Invisible spec) = Just spec - --- | Like 'splitForAllTyCoVars', but split only for tyvars. --- This always succeeds, even if it returns only an empty list. Note that the --- result type returned may have free variables that were bound by a forall. -splitForAllTyVars :: Type -> ([TyVar], Type) -splitForAllTyVars ty = split ty ty [] - where - split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) - split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split orig_ty _ tvs = (reverse tvs, orig_ty) - --- | Checks whether this is a proper forall (with a named binder) -isForAllTy :: Type -> Bool -isForAllTy ty - | ForAllTy {} <- coreFullView ty = True - | otherwise = False - --- | Like `isForAllTy`, but returns True only if it is a tyvar binder -isForAllTy_ty :: Type -> Bool -isForAllTy_ty ty - | ForAllTy (Bndr tv _) _ <- 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 - | ForAllTy (Bndr tv _) _ <- coreFullView ty - , isCoVar tv - = True - - | otherwise = False - --- | Is this a function or forall? -isPiTy :: Type -> Bool -isPiTy ty = case coreFullView ty of - ForAllTy {} -> True - FunTy {} -> True - _ -> False - --- | Is this a function? -isFunTy :: Type -> Bool -isFunTy ty - | FunTy {} <- coreFullView ty = True - | otherwise = False - --- | Take a forall type apart, or panics if that is not possible. -splitForAllTyCoVar :: Type -> (TyCoVar, Type) -splitForAllTyCoVar ty - | Just answer <- splitForAllTyCoVar_maybe ty = answer - | otherwise = pprPanic "splitForAllTyCoVar" (ppr ty) - --- | Drops all ForAllTys -dropForAlls :: Type -> Type -dropForAlls ty = go ty - where - go (ForAllTy _ res) = go res - 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 -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. -splitForAllTyVar_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllTyVar_maybe ty - | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty - , isTyVar tv - = Just (tv, inner_ty) - - | otherwise = Nothing - --- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a covar binder. -splitForAllCoVar_maybe :: Type -> Maybe (TyCoVar, Type) -splitForAllCoVar_maybe ty - | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty - , isCoVar tv - = Just (tv, inner_ty) - - | otherwise = Nothing - --- | Attempts to take a forall type apart; works with proper foralls and --- functions -{-# INLINE splitPiTy_maybe #-} -- callers will immediately deconstruct -splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type) -splitPiTy_maybe ty = case coreFullView ty of - ForAllTy bndr ty -> Just (Named bndr, ty) - FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res} - -> Just (Anon af (mkScaled w arg), res) - _ -> Nothing - --- | Takes a forall type apart, or panics -splitPiTy :: Type -> (TyCoBinder, Type) -splitPiTy ty - | Just answer <- splitPiTy_maybe ty = answer - | otherwise = pprPanic "splitPiTy" (ppr ty) - --- | Split off all TyCoBinders to a type, splitting both proper foralls --- and functions -splitPiTys :: Type -> ([TyCoBinder], Type) -splitPiTys ty = split ty ty [] - where - split _ (ForAllTy b res) bs = split res res (Named b : bs) - split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) bs - = split res res (Anon af (Scaled w arg) : bs) - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split orig_ty _ bs = (reverse bs, orig_ty) - --- | Extracts a list of run-time arguments from a function type, --- looking through newtypes to the right of arrows. --- --- Examples: --- --- @ --- newtype Identity a = I a --- --- getRuntimeArgTys (Int -> Bool -> Double) == [(Int, VisArg), (Bool, VisArg)] --- getRuntimeArgTys (Identity Int -> Bool -> Double) == [(Identity Int, VisArg), (Bool, VisArg)] --- getRuntimeArgTys (Int -> Identity (Bool -> Identity Double)) == [(Int, VisArg), (Bool, VisArg)] --- getRuntimeArgTys (forall a. Show a => Identity a -> a -> Int -> Bool) == [(Show a, InvisArg), (Identity a, VisArg),(a, VisArg),(Int, VisArg)] --- @ --- --- Note that, in the last case, the returned types might mention an out-of-scope --- type variable. This function is used only when we really care about the /kinds/ --- of the returned types, so this is OK. --- --- **Warning**: this function can return an infinite list. For example: --- --- @ --- newtype N a = MkN (a -> N a) --- getRuntimeArgTys (N a) == repeat (a, VisArg) --- @ -getRuntimeArgTys :: Type -> [(Type, AnonArgFlag)] -getRuntimeArgTys = go - where - go :: Type -> [(Type, AnonArgFlag)] - go (ForAllTy _ res) - = go res - go (FunTy { ft_arg = arg, ft_res = res, ft_af = af }) - = (arg, af) : go res - go ty - | Just ty' <- coreView ty - = go ty' - | Just (_,ty') <- topNormaliseNewType_maybe ty - = go ty' - | otherwise - = [] - --- | Like 'splitPiTys' but split off only /named/ binders --- and returns 'TyCoVarBinder's rather than 'TyCoBinder's -splitForAllTyCoVarBinders :: Type -> ([TyCoVarBinder], Type) -splitForAllTyCoVarBinders ty = split ty ty [] - where - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b res) bs = split res res (b:bs) - split orig_ty _ bs = (reverse bs, orig_ty) -{-# INLINE splitForAllTyCoVarBinders #-} - -invisibleTyBndrCount :: 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)) - --- | Like 'splitPiTys', but returns only *invisible* binders, including constraints. --- Stops at the first visible binder. -splitInvisPiTys :: Type -> ([TyCoBinder], Type) -splitInvisPiTys ty = split ty ty [] - where - split _ (ForAllTy b res) bs - | Bndr _ vis <- b - , isInvisibleArgFlag vis = split res res (Named b : bs) - split _ (FunTy { ft_af = InvisArg, ft_mult = mult, ft_arg = arg, ft_res = res }) bs - = split res res (Anon InvisArg (mkScaled mult arg) : bs) - split orig_ty ty bs - | Just ty' <- coreView ty = split orig_ty ty' bs - split orig_ty _ bs = (reverse bs, orig_ty) - -splitInvisPiTysN :: Int -> Type -> ([TyCoBinder], Type) --- ^ Same as 'splitInvisPiTys', but stop when --- - you have found @n@ 'TyCoBinder's, --- - or you run out of invisible binders -splitInvisPiTysN n ty = split n ty ty [] - where - split n orig_ty ty bs - | n == 0 = (reverse bs, orig_ty) - | Just ty' <- coreView ty = split n orig_ty ty' bs - | ForAllTy b res <- ty - , Bndr _ vis <- b - , isInvisibleArgFlag vis = split (n-1) res res (Named b : bs) - | FunTy { ft_af = InvisArg, ft_mult = mult, ft_arg = arg, ft_res = res } <- ty - = split (n-1) res res (Anon InvisArg (Scaled mult arg) : bs) - | otherwise = (reverse bs, orig_ty) - --- | Given a 'TyCon' and a list of argument types, filter out any invisible --- (i.e., 'Inferred' or 'Specified') arguments. -filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] -filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys - --- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred' --- arguments. -filterOutInferredTypes :: TyCon -> [Type] -> [Type] -filterOutInferredTypes tc tys = - filterByList (map (/= Inferred) $ tyConArgFlags tc tys) tys - --- | Given a 'TyCon' and a list of argument types, partition the arguments --- into: --- --- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and --- --- 2. 'Required' (i.e., visible) arguments -partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) -partitionInvisibleTypes tc tys = - partitionByList (map isInvisibleArgFlag $ tyConArgFlags tc tys) tys - --- | Given a list of things paired with their visibilities, partition the --- things into (invisible things, visible things). -partitionInvisibles :: [(a, ArgFlag)] -> ([a], [a]) -partitionInvisibles = partitionWith pick_invis - where - pick_invis :: (a, ArgFlag) -> Either a a - pick_invis (thing, vis) | isInvisibleArgFlag vis = Left thing - | otherwise = Right thing - --- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is --- applied, determine each argument's visibility --- ('Inferred', 'Specified', or 'Required'). --- --- Wrinkle: consider the following scenario: --- --- > T :: forall k. k -> k --- > tyConArgFlags T [forall m. m -> m -> m, S, R, Q] --- --- After substituting, we get --- --- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n --- --- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, --- and @Q@ is visible. -tyConArgFlags :: TyCon -> [Type] -> [ArgFlag] -tyConArgFlags tc = fun_kind_arg_flags (tyConKind tc) - --- | Given a 'Type' and a list of argument types to which the 'Type' is --- applied, determine each argument's visibility --- ('Inferred', 'Specified', or 'Required'). --- --- Most of the time, the arguments will be 'Required', but not always. Consider --- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is --- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely --- this sort of higher-rank situation in which 'appTyArgFlags' comes in handy, --- since @f Type Bool@ would be represented in Core using 'AppTy's. --- (See also #15792). -appTyArgFlags :: Type -> [Type] -> [ArgFlag] -appTyArgFlags ty = fun_kind_arg_flags (typeKind ty) - --- | Given a function kind and a list of argument types (where each argument's --- kind aligns with the corresponding position in the argument kind), determine --- each argument's visibility ('Inferred', 'Specified', or 'Required'). -fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag] -fun_kind_arg_flags = go emptyTCvSubst - where - go subst ki arg_tys - | Just ki' <- coreView ki = go subst ki' arg_tys - go _ _ [] = [] - go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys) - = argf : go subst' res_ki arg_tys - where - subst' = extendTvSubst subst tv arg_ty - go subst (TyVarTy tv) arg_tys - | Just ki <- lookupTyVar subst tv = go subst ki arg_tys - -- This FunTy case is important to handle kinds with nested foralls, such - -- as this kind (inspired by #16518): - -- - -- forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type - -- - -- Here, we want to get the following ArgFlags: - -- - -- [Inferred, Specified, Required, Required, Specified, Required] - -- forall {k1}. forall k2. k1 -> k2 -> forall k3. k3 -> Type - go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys) - = argf : go subst res_ki arg_tys - where - argf = case af of - VisArg -> Required - InvisArg -> Inferred - go _ _ arg_tys = map (const Required) arg_tys - -- something is ill-kinded. But this can happen - -- when printing errors. Assume everything is Required. - --- @isTauTy@ tests if a type has no foralls or (=>) -isTauTy :: Type -> Bool -isTauTy ty | Just ty' <- coreView ty = isTauTy ty' -isTauTy (TyVarTy _) = True -isTauTy (LitTy {}) = True -isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc -isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (FunTy af w a b) = case af of - InvisArg -> False -- e.g., Eq a => b - VisArg -> isTauTy w && isTauTy a && isTauTy b -- e.g., a -> b -isTauTy (ForAllTy {}) = False -isTauTy (CastTy ty _) = isTauTy ty -isTauTy (CoercionTy _) = False -- Not sure about this - -isAtomicTy :: Type -> Bool --- True if the type is just a single token, and can be printed compactly --- Used when deciding how to lay out type error messages; see the --- call in GHC.Tc.Errors -isAtomicTy (TyVarTy {}) = True -isAtomicTy (LitTy {}) = True -isAtomicTy (TyConApp _ []) = True - -isAtomicTy ty | isLiftedTypeKind ty = True - -- 'Type' prints compactly as * - -- See GHC.Iface.Type.ppr_kind_type - -isAtomicTy _ = False - -{- -%************************************************************************ -%* * - TyCoBinders -%* * -%************************************************************************ --} - --- | Make an anonymous binder -mkAnonBinder :: AnonArgFlag -> Scaled Type -> TyCoBinder -mkAnonBinder = Anon - --- | Does this binder bind a variable that is /not/ erased? Returns --- 'True' for anonymous binders. -isAnonTyCoBinder :: TyCoBinder -> Bool -isAnonTyCoBinder (Named {}) = False -isAnonTyCoBinder (Anon {}) = True - -tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar -tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv -tyCoBinderVar_maybe _ = Nothing - -tyCoBinderType :: TyCoBinder -> Type -tyCoBinderType (Named tvb) = binderType tvb -tyCoBinderType (Anon _ ty) = scaledThing ty - -tyBinderType :: TyBinder -> Type -tyBinderType (Named (Bndr tv _)) - = assert (isTyVar tv ) - tyVarKind tv -tyBinderType (Anon _ ty) = scaledThing ty - --- | Extract a relevant type, if there is one. -binderRelevantType_maybe :: TyCoBinder -> Maybe Type -binderRelevantType_maybe (Named {}) = Nothing -binderRelevantType_maybe (Anon _ ty) = Just (scaledThing ty) - -{- -************************************************************************ -* * -\subsection{Type families} -* * -************************************************************************ --} - -mkFamilyTyConApp :: TyCon -> [Type] -> Type --- ^ Given a family instance TyCon and its arg types, return the --- corresponding family type. E.g: --- --- > data family T a --- > data instance T (Maybe b) = MkT b --- --- Where the instance tycon is :RTL, so: --- --- > mkFamilyTyConApp :RTL Int = T (Maybe Int) -mkFamilyTyConApp tc tys - | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc - , let tvs = tyConTyVars tc - fam_subst = assertPpr (tvs `equalLength` tys) (ppr tc <+> ppr tys) $ - zipTvSubst tvs tys - = mkTyConApp fam_tc (substTys fam_subst fam_tys) - | otherwise - = mkTyConApp tc tys - --- | Get the type on the LHS of a coercion induced by a type/data --- family instance. -coAxNthLHS :: CoAxiom br -> Int -> Type -coAxNthLHS ax ind = - mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) - -isFamFreeTy :: Type -> Bool -isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' -isFamFreeTy (TyVarTy _) = True -isFamFreeTy (LitTy {}) = True -isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc -isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b -isFamFreeTy (FunTy _ w a b) = isFamFreeTy w && isFamFreeTy a && isFamFreeTy b -isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty -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 - -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 - where - 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 - -{- -************************************************************************ -* * -\subsection{Liftedness} -* * -************************************************************************ --} - --- | Tries to compute the 'Levity' of the given type. Returns either --- a definite 'Levity', or 'Nothing' if we aren't sure (e.g. the --- type is representation-polymorphic). --- --- Panics if the kind does not have the shape @TYPE r@. -typeLevity_maybe :: HasDebugCallStack => Type -> Maybe Levity -typeLevity_maybe ty = runtimeRepLevity_maybe (getRuntimeRep ty) - --- | Is the given type definitely unlifted? --- See "Type#type_classification" for what an unlifted type is. --- --- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for --- a more approximate predicate that behaves better in the presence of --- representation polymorphism. -isUnliftedType :: HasDebugCallStack => Type -> Bool - -- 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)) - --- | State token type. -isStateType :: Type -> Bool -isStateType ty - = case tyConAppTyCon_maybe ty of - Just tycon -> tycon == statePrimTyCon - _ -> False - --- | Returns: --- --- * 'False' if the type is /guaranteed/ unlifted or --- * 'True' if it lifted, OR we aren't sure --- (e.g. in a representation-polymorphic case) -mightBeLiftedType :: Type -> Bool -mightBeLiftedType = mightBeLifted . typeLevity_maybe - --- | Returns: --- --- * 'False' if the type is /guaranteed/ lifted or --- * 'True' if it is unlifted, OR we aren't sure --- (e.g. in a representation-polymorphic case) -mightBeUnliftedType :: Type -> Bool -mightBeUnliftedType = mightBeUnlifted . typeLevity_maybe - --- | 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 --- representation polymorphism. -isBoxedType :: Type -> Bool -isBoxedType ty = isBoxedRuntimeRep (getRuntimeRep ty) - --- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) -isRuntimeRepKindedTy :: Type -> Bool -isRuntimeRepKindedTy = isRuntimeRepTy . typeKind - --- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. --- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: --- --- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep --- , String, Int# ] == [String, Int#] --- -dropRuntimeRepArgs :: [Type] -> [Type] -dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy - --- | Extract the RuntimeRep classifier of a type. For instance, --- @getRuntimeRep_maybe Int = Just LiftedRep@. Returns 'Nothing' if this is not --- possible. -getRuntimeRep_maybe :: HasDebugCallStack - => Type -> Maybe Type -getRuntimeRep_maybe = kindRep_maybe . typeKind - --- | Extract the RuntimeRep classifier of a type. For instance, --- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. -getRuntimeRep :: HasDebugCallStack => Type -> Type -getRuntimeRep ty - = case getRuntimeRep_maybe ty of - Just r -> r - Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) - --- | Extract the 'Levity' of a type. For example, @getLevity_maybe Int = Just Lifted@, --- @getLevity (Array# Int) = Just Unlifted@, @getLevity Float# = Nothing@. --- --- Returns 'Nothing' if this is not possible. Does not look through type family applications. -getLevity_maybe :: HasDebugCallStack => Type -> Maybe Type -getLevity_maybe ty - | Just rep <- getRuntimeRep_maybe ty - , Just (tc, [lev]) <- splitTyConApp_maybe rep - , tc == boxedRepDataConTyCon - = Just lev - | otherwise - = Nothing - --- | Extract the 'Levity' of a type. For example, @getLevity Int = Lifted@, --- or @getLevity (Array# Int) = Unlifted@. --- --- Panics if this is not possible. Does not look through type family applications. -getLevity :: HasDebugCallStack => Type -> Type -getLevity ty - | Just lev <- getLevity_maybe ty - = lev - | otherwise - = pprPanic "getLevity" (ppr ty <+> dcolon <+> ppr (typeKind ty)) - -isUnboxedTupleType :: Type -> Bool -isUnboxedTupleType ty - = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey - -- NB: Do not use typePrimRep, as that can't tell the difference between - -- unboxed tuples and unboxed sums - - -isUnboxedSumType :: Type -> Bool -isUnboxedSumType ty - = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey - --- | See "Type#type_classification" for what an algebraic type is. --- Should only be applied to /types/, as opposed to e.g. partially --- saturated type constructors -isAlgType :: Type -> Bool -isAlgType ty - = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc ) - 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'. --- Panics on representation-polymorphic types. -isStrictType :: HasDebugCallStack => Type -> Bool -isStrictType = isUnliftedType - -isPrimitiveType :: Type -> Bool --- ^ Returns true of types that are opaque to Haskell. -isPrimitiveType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc ) - isPrimTyCon tc - _ -> False - -{- -************************************************************************ -* * -\subsection{Join points} -* * -************************************************************************ --} - --- | Determine whether a type could be the type of a join point of given total --- arity, according to the polymorphism rule. A join point cannot be polymorphic --- in its return type, since given --- join j @a @b x y z = e1 in e2, --- the types of e1 and e2 must be the same, and a and b are not in scope for e2. --- (See Note [The polymorphism rule of join points] in "GHC.Core".) Returns False --- also if the type simply doesn't have enough arguments. --- --- Note that we need to know how many arguments (type *and* value) the putative --- join point takes; for instance, if --- j :: forall a. a -> Int --- then j could be a binary join point returning an Int, but it could *not* be a --- unary join point returning a -> Int. --- --- TODO: See Note [Excess polymorphism and join points] -isValidJoinPointType :: JoinArity -> Type -> Bool -isValidJoinPointType arity ty - = valid_under emptyVarSet arity ty - where - valid_under tvs arity ty - | arity == 0 - = tvs `disjointVarSet` tyCoVarsOfType ty - | Just (t, ty') <- splitForAllTyCoVar_maybe ty - = valid_under (tvs `extendVarSet` t) (arity-1) ty' - | Just (_, _, res_ty) <- splitFunTy_maybe ty - = valid_under tvs (arity-1) res_ty - | otherwise - = False - -{- Note [Excess polymorphism and join points] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In principle, if a function would be a join point except that it fails -the polymorphism rule (see Note [The polymorphism rule of join points] in -GHC.Core), it can still be made a join point with some effort. This is because -all tail calls must return the same type (they return to the same context!), and -thus if the return type depends on an argument, that argument must always be the -same. - -For instance, consider: - - let f :: forall a. a -> Char -> [a] - f @a x c = ... f @a y 'a' ... - in ... f @Int 1 'b' ... f @Int 2 'c' ... - -(where the calls are tail calls). `f` fails the polymorphism rule because its -return type is [a], where [a] is bound. But since the type argument is always -'Int', we can rewrite it as: - - let f' :: Int -> Char -> [Int] - f' x c = ... f' y 'a' ... - in ... f' 1 'b' ... f 2 'c' ... - -and now we can make f' a join point: - - join f' :: Int -> Char -> [Int] - f' x c = ... jump f' y 'a' ... - in ... jump f' 1 'b' ... jump f' 2 'c' ... - -It's not clear that this comes up often, however. TODO: Measure how often and -add this analysis if necessary. See #14620. - - -************************************************************************ -* * -\subsection{Sequencing on types} -* * -************************************************************************ --} - -seqType :: Type -> () -seqType (LitTy n) = n `seq` () -seqType (TyVarTy tv) = tv `seq` () -seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (FunTy _ w t1 t2) = seqType w `seq` seqType t1 `seq` seqType t2 -seqType (TyConApp tc tys) = tc `seq` seqTypes tys -seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty -seqType (CastTy ty co) = seqType ty `seq` seqCo co -seqType (CoercionTy co) = seqCo co - -seqTypes :: [Type] -> () -seqTypes [] = () -seqTypes (ty:tys) = seqType ty `seq` seqTypes tys - -{- -************************************************************************ -* * - Comparison for types - (We don't use instances so that we know where it happens) -* * -************************************************************************ - -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 repSplitAppTy_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 -uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for -ordering leads to nondeterminism. We hit the same problem in the TyVarTy case, -comparing type variables is nondeterministic, note the call to nonDetCmpVar in -nonDetCmpTypeX. -See Note [Unique Determinism] for more details. - -Note [Computing equality on types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are several places within GHC that depend on the precise choice of -definitional equality used. If we change that definition, all these places -must be updated. This Note merely serves as a place for all these places -to refer to, so searching for references to this Note will find every place -that needs to be updated. - -See also Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. - --} - -nonDetCmpType :: Type -> Type -> Ordering -nonDetCmpType (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 - = EQ -nonDetCmpType t1 t2 - -- we know k1 and k2 have the same kind, because they both have kind *. - = 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@ - | TEQ -- ^ @t1 ~ t2@ and there are no casts in either, - -- therefore we can conclude @k1 ~ k2@ - | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so - -- they may differ in kind. - | TGT -- ^ @t1 > t2@ - deriving (Eq, Ord, Enum, Bounded) - -nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse - -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep - -- See Note [Computing equality on types] -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 the kinds of - -- the types being compared - TEQX -> toOrdering $ go env k1 k2 - ty_ordering -> toOrdering ty_ordering - where - k1 = typeKind orig_t1 - k2 = typeKind orig_t2 - - toOrdering :: TypeOrdering -> Ordering - toOrdering TLT = LT - toOrdering TEQ = EQ - toOrdering TEQX = EQ - toOrdering TGT = GT - - liftOrdering :: Ordering -> TypeOrdering - liftOrdering LT = TLT - liftOrdering EQ = TEQ - liftOrdering GT = TGT - - thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering - thenCmpTy TEQ rel = rel - thenCmpTy TEQX rel = hasCast rel - thenCmpTy rel _ = rel - - hasCast :: TypeOrdering -> TypeOrdering - hasCast TEQ = TEQX - hasCast rel = rel - - -- 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 - go env t1 t2 - | Just t1' <- coreView t1 = go env t1' t2 - | Just t2' <- coreView t2 = go env t1 t2' - - go env (TyVarTy tv1) (TyVarTy tv2) - = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 - go env (ForAllTy (Bndr tv1 _) t1) (ForAllTy (Bndr tv2 _) t2) - = go env (varType tv1) (varType tv2) - `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 - -- See Note [Equality on AppTys] - go env (AppTy s1 t1) ty2 - | Just (s2, t2) <- repSplitAppTy_maybe ty2 - = go env s1 s2 `thenCmpTy` go env t1 t2 - go env ty1 (AppTy s2 t2) - | Just (s1, t1) <- repSplitAppTy_maybe ty1 - = go env s1 s2 `thenCmpTy` go env t1 t2 - go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) - -- NB: nonDepCmpTypeX does the kind check requested by - -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep - = liftOrdering (nonDetCmpTypeX env s1 s2 `thenCmp` nonDetCmpTypeX env t1 t2) - `thenCmpTy` go env w1 w2 - -- Comparing multiplicities last because the test is usually true - go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) - = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 - go _ (LitTy l1) (LitTy l2) = liftOrdering (nonDetCmpTyLit l1 l2) - go env (CastTy t1 _) t2 = hasCast $ go env t1 t2 - go env t1 (CastTy t2 _) = hasCast $ go env t1 t2 - - go _ (CoercionTy {}) (CoercionTy {}) = TEQ - - -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy - go _ ty1 ty2 - = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2) - where get_rank :: Type -> Int - get_rank (CastTy {}) - = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) - get_rank (TyVarTy {}) = 0 - get_rank (CoercionTy {}) = 1 - get_rank (AppTy {}) = 3 - get_rank (LitTy {}) = 4 - get_rank (TyConApp {}) = 5 - get_rank (FunTy {}) = 6 - get_rank (ForAllTy {}) = 7 - - gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering - gos _ [] [] = TEQ - gos _ [] _ = TLT - 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 - `thenCmp` - nonDetCmpTypesX env tys1 tys2 -nonDetCmpTypesX _ [] _ = LT -nonDetCmpTypesX _ _ [] = GT - -------------- --- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as --- recognized by Kind.isConstraintKindCon) which is considered a synonym for --- 'Type' in Core. --- See Note [Kind Constraint and kind Type] in "GHC.Core.Type". --- See Note [nonDetCmpType nondeterminism] -nonDetCmpTc :: TyCon -> TyCon -> Ordering -nonDetCmpTc tc1 tc2 - = assert (not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2)) $ - u1 `nonDetCmpUnique` u2 - where - u1 = tyConUnique tc1 - u2 = tyConUnique tc2 - -{- -************************************************************************ -* * - The kind of a type -* * -************************************************************************ - -Note [typeKind vs tcTypeKind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We have two functions to get the kind of a type - - * typeKind ignores the distinction between Constraint and * - * tcTypeKind respects the distinction between Constraint and * - -tcTypeKind is used by the type inference engine, for which Constraint -and * are different; after that we use typeKind. - -See also Note [coreView vs tcView] - -Note [Kinding rules for types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In typeKind we consider Constraint and (TYPE LiftedRep) to be identical. -We then have - - t1 : TYPE rep1 - t2 : TYPE rep2 - (FUN) ---------------- - t1 -> t2 : Type - - ty : TYPE rep - `a` is not free in rep -(FORALL) ----------------------- - forall a. ty : TYPE rep - -In tcTypeKind we consider Constraint and (TYPE LiftedRep) to be distinct: - - t1 : TYPE rep1 - t2 : TYPE rep2 - (FUN) ---------------- - t1 -> t2 : Type - - t1 : Constraint - t2 : TYPE rep - (PRED1) ---------------- - t1 => t2 : Type - - t1 : Constraint - t2 : Constraint - (PRED2) --------------------- - t1 => t2 : Constraint - - ty : TYPE rep - `a` is not free in rep -(FORALL1) ----------------------- - forall a. ty : TYPE rep - - ty : Constraint -(FORALL2) ------------------------- - forall a. ty : Constraint - -Note that: -* The only way we distinguish '->' from '=>' is by the fact - that the argument is a PredTy. Both are FunTys - -Note [Phantom type variables in kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - - type K (r :: RuntimeRep) = Type -- Note 'r' is unused - data T r :: K r -- T :: forall r -> K r - foo :: forall r. T r - -The body of the forall in foo's type has kind (K r), and -normally it would make no sense to have - forall r. (ty :: K r) -because the kind of the forall would escape the binding -of 'r'. But in this case it's fine because (K r) exapands -to Type, so we explicitly /permit/ the type - forall r. T r - -To accommodate such a type, in typeKind (forall a.ty) we use -occCheckExpand to expand any type synonyms in the kind of 'ty' -to eliminate 'a'. See kinding rule (FORALL) in -Note [Kinding rules for types] - -See also - * GHC.Core.Type.occCheckExpand - * GHC.Core.Utils.coreAltsType - * GHC.Tc.Validity.checkEscapingKind -all of which grapple with the same problem. - -See #14939. --} - ------------------------------ -typeKind :: HasDebugCallStack => Type -> Kind --- No need to expand synonyms -typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys -typeKind (LitTy l) = typeLiteralKind l -typeKind (FunTy {}) = liftedTypeKind -typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (CastTy _ty co) = coercionRKind co -typeKind (CoercionTy co) = coercionType co - -typeKind (AppTy fun arg) - = go fun [arg] - where - -- Accumulate the type arguments, so we can call piResultTys, - -- rather than a succession of calls to piResultTy (which is - -- asymptotically costly as the number of arguments increases) - go (AppTy fun arg) args = go fun (arg:args) - 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! - -- See Note [Phantom type variables in kinds] - Just k' -> k' - Nothing -> pprPanic "typeKind" - (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) - where - (tvs, body) = splitForAllTyVars ty - body_kind = typeKind body - ---------------------------------------------- --- Utilities to be used in GHC.Core.Unify, --- which uses "tc" functions ---------------------------------------------- - -tcTypeKind :: HasDebugCallStack => Type -> Kind --- No need to expand synonyms -tcTypeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys -tcTypeKind (LitTy l) = typeLiteralKind l -tcTypeKind (TyVarTy tyvar) = tyVarKind tyvar -tcTypeKind (CastTy _ty co) = coercionRKind co -tcTypeKind (CoercionTy co) = coercionType co - -tcTypeKind (FunTy { ft_af = af, ft_res = res }) - | InvisArg <- af - , tcIsConstraintKind (tcTypeKind res) - = constraintKind -- Eq a => Ord a :: Constraint - | otherwise -- Eq a => a -> a :: TYPE LiftedRep - = liftedTypeKind -- Eq a => Array# Int :: Type LiftedRep (not TYPE PtrRep) - -tcTypeKind (AppTy fun arg) - = go fun [arg] - where - -- Accumulate the type arguments, so we can call piResultTys, - -- rather than a succession of calls to piResultTy (which is - -- asymptotically costly as the number of arguments increases) - go (AppTy fun arg) args = go fun (arg:args) - go fun args = piResultTys (tcTypeKind fun) args - -tcTypeKind ty@(ForAllTy {}) - | tcIsConstraintKind body_kind - = constraintKind - - | otherwise - = case occCheckExpand tvs body_kind of - -- We must make sure tv does not occur in kind - -- As it is already out of scope! - -- See Note [Phantom type variables in kinds] - Just k' -> k' - Nothing -> pprPanic "tcTypeKind" - (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) - where - (tvs, body) = splitForAllTyVars ty - body_kind = tcTypeKind body - - -isPredTy :: HasDebugCallStack => Type -> Bool --- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep -isPredTy ty = tcIsConstraintKind (tcTypeKind ty) - --- tcIsConstraintKind stuff only makes sense in the typechecker --- After that Constraint = Type --- See Note [coreView vs tcView] --- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh) -tcIsConstraintKind :: Kind -> Bool -tcIsConstraintKind ty - | Just (tc, args) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here - , isConstraintKindCon tc - = assertPpr (null args) (ppr ty) True - - | otherwise - = False - --- | Like 'kindRep_maybe', but considers 'Constraint' to be distinct --- from 'Type'. For a version that treats them as the same type, see --- 'kindRep_maybe'. -tcKindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type -tcKindRep_maybe kind - | Just (tc, [arg]) <- tcSplitTyConApp_maybe kind -- Note: tcSplit here - , tc `hasKey` tYPETyConKey = Just arg - | otherwise = Nothing - --- | Is this kind equivalent to 'Type'? --- --- This considers 'Constraint' to be distinct from 'Type'. For a version that --- treats them as the same type, see 'isLiftedTypeKind'. -tcIsLiftedTypeKind :: Kind -> Bool -tcIsLiftedTypeKind kind - = case tcKindRep_maybe kind of - Just rep -> isLiftedRuntimeRep rep - Nothing -> False - --- | Is this kind equivalent to @TYPE (BoxedRep l)@ for some @l :: Levity@? --- --- This considers 'Constraint' to be distinct from 'Type'. For a version that --- treats them as the same type, see 'isLiftedTypeKind'. -tcIsBoxedTypeKind :: Kind -> Bool -tcIsBoxedTypeKind kind - = case tcKindRep_maybe kind of - Just rep -> isBoxedRuntimeRep rep - Nothing -> False - --- | Is this kind equivalent to @TYPE r@ (for some unknown r)? --- --- This considers 'Constraint' to be distinct from @*@. -tcIsRuntimeTypeKind :: Kind -> Bool -tcIsRuntimeTypeKind kind = isJust (tcKindRep_maybe kind) - -tcReturnsConstraintKind :: Kind -> Bool --- True <=> the Kind ultimately returns a Constraint --- E.g. * -> Constraint --- forall k. k -> Constraint -tcReturnsConstraintKind kind - | Just kind' <- tcView kind = tcReturnsConstraintKind kind' -tcReturnsConstraintKind (ForAllTy _ ty) = tcReturnsConstraintKind ty -tcReturnsConstraintKind (FunTy { ft_res = ty }) = tcReturnsConstraintKind ty -tcReturnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc -tcReturnsConstraintKind _ = False - --------------------------- -typeLiteralKind :: TyLit -> Kind -typeLiteralKind (NumTyLit {}) = naturalTy -typeLiteralKind (StrTyLit {}) = typeSymbolKind -typeLiteralKind (CharTyLit {}) = charTy - --- | Returns True if a type has a syntactically fixed runtime rep, --- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. --- --- This function is equivalent to @('isFixedRuntimeRepKind' . 'typeKind')@, --- but much faster. --- --- __Precondition:__ The type has kind @('TYPE' blah)@ -typeHasFixedRuntimeRep :: Type -> Bool -typeHasFixedRuntimeRep = go - where - go (TyConApp tc _) - | tcHasFixedRuntimeRep tc = True - go (FunTy {}) = True - go (LitTy {}) = True - go (ForAllTy _ ty) = go ty - go ty = isFixedRuntimeRepKind (typeKind ty) - --- | Looking past all pi-types, does the end result have a --- fixed runtime rep, as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete? --- --- Examples: --- --- * False for @(forall r (a :: TYPE r). String -> a)@ --- * True for @(forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type)@ -resultHasFixedRuntimeRep :: Type -> Bool -resultHasFixedRuntimeRep = typeHasFixedRuntimeRep . snd . splitPiTys - -{- ********************************************************************** -* * - Occurs check expansion -%* * -%********************************************************************* -} - -{- Note [Occurs check expansion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid -of occurrences of tv outside type function arguments, if that is -possible; otherwise, it returns Nothing. - -For example, suppose we have - type F a b = [a] -Then - occCheckExpand b (F Int b) = Just [Int] -but - occCheckExpand a (F a Int) = Nothing - -We don't promise to do the absolute minimum amount of expanding -necessary, but we try not to do expansions we don't need to. We -prefer doing inner expansions first. For example, - type F a b = (a, Int, a, [a]) - type G b = Char -We have - occCheckExpand b (F (G b)) = Just (F Char) -even though we could also expand F to get rid of b. - -Note [Occurrence checking: look inside kinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we are considering unifying - (alpha :: *) ~ Int -> (beta :: alpha -> alpha) -This may be an error (what is that alpha doing inside beta's kind?), -but we must not make the mistake of actually unifying or we'll -build an infinite data structure. So when looking for occurrences -of alpha in the rhs, we must look in the kinds of type variables -that occur there. - -occCheckExpand tries to expand type synonyms to remove -unnecessary occurrences of a variable, and thereby get past an -occurs-check failure. This is good; but - we can't do it in the /kind/ of a variable /occurrence/ - -For example #18451 built an infinite type: - type Const a b = a - data SameKind :: k -> k -> Type - type T (k :: Const Type a) = forall (b :: k). SameKind a b - -We have - b :: k - k :: Const Type a - a :: k (must be same as b) - -So if we aren't careful, a's kind mentions a, which is bad. -And expanding an /occurrence/ of 'a' doesn't help, because the -/binding site/ is the master copy and all the occurrences should -match it. - -Here's a related example: - f :: forall a b (c :: Const Type b). Proxy '[a, c] - -The list means that 'a' gets the same kind as 'c'; but that -kind mentions 'b', so the binders are out of order. - -Bottom line: in occCheckExpand, do not expand inside the kinds -of occurrences. See bad_var_occ in occCheckExpand. And -see #18451 for more debate. --} - -occCheckExpand :: [Var] -> Type -> Maybe Type --- See Note [Occurs check expansion] --- We may have needed to do some type synonym unfolding in order to --- get rid of the variable (or forall), so we also return the unfolded --- version of the type, which is guaranteed to be syntactically free --- of the given type variable. If the type is already syntactically --- free of the variable, then the same type is returned. -occCheckExpand vs_to_avoid ty - | null vs_to_avoid -- Efficient shortcut - = Just ty -- Can happen, eg. GHC.Core.Utils.mkSingleAltCase - - | otherwise - = go (mkVarSet vs_to_avoid, emptyVarEnv) ty - where - go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type - -- The VarSet is the set of variables we are trying to avoid - -- The VarEnv carries mappings necessary - -- because of kind expansion - go (as, env) ty@(TyVarTy tv) - | Just tv' <- lookupVarEnv env tv = return (mkTyVarTy tv') - | bad_var_occ as tv = Nothing - | otherwise = return ty - - go _ ty@(LitTy {}) = return ty - go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1 - ; ty2' <- go cxt ty2 - ; return (mkAppTy ty1' ty2') } - go cxt ty@(FunTy _ w ty1 ty2) - = do { w' <- go cxt w - ; ty1' <- go cxt ty1 - ; ty2' <- go cxt ty2 - ; return (ty { ft_mult = w', ft_arg = ty1', ft_res = ty2' }) } - go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) - = do { ki' <- go cxt (varType tv) - ; let tv' = setVarType tv ki' - env' = extendVarEnv env tv tv' - as' = as `delVarSet` tv - ; body' <- go (as', env') body_ty - ; return (ForAllTy (Bndr tv' vis) body') } - - -- For a type constructor application, first try expanding away the - -- offending variable from the arguments. If that doesn't work, next - -- see if the type constructor is a type synonym, and if so, expand - -- it and try again. - go cxt ty@(TyConApp tc tys) - = case mapM (go cxt) tys of - Just tys' -> return (mkTyConApp tc tys') - Nothing | Just ty' <- tcView ty -> go cxt ty' - | otherwise -> Nothing - -- Failing that, try to expand a synonym - - go cxt (CastTy ty co) = do { ty' <- go cxt ty - ; co' <- go_co cxt co - ; return (mkCastTy ty' co') } - go cxt (CoercionTy co) = do { co' <- go_co cxt co - ; return (mkCoercionTy co') } - - ------------------ - bad_var_occ :: VarSet -> Var -> Bool - -- Works for TyVar and CoVar - -- See Note [Occurrence checking: look inside kinds] - bad_var_occ vs_to_avoid v - = v `elemVarSet` vs_to_avoid - || tyCoVarsOfType (varType v) `intersectsVarSet` vs_to_avoid - - ------------------ - go_mco _ MRefl = return MRefl - go_mco ctx (MCo co) = MCo <$> go_co ctx co - - ------------------ - go_co cxt (Refl ty) = do { ty' <- go cxt ty - ; return (mkNomReflCo ty') } - go_co cxt (GRefl r ty mco) = do { mco' <- go_mco cxt mco - ; ty' <- go cxt ty - ; return (mkGReflCo r ty' mco') } - -- Note: Coercions do not contain type synonyms - go_co cxt (TyConAppCo r tc args) = do { args' <- mapM (go_co cxt) args - ; return (mkTyConAppCo r tc args') } - go_co cxt (AppCo co arg) = do { co' <- go_co cxt co - ; arg' <- go_co cxt arg - ; return (mkAppCo co' arg') } - go_co cxt@(as, env) (ForAllCo tv kind_co 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') } - go_co cxt (FunCo r w co1 co2) = do { co1' <- go_co cxt co1 - ; co2' <- go_co cxt co2 - ; w' <- go_co cxt w - ; return (mkFunCo r w' co1' co2') } - go_co (as,env) co@(CoVarCo c) - | Just c' <- lookupVarEnv env c = return (mkCoVarCo c') - | bad_var_occ as c = Nothing - | otherwise = return co - - go_co (as,_) co@(HoleCo h) - | 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 (mkAxiomInstCo 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 (mkUnivCo p' r ty1' ty2') } - go_co cxt (SymCo co) = do { co' <- go_co cxt co - ; return (mkSymCo co') } - go_co cxt (TransCo co1 co2) = do { co1' <- go_co cxt co1 - ; co2' <- go_co cxt co2 - ; return (mkTransCo co1' co2') } - go_co cxt (NthCo r n co) = do { co' <- go_co cxt co - ; return (mkNthCo r n co') } - go_co cxt (LRCo lr co) = do { co' <- go_co cxt co - ; return (mkLRCo lr co') } - go_co cxt (InstCo co arg) = do { co' <- go_co cxt co - ; arg' <- go_co cxt arg - ; return (mkInstCo co' arg') } - go_co cxt (KindCo co) = do { co' <- go_co cxt co - ; return (mkKindCo co') } - go_co cxt (SubCo co) = do { co' <- go_co cxt co - ; return (mkSubCo co') } - go_co cxt (AxiomRuleCo ax cs) = do { cs' <- mapM (go_co cxt) cs - ; return (mkAxiomRuleCo 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 - - -{- -%************************************************************************ -%* * - Miscellaneous functions -%* * -%************************************************************************ - --} --- | All type constructors occurring in the type; looking through type --- synonyms, but not newtypes. --- When it finds a Class, it returns the class TyCon. -tyConsOfType :: Type -> UniqSet TyCon -tyConsOfType ty - = go ty - where - go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim - go ty | Just ty' <- coreView ty = go ty' - go (TyVarTy {}) = emptyUniqSet - go (LitTy {}) = emptyUniqSet - go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys - go (AppTy a b) = go a `unionUniqSets` go b - go (FunTy _ w a b) = go w `unionUniqSets` - go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon - go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) - go (CastTy ty co) = go ty `unionUniqSets` go_co co - go (CoercionTy co) = go_co co - - go_co (Refl ty) = go ty - 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 (FunCo _ co_mult co1 co2) = go_co co_mult `unionUniqSets` go_co co1 `unionUniqSets` go_co co2 - 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 (CoVarCo {}) = emptyUniqSet - go_co (HoleCo {}) = emptyUniqSet - go_co (SymCo co) = go_co co - go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 - go_co (NthCo _ _ co) = go_co co - go_co (LRCo _ co) = go_co co - 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_s tys = foldr (unionUniqSets . go) emptyUniqSet tys - go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos - - go_tc tc = unitUniqSet tc - go_ax ax = go_tc $ coAxiomTyCon ax - --- | Retrieve the free variables in this type, splitting them based --- on whether they are used visibly or invisibly. Invisible ones come --- first. -splitVisVarsOfType :: Type -> Pair TyCoVarSet -splitVisVarsOfType orig_ty = Pair invis_vars vis_vars - where - Pair invis_vars1 vis_vars = go orig_ty - invis_vars = invis_vars1 `minusVarSet` vis_vars - - go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) - go (AppTy t1 t2) = go t1 `mappend` go t2 - go (TyConApp tc tys) = go_tc tc tys - go (FunTy _ w t1 t2) = go w `mappend` go t1 `mappend` go t2 - go (ForAllTy (Bndr tv _) ty) - = ((`delVarSet` tv) <$> go ty) `mappend` - (invisible (tyCoVarsOfType $ varType tv)) - go (LitTy {}) = mempty - go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) - go (CoercionTy co) = invisible $ tyCoVarsOfCo co - - invisible vs = Pair vs emptyVarSet - - go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in - invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis - -splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet -splitVisVarsOfTypes = foldMap splitVisVarsOfType - -{- -************************************************************************ -* * - Functions over Kinds -* * -************************************************************************ - -Note [Kind Constraint and kind Type] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The kind Constraint is the kind of classes and other type constraints. -The special thing about types of kind Constraint is that - * They are displayed with double arrow: - f :: Ord a => a -> a - * They are implicitly instantiated at call sites; so the type inference - engine inserts an extra argument of type (Ord a) at every call site - to f. - -However, once type inference is over, there is *no* distinction between -Constraint and Type. Indeed we can have coercions between the two. Consider - class C a where - op :: a -> a -For this single-method class we may generate a newtype, which in turn -generates an axiom witnessing - C a ~ (a -> a) -so on the left we have Constraint, and on the right we have Type. -See #7451. - -Because we treat Constraint/Type differently during and after type inference, -GHC has two notions of equality that differ in whether they equate -Constraint/Type or not: - -* GHC.Tc.Utils.TcType.tcEqType implements typechecker equality (see - Note [Typechecker equality vs definitional equality] in GHC.Tc.Utils.TcType), - which treats Constraint and Type as distinct. This is used during type - inference. See #11715 for issues that arise from this. -* GHC.Core.TyCo.Rep.eqType implements definitional equality (see - Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep), which treats - Constraint and Type as equal. This is used after type inference. - -Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with -distinct uniques, they are treated as equal at all times except -during type inference. --} - --- | Checks that a kind of the form 'Type', 'Constraint' --- or @'TYPE r@ is concrete. See 'isConcrete'. --- --- __Precondition:__ The type has kind @('TYPE' blah)@. -isFixedRuntimeRepKind :: HasDebugCallStack => Kind -> Bool -isFixedRuntimeRepKind k - = assertPpr (isLiftedTypeKind k || _is_type) (ppr k) $ - -- the isLiftedTypeKind check is necessary b/c of Constraint - isConcrete k - where - _is_type = classifiesTypeWithValues 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 - where - go ty | Just ty' <- coreView ty = go ty' - go (TyVarTy tv) = isConcreteTyVar tv - go (AppTy ty1 ty2) = go ty1 && go ty2 - go (TyConApp tc tys) - | isConcreteTyCon tc = all go tys - | otherwise = False - go ForAllTy{} = False - go (FunTy _ w t1 t2) = go w - && go (typeKind t1) && go t1 - && go (typeKind t2) && go t2 - go LitTy{} = True - go CastTy{} = False - go CoercionTy{} = False - ------------------------------------------ --- | Does this classify a type allowed to have values? Responds True to things --- like *, TYPE Lifted, TYPE IntRep, TYPE v, Constraint. -classifiesTypeWithValues :: Kind -> Bool --- ^ True of any sub-kind of OpenTypeKind -classifiesTypeWithValues k = isJust (kindRep_maybe k) - -{- -%************************************************************************ -%* * - Pretty-printing -%* * -%************************************************************************ - -Most pretty-printing is either in GHC.Core.TyCo.Rep or GHC.Iface.Type. - --} - --- | Does a 'TyCon' (that is applied to some number of arguments) need to be --- ascribed with an explicit kind signature to resolve ambiguity if rendered as --- a source-syntax type? --- (See @Note [When does a tycon application need an explicit kind signature?]@ --- for a full explanation of what this function checks for.) -tyConAppNeedsKindSig - :: Bool -- ^ Should specified binders count towards injective positions in - -- the kind of the TyCon? (If you're using visible kind - -- applications, then you want True here. - -> TyCon - -> Int -- ^ The number of args the 'TyCon' is applied to. - -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the - -- number of arguments) -tyConAppNeedsKindSig spec_inj_pos tc n_args - | LT <- listLengthCmp tc_binders n_args - = False - | otherwise - = let (dropped_binders, remaining_binders) - = splitAt n_args tc_binders - result_kind = mkTyConKind remaining_binders tc_res_kind - result_vars = tyCoVarsOfType result_kind - dropped_vars = fvVarSet $ - mapUnionFV injective_vars_of_binder dropped_binders - - in not (subVarSet result_vars dropped_vars) - where - tc_binders = tyConBinders tc - tc_res_kind = tyConResKind tc - - -- Returns the variables that would be fixed by knowing a TyConBinder. See - -- Note [When does a tycon application need an explicit kind signature?] - -- for a more detailed explanation of what this function does. - injective_vars_of_binder :: TyConBinder -> FV - injective_vars_of_binder (Bndr tv vis) = - case vis of - AnonTCB VisArg -> injectiveVarsOfType False -- conservative choice - (varType tv) - NamedTCB argf | source_of_injectivity argf - -> unitFV tv `unionFV` - injectiveVarsOfType False (varType tv) - _ -> emptyFV - - source_of_injectivity Required = True - source_of_injectivity Specified = spec_inj_pos - source_of_injectivity Inferred = False - -{- -Note [When does a tycon application need an explicit kind signature?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are a couple of places in GHC where we convert Core Types into forms that -more closely resemble user-written syntax. These include: - -1. Template Haskell Type reification (see, for instance, GHC.Tc.Gen.Splice.reify_tc_app) -2. Converting Types to LHsTypes (such as in Haddock.Convert in haddock) - -This conversion presents a challenge: how do we ensure that the resulting type -has enough kind information so as not to be ambiguous? To better motivate this -question, consider the following Core type: - - -- Foo :: Type -> Type - type Foo = Proxy Type - -There is nothing ambiguous about the RHS of Foo in Core. But if we were to, -say, reify it into a TH Type, then it's tempting to just drop the invisible -Type argument and simply return `Proxy`. But now we've lost crucial kind -information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` -or `Proxy Int` or something else! We've inadvertently introduced ambiguity. - -Unlike in other situations in GHC, we can't just turn on --fprint-explicit-kinds, as we need to produce something which has the same -structure as a source-syntax type. Moreover, we can't rely on visible kind -application, since the first kind argument to Proxy is inferred, not specified. -Our solution is to annotate certain tycons with their kinds whenever they -appear in applied form in order to resolve the ambiguity. For instance, we -would reify the RHS of Foo like so: - - type Foo = (Proxy :: Type -> Type) - -We need to devise an algorithm that determines precisely which tycons need -these explicit kind signatures. We certainly don't want to annotate _every_ -tycon with a kind signature, or else we might end up with horribly bloated -types like the following: - - (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) - -We only want to annotate tycons that absolutely require kind signatures in -order to resolve some sort of ambiguity, and nothing more. - -Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type -require a kind signature? It might require it when we need to fill in any of -T's omitted arguments. By "omitted argument", we mean one that is dropped when -reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and -specified arguments (e.g., TH reification in GHC.Tc.Gen.Splice), and sometimes the -omitted arguments are only the inferred ones (e.g., in situations where -specified arguments are reified through visible kind application). -Regardless, the key idea is that _some_ arguments are going to be omitted after -reification, and the only mechanism we have at our disposal for filling them in -is through explicit kind signatures. - -What do we mean by "fill in"? Let's consider this small example: - - T :: forall {k}. Type -> (k -> Type) -> k - -Moreover, we have this application of T: - - T @{j} Int aty - -When we reify this type, we omit the inferred argument @{j}. Is it fixed by the -other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then -we'll generate an equality constraint (kappa -> Type) and, assuming we can -solve it, that will fix `kappa`. (Here, `kappa` is the unification variable -that we instantiate `k` with.) - -Therefore, for any application of a tycon T to some arguments, the Question We -Must Answer is: - -* Given the first n arguments of T, do the kinds of the non-omitted arguments - fill in the omitted arguments? - -(This is still a bit hand-wavey, but we'll refine this question incrementally -as we explain more of the machinery underlying this process.) - -Answering this question is precisely the role that the `injectiveVarsOfType` -and `injective_vars_of_binder` functions exist to serve. If an omitted argument -`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing -`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a -bit.) - -More formally, if -`a` is in `injectiveVarsOfType ty` -and S1(ty) ~ S2(ty), -then S1(a) ~ S2(a), -where S1 and S2 are arbitrary substitutions. - -For example, is `F` is a non-injective type family, then - - injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} - -Now that we know what this function does, here is a second attempt at the -Question We Must Answer: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. Do the injective - variables of these binders fill in the remainder of T's kind? - -Alright, we're getting closer. Next, we need to clarify what the injective -variables of a tycon binder are. This the role that the -`injective_vars_of_binder` function serves. Here is what this function does for -each form of tycon binder: - -* Anonymous binders are injective positions. For example, in the promoted data - constructor '(:): - - '(:) :: forall a. a -> [a] -> [a] - - The second and third tyvar binders (of kinds `a` and `[a]`) are both - anonymous, so if we had '(:) 'True '[], then the kinds of 'True and - '[] would contribute to the kind of '(:) 'True '[]. Therefore, - injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. - (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) -* Named binders: - - Inferred binders are never injective positions. For example, in this data - type: - - data Proxy a - Proxy :: forall {k}. k -> Type - - If we had Proxy 'True, then the kind of 'True would not contribute to the - kind of Proxy 'True. Therefore, - injective_vars_of_binder(forall {k}. ...) = {}. - - Required binders are injective positions. For example, in this data type: - - data Wurble k (a :: k) :: k - Wurble :: forall k -> k -> k - - The first tyvar binder (of kind `forall k`) has required visibility, so if - we had Wurble (Maybe a) Nothing, then the kind of Maybe a would - contribute to the kind of Wurble (Maybe a) Nothing. Hence, - injective_vars_of_binder(forall a -> ...) = {a}. - - Specified binders /might/ be injective positions, depending on how you - approach things. Continuing the '(:) example: - - '(:) :: forall a. a -> [a] -> [a] - - Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind - of '(:) 'True '[], since it's not explicitly instantiated by the user. But - if visible kind application is enabled, then this is possible, since the - user can write '(:) @Bool 'True '[]. (In that case, - injective_vars_of_binder(forall a. ...) = {a}.) - - There are some situations where using visible kind application is appropriate - and others where it is not (e.g., TH - reification), so the `injective_vars_of_binder` function is parametrized by - a Bool which decides if specified binders should be counted towards - injective positions or not. - -Now that we've defined injective_vars_of_binder, we can refine the Question We -Must Answer once more: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. For each such binder - b_i, take the union of all injective_vars_of_binder(b_i). Is this set a - superset of the free variables of the remainder of T's kind? - -If the answer to this question is "no", then (T ty_1 ... ty_n) needs an -explicit kind signature, since T's kind has kind variables leftover that -aren't fixed by the non-omitted arguments. - -One last sticking point: what does "the remainder of T's kind" mean? You might -be tempted to think that it corresponds to all of the arguments in the kind of -T that would normally be instantiated by omitted arguments. But this isn't -quite right, strictly speaking. Consider the following (silly) example: - - S :: forall {k}. Type -> Type - -And suppose we have this application of S: - - S Int Bool - -The Int argument would be omitted, and -injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which -might suggest that (S Bool) needs an explicit kind signature. But -(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature -only affects the /result/ of the application, not all of the individual -arguments. So adding a kind signature here won't make a difference. Therefore, -the fourth (and final) iteration of the Question We Must Answer is: - -* Given the first n arguments of T (ty_1 ... ty_n), consider the binders - of T that are instantiated by non-omitted arguments. For each such binder - b_i, take the union of all injective_vars_of_binder(b_i). Is this set a - superset of the free variables of the kind of (T ty_1 ... ty_n)? - -Phew, that was a lot of work! - -How can be sure that this is correct? That is, how can we be sure that in the -event that we leave off a kind annotation, that one could infer the kind of the -tycon application from its arguments? It's essentially a proof by induction: if -we can infer the kinds of every subtree of a type, then the whole tycon -application will have an inferrable kind--unless, of course, the remainder of -the tycon application's kind has uninstantiated kind variables. - -What happens if T is oversaturated? That is, if T's kind has fewer than n -arguments, in the case that the concrete application instantiates a result -kind variable with an arrow kind? If we run out of arguments, we do not attach -a kind annotation. This should be a rare case, indeed. Here is an example: - - data T1 :: k1 -> k2 -> * - data T2 :: k1 -> k2 -> * - - type family G (a :: k) :: k - type instance G T1 = T2 - - type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above - -Here G's kind is (forall k. k -> k), and the desugared RHS of that last -instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to -the algorithm above, there are 3 arguments to G so we should peel off 3 -arguments in G's kind. But G's kind has only two arguments. This is the -rare special case, and we choose not to annotate the application of G with -a kind signature. After all, we needn't do this, since that instance would -be reified as: - - type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool - -So the kind of G isn't ambiguous anymore due to the explicit kind annotation -on its argument. See #8953 and test th/T8953. --} - -{- -************************************************************************ -* * - Multiplicities -* * -************************************************************************ - -These functions would prefer to be in GHC.Core.Multiplicity, but -they some are used elsewhere in this module, and wanted to bring -their friends here with them. --} - -unrestricted, linear, tymult :: a -> Scaled a - --- | Scale a payload by Many -unrestricted = Scaled Many - --- | Scale a payload by One -linear = Scaled One - --- | Scale a payload by Many; used for type arguments in core -tymult = Scaled Many - -irrelevantMult :: Scaled a -> a -irrelevantMult = scaledThing - -mkScaled :: Mult -> a -> Scaled a -mkScaled = Scaled - -scaledSet :: Scaled a -> b -> Scaled b -scaledSet (Scaled m _) b = Scaled m b - -pattern One :: Mult -pattern One <- (isOneDataConTy -> True) - where One = oneDataConTy - -pattern Many :: Mult -pattern Many <- (isManyDataConTy -> True) - where Many = manyDataConTy - -isManyDataConTy :: Mult -> Bool -isManyDataConTy ty - | Just tc <- tyConAppTyCon_maybe ty - = tc `hasKey` manyDataConKey -isManyDataConTy _ = False - -isOneDataConTy :: Mult -> Bool -isOneDataConTy ty - | Just tc <- tyConAppTyCon_maybe ty - = tc `hasKey` oneDataConKey -isOneDataConTy _ = False - -isLinearType :: Type -> Bool --- ^ @isLinear t@ returns @True@ of a if @t@ is a type of (curried) function --- where at least one argument is linear (or otherwise non-unrestricted). We use --- this function to check whether it is safe to eta reduce an Id in CorePrep. It --- is always safe to return 'True', because 'True' deactivates the optimisation. -isLinearType ty = case ty of - FunTy _ Many _ res -> isLinearType res - FunTy _ _ _ _ -> True - ForAllTy _ res -> isLinearType res - _ -> False +{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Main functions for manipulating types and type-related things +module GHC.Core.Type ( + -- Note some of this is just re-exports from TyCon.. + + -- * Main data types representing Types + -- $type_classification + + -- $representation_types + Type, ForAllTyFlag(..), FunTyFlag(..), + Specificity(..), + KindOrType, PredType, ThetaType, FRRType, + Var, TyVar, isTyVar, TyCoVar, PiTyBinder, ForAllTyBinder, TyVarBinder, + Mult, Scaled, + KnotTied, RuntimeRepType, + + -- ** Constructing and deconstructing types + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, + getCastedTyVar_maybe, tyVarKind, varType, + + mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTysNoView, + splitAppTy_maybe, splitAppTyNoView_maybe, tcSplitAppTyNoView_maybe, + + mkFunTy, mkVisFunTy, + mkVisFunTyMany, mkVisFunTysMany, + mkScaledFunTys, + mkInvisFunTy, mkInvisFunTys, + tcMkVisFunTy, tcMkScaledFunTys, tcMkInvisFunTy, + splitFunTy, splitFunTy_maybe, + splitFunTys, funResultTy, funArgTy, + funTyConAppTy_maybe, funTyFlagTyCon, + tyConAppFunTy_maybe, tyConAppFunCo_maybe, + mkFunctionType, mkScaledFunctionTys, chooseFunTyFlag, + + mkTyConApp, mkTyConTy, + tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, + tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, + + splitTyConApp_maybe, splitTyConAppNoView_maybe, splitTyConApp, + tcSplitTyConApp, tcSplitTyConApp_maybe, + + mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, + mkSpecForAllTy, mkSpecForAllTys, + mkVisForAllTys, mkTyCoInvForAllTy, + mkInfForAllTy, mkInfForAllTys, + splitForAllTyCoVars, splitForAllTyVars, + splitForAllReqTyBinders, splitForAllInvisTyBinders, + splitForAllForAllTyBinders, + splitForAllTyCoVar_maybe, splitForAllTyCoVar, + splitForAllTyVar_maybe, splitForAllCoVar_maybe, + splitPiTy_maybe, splitPiTy, splitPiTys, + getRuntimeArgTys, + mkTyConBindersPreferAnon, + mkPiTy, mkPiTys, + piResultTy, piResultTys, + applyTysX, dropForAlls, + mkFamilyTyConApp, + buildSynTyCon, + + mkNumLitTy, isNumLitTy, + mkStrLitTy, isStrLitTy, + mkCharLitTy, isCharLitTy, + isLitTy, + + isPredTy, + + getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep, + getLevity, levityType_maybe, + + mkCastTy, mkCoercionTy, splitCastTy_maybe, + + userTypeError_maybe, pprUserTypeErrorTy, + + coAxNthLHS, + stripCoercionTy, + + splitInvisPiTys, splitInvisPiTysN, + invisibleTyBndrCount, + filterOutInvisibleTypes, filterOutInferredTypes, + partitionInvisibleTypes, partitionInvisibles, + tyConForAllTyFlags, appTyForAllTyFlags, + + -- ** Analyzing types + TyCoMapper(..), mapTyCo, mapTyCoX, + TyCoFolder(..), foldTyCo, noView, + + -- (Newtypes) + newTyConInstRhs, + + -- ** Binders + mkForAllTyBinder, mkForAllTyBinders, + mkTyVarBinder, mkTyVarBinders, + tyVarSpecToBinders, + isAnonPiTyBinder, + binderVar, binderVars, binderType, binderFlag, binderFlags, + piTyBinderType, namedPiTyBinder_maybe, + anonPiTyBinderType_maybe, + isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isVisiblePiTyBinder, + isInvisiblePiTyBinder, isNamedPiTyBinder, + tyConBindersPiTyBinders, + + -- ** Predicates on types + isTyVarTy, isFunTy, isCoercionTy, + isCoercionTy_maybe, isForAllTy, + isForAllTy_ty, isForAllTy_co, + isPiTy, isTauTy, isFamFreeTy, + isCoVarType, isAtomicTy, + + isValidJoinPointType, + tyConAppNeedsKindSig, + + -- * Space-saving construction + mkTYPEapp, mkTYPEapp_maybe, + mkCONSTRAINTapp, mkCONSTRAINTapp_maybe, + mkBoxedRepApp_maybe, mkTupleRepApp_maybe, + typeOrConstraintKind, + + -- *** Levity and boxity + sORTKind_maybe, typeTypeOrConstraint, + typeLevity_maybe, tyConIsTYPEorCONSTRAINT, + isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind, + isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe, + isBoxedRuntimeRep, + isLiftedLevity, isUnliftedLevity, + isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType, + kindBoxedRepLevity_maybe, + mightBeLiftedType, mightBeUnliftedType, + isAlgType, isDataFamilyAppType, + isPrimitiveType, isStrictType, + isLevityTy, isLevityVar, + isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, + dropRuntimeRepArgs, + + -- * Multiplicity + + isMultiplicityTy, isMultiplicityVar, + unrestricted, linear, tymult, + mkScaled, irrelevantMult, scaledSet, + pattern OneTy, pattern ManyTy, + isOneTy, isManyTy, + isLinearType, + + -- * Main data types representing Kinds + Kind, + + -- ** Finding the kind of a type + typeKind, typeHasFixedRuntimeRep, argsHaveFixedRuntimeRep, + tcIsLiftedTypeKind, + isConstraintKind, isConstraintLikeKind, returnsConstraintKind, + tcIsBoxedTypeKind, isTypeLikeKind, + + -- ** Common Kind + liftedTypeKind, unliftedTypeKind, + + -- * Type free variables + tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoVarsOfType, tyCoVarsOfTypes, + tyCoVarsOfTypeDSet, + coVarsOfType, + coVarsOfTypes, + + anyFreeVarsOfType, anyFreeVarsOfTypes, + noFreeVarsOfType, + expandTypeSynonyms, + 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, + + tyConsOfType, + + -- * Main type substitution data types + TvSubstEnv, -- Representation widely visible + IdSubstEnv, + Subst(..), -- Representation visible to a few friends + + -- ** Manipulating type substitutions + emptyTvSubstEnv, emptySubst, mkEmptySubst, + + mkSubst, zipTvSubst, mkTvSubstPrs, + zipTCvSubst, + notElemSubst, + getTvSubstEnv, + zapSubst, getSubstInScope, setInScope, getSubstRangeTyCoFVs, + extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet, + extendTCvSubst, extendCvSubst, + extendTvSubst, extendTvSubstBinderAndInScope, + extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, + extendTvSubstWithClone, + extendTCvSubstWithClone, + isInScope, composeTCvSubst, zipTyEnv, zipCoEnv, + isEmptySubst, unionSubst, isEmptyTCvSubst, + + -- ** Performing substitution on types and kinds + substTy, substTys, substScaledTy, substScaledTys, substTyWith, substTysWith, substTheta, + substTyAddInScope, + substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked, + substThetaUnchecked, substTyWithUnchecked, + substCo, substCoUnchecked, substCoWithUnchecked, + substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, + substVarBndr, substVarBndrs, + 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, + ) where + +import GHC.Prelude + +import GHC.Types.Basic + +-- We import the representation and primitive functions from GHC.Core.TyCo.Rep. +-- Many things are reexported, but not the representation! + +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 + +import {-# SOURCE #-} GHC.Builtin.Types + ( charTy, naturalTy + , typeSymbolKind, liftedTypeKind, unliftedTypeKind + , constraintKind, zeroBitTypeKind + , manyDataConTy, oneDataConTy + , liftedRepTy, unliftedRepTy, zeroBitRepTy ) + +import GHC.Types.Name( Name ) +import GHC.Builtin.Names +import GHC.Core.Coercion.Axiom + +import {-# SOURCE #-} GHC.Core.Coercion + ( mkNomReflCo, mkGReflCo, mkReflCo + , mkTyConAppCo, mkAppCo + , mkForAllCo, mkFunCo2, mkAxiomInstCo, mkUnivCo + , mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo + , mkKindCo, mkSubCo, mkFunCo1 + , decomposePiCos, coercionKind + , coercionRKind, coercionType + , isReflexiveCo, seqCo + , topNormaliseNewType_maybe + ) +import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isConcreteTyVar ) + +-- others +import GHC.Utils.Misc +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 ) + +-- $type_classification +-- #type_classification# +-- +-- Types are any, but at least one, of: +-- +-- [Boxed] Iff its representation is a pointer to an object on the +-- GC'd heap. Operationally, heap objects can be entered as +-- a means of evaluation. +-- +-- [Lifted] Iff it has bottom as an element: An instance of a +-- lifted type might diverge when evaluated. +-- GHC Haskell's unboxed types are unlifted. +-- An unboxed, but lifted type is not very useful. +-- (Example: A byte-represented type, where evaluating 0xff +-- computes the 12345678th collatz number modulo 0xff.) +-- Only lifted types may be unified with a type variable. +-- +-- [Algebraic] Iff it is a type with one or more constructors, whether +-- declared with @data@ or @newtype@. +-- An algebraic type is one that can be deconstructed +-- with a case expression. There are algebraic types that +-- are not lifted types, like unlifted data types or +-- unboxed tuples. +-- +-- [Data] Iff it is a type declared with @data@, or a boxed tuple. +-- There are also /unlifted/ data types. +-- +-- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. +-- +-- [Unlifted] Anything that isn't lifted is considered unlifted. +-- +-- Currently, all primitive types are unlifted, but that's not necessarily +-- the case: for example, @Int@ could be primitive. +-- +-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed +-- but unlifted (such as @ByteArray#@). The only primitive types that we +-- classify as algebraic are the unboxed tuples. +-- +-- Some examples of type classifications that may make this a bit clearer are: +-- +-- @ +-- Type primitive boxed lifted algebraic +-- ----------------------------------------------------------------------------- +-- Int# Yes No No No +-- ByteArray# Yes Yes No No +-- (\# a, b \#) Yes No No Yes +-- (\# a | b \#) Yes No No Yes +-- ( a, b ) No Yes Yes Yes +-- [a] No Yes Yes Yes +-- @ + +-- $representation_types +-- A /source type/ is a type that is a separate type as far as the type checker is +-- concerned, but which has a more low-level representation as far as Core-to-Core +-- passes and the rest of the back end is concerned. +-- +-- You don't normally have to worry about this, as the utility functions in +-- this module will automatically convert a source into a representation type +-- if they are spotted, to the best of its abilities. If you don't want this +-- to happen, use the equivalent functions from the "TcType" module. + +{- +************************************************************************ +* * + Type representation +* * +************************************************************************ +-} + +coreView :: Type -> Maybe Type +-- ^ This function strips off the /top layer only/ of a type synonym +-- application (if any) its underlying representation type. +-- Returns 'Nothing' if there is nothing to look through. +-- +-- This function does not look through type family applications. +-- +-- By being non-recursive and inlined, this case analysis gets efficiently +-- joined onto the case analysis that the caller is already doing +coreView (TyConApp tc tys) = expandSynTyConApp_maybe tc tys +coreView _ = Nothing +-- See Note [Inlining coreView]. +{-# INLINE coreView #-} + +coreFullView, core_full_view :: Type -> Type +-- ^ Iterates 'coreView' until there is no more to synonym to expand. +-- NB: coreFullView is non-recursive and can be inlined; +-- core_full_view is the recursive one +-- See Note [Inlining coreView]. +coreFullView ty@(TyConApp tc _) + | isTypeSynonymTyCon tc = core_full_view ty +coreFullView ty = ty +{-# INLINE coreFullView #-} + +core_full_view ty + | Just ty' <- coreView ty = core_full_view ty' + | otherwise = ty + +----------------------------------------------- +-- | @expandSynTyConApp_maybe tc tys@ expands the RHS of type synonym @tc@ +-- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a +-- synonym. +expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type +{-# INLINE expandSynTyConApp_maybe #-} +-- This INLINE will inline the call to expandSynTyConApp_maybe in coreView, +-- which will eliminate the allocation Just/Nothing in the result +-- Don't be tempted to make `expand_syn` (which is NOINLINE) return the +-- Just/Nothing, else you'll increase allocation +expandSynTyConApp_maybe tc arg_tys + | Just (tvs, rhs) <- synTyConDefn_maybe tc + , arg_tys `saturates` tyConArity tc + = Just (expand_syn tvs rhs arg_tys) + | otherwise + = Nothing + +saturates :: [Type] -> Arity -> Bool +saturates _ 0 = True +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 + +-- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path +-- into call-sites. +-- +-- Precondition: the call is saturated or over-saturated; +-- i.e. length tvs <= length arg_tys +expand_syn :: [TyVar] -- ^ the variables bound by the synonym + -> Type -- ^ the RHS of the synonym + -> [Type] -- ^ the type arguments the synonym is instantiated at. + -> Type +{-# NOINLINE expand_syn #-} -- We never want to inline this cold-path. + +expand_syn tvs rhs arg_tys + -- No substitution necessary if either tvs or tys is empty + -- This is both more efficient, and steers clear of an infinite + -- loop; see Note [Care using synonyms to compress types] + | null arg_tys = assert (null tvs) rhs + | null tvs = mkAppTys rhs arg_tys + | otherwise = go empty_subst tvs arg_tys + where + empty_subst = mkEmptySubst in_scope + in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ arg_tys + -- The free vars of 'rhs' should all be bound by 'tenv', + -- so we only need the free vars of tys + -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst. + + go subst [] tys + | null tys = rhs' -- Exactly Saturated + | otherwise = mkAppTys rhs' tys + -- Its important to use mkAppTys, rather than (foldl AppTy), + -- because the function part might well return a + -- partially-applied type constructor; indeed, usually will! + where + rhs' = substTy subst rhs + + go subst (tv:tvs) (ty:tys) = go (extendTvSubst subst tv ty) tvs tys + + go _ (_:_) [] = pprPanic "expand_syn" (ppr tvs $$ ppr rhs $$ ppr arg_tys) + -- Under-saturated, precondition failed + +{- Note [Inlining coreView] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very common to have a function + + f :: Type -> ... + f ty | Just ty' <- coreView ty = f ty' + f (TyVarTy ...) = ... + f ... = ... + +If f is not otherwise recursive, the initial call to coreView +causes f to become recursive, which kills the possibility of +inlining. Instead, for non-recursive functions, we prefer to +use coreFullView, which guarantees to unwrap top-level type +synonyms. It can be inlined and is efficient and non-allocating +in its fast path. For this to really be fast, all calls made +on its fast path must also be inlined, linked back to this Note. +-} + + +{- ********************************************************************* +* * + expandTypeSynonyms +* * +********************************************************************* -} + +expandTypeSynonyms :: Type -> Type +-- ^ Expand out all type synonyms. Actually, it'd suffice to expand out +-- just the ones that discard type variables (e.g. type Funny a = Int) +-- But we don't know which those are currently, so we just expand all. +-- +-- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type, +-- not in the kinds of any TyCon or TyVar mentioned in the type. +-- +-- Keep this synchronized with 'synonymTyConsOfType' +expandTypeSynonyms ty + = go (mkEmptySubst in_scope) ty + where + in_scope = mkInScopeSet (tyCoVarsOfType ty) + + go subst (TyConApp tc tys) + | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc expanded_tys + = let subst' = mkTvSubst in_scope (mkVarEnv tenv) + -- Make a fresh substitution; rhs has nothing to + -- do with anything that has happened so far + -- NB: if you make changes here, be sure to build an + -- /idempotent/ substitution, even in the nested case + -- type T a b = a -> b + -- type S x y = T y x + -- (#11665) + in mkAppTys (go subst' rhs) tys' + | otherwise + = TyConApp tc expanded_tys + where + expanded_tys = (map (go subst) tys) + + go _ (LitTy l) = LitTy l + go subst (TyVarTy tv) = substTyVar subst tv + go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) + go subst ty@(FunTy _ mult arg res) + = ty { ft_mult = go subst mult, ft_arg = go subst arg, ft_res = go subst res } + go subst (ForAllTy (Bndr tv vis) t) + = let (subst', tv') = substVarBndrUsing go subst tv in + ForAllTy (Bndr tv' vis) (go subst' t) + go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) + go subst (CoercionTy co) = mkCoercionTy (go_co subst co) + + go_mco _ MRefl = MRefl + go_mco subst (MCo co) = MCo (go_co subst co) + + go_co subst (Refl ty) + = mkNomReflCo (go subst ty) + go_co subst (GRefl r ty mco) + = mkGReflCo r (go subst ty) (go_mco subst mco) + -- NB: coercions are always expanded upon creation + go_co subst (TyConAppCo r tc args) + = 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) + = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in + mkForAllCo tv' 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 (SymCo co) + = mkSymCo (go_co subst co) + go_co subst (TransCo co1 co2) + = mkTransCo (go_co subst co1) (go_co subst co2) + go_co subst (SelCo n co) + = mkSelCo n (go_co subst co) + go_co subst (LRCo lr co) + = mkLRCo lr (go_co subst co) + go_co subst (InstCo co arg) + = mkInstCo (go_co subst co) (go_co subst arg) + go_co subst (KindCo co) + = 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 + +{- Notes on type synonyms +~~~~~~~~~~~~~~~~~~~~~~~~~ +The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try +to return type synonyms wherever possible. Thus + + type Foo a = a -> a + +we want + splitFunTys (a -> Foo a) = ([a], Foo a) +not ([a], a -> a) + +The reason is that we then get better (shorter) type signatures in +interfaces. Notably this plays a role in tcTySigs in GHC.Tc.Gen.Bind. +-} + +{- ********************************************************************* +* * + Random functions (todo: organise) +* * +********************************************************************* -} + +-- | An INLINE helper for function such as 'kindRep_maybe' below. +-- +-- @isTyConKeyApp_maybe key ty@ returns @Just tys@ iff +-- the type @ty = T tys@, where T's unique = key +-- key must not be `fUNTyConKey`; to test for functions, use `splitFunTy_maybe`. +-- Thanks to this fact, we don't have to pattern match on `FunTy` here. +isTyConKeyApp_maybe :: Unique -> Type -> Maybe [Type] +isTyConKeyApp_maybe key ty + | TyConApp tc args <- coreFullView ty + , tc `hasKey` key + = Just args + | otherwise + = Nothing +{-# INLINE isTyConKeyApp_maybe #-} + +-- | Extract the RuntimeRep classifier of a type from its kind. For example, +-- @kindRep * = LiftedRep@; Panics if this is not possible. +-- Treats * and Constraint as the same +kindRep :: HasDebugCallStack => Kind -> RuntimeRepType +kindRep k = case kindRep_maybe k of + Just r -> r + Nothing -> pprPanic "kindRep" (ppr k) + +-- | Given a kind (TYPE rr) or (CONSTRAINT rr), extract its RuntimeRep classifier rr. +-- For example, @kindRep_maybe * = Just LiftedRep@ +-- Returns 'Nothing' if the kind is not of form (TYPE rr) +kindRep_maybe :: HasDebugCallStack => Kind -> Maybe RuntimeRepType +kindRep_maybe kind + | Just (_, rep) <- sORTKind_maybe kind = Just rep + | otherwise = Nothing + +-- | Returns True if the argument is (lifted) Type or Constraint +-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim +isLiftedTypeKind :: Kind -> Bool +isLiftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isLiftedRuntimeRep rep + Nothing -> False + +-- | Returns True if the kind classifies unlifted types (like 'Int#') and False +-- otherwise. Note that this returns False for representation-polymorphic +-- kinds, which may be specialized to a kind that classifies unlifted types. +isUnliftedTypeKind :: Kind -> Bool +isUnliftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isUnliftedRuntimeRep rep + Nothing -> False + +pickyIsLiftedTypeKind :: Kind -> Bool +-- Checks whether the kind is literally +-- TYPE LiftedRep +-- or TYPE ('BoxedRep 'Lifted) +-- or Type +-- without expanding type synonyms or anything +-- Used only when deciding whether to suppress the ":: *" in +-- (a :: *) when printing kinded type variables +-- See Note [Suppressing * kinds] in GHC.Core.TyCo.Ppr +pickyIsLiftedTypeKind kind + | TyConApp tc [arg] <- kind + , tc `hasKey` tYPETyConKey + , TyConApp rr_tc rr_args <- arg = case rr_args of + [] -> rr_tc `hasKey` liftedRepTyConKey + [rr_arg] + | rr_tc `hasKey` boxedRepDataConKey + , TyConApp lev [] <- rr_arg + , lev `hasKey` liftedDataConKey -> True + _ -> False + | TyConApp tc [] <- kind + , tc `hasKey` liftedTypeKindTyConKey = True + | otherwise = False + +-- | Check whether a kind is of the form `TYPE (BoxedRep Lifted)` +-- or `TYPE (BoxedRep Unlifted)`. +-- +-- Returns: +-- +-- - `Just Lifted` for `TYPE (BoxedRep Lifted)` and `Type`, +-- - `Just Unlifted` for `TYPE (BoxedRep Unlifted)` and `UnliftedType`, +-- - `Nothing` for anything else, e.g. `TYPE IntRep`, `TYPE (BoxedRep l)`, etc. +kindBoxedRepLevity_maybe :: Type -> Maybe Levity +kindBoxedRepLevity_maybe ty + | Just rep <- kindRep_maybe ty + , isBoxedRuntimeRep rep + = runtimeRepLevity_maybe rep + | otherwise + = Nothing + +-- | Check whether a type of kind 'RuntimeRep' is lifted. +-- +-- 'isLiftedRuntimeRep' is: +-- +-- * True of @LiftedRep :: RuntimeRep@ +-- * 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 + +-- | Check whether a type of kind 'RuntimeRep' is unlifted. +-- +-- * True of definitely unlifted 'RuntimeRep's such as +-- 'UnliftedRep', 'IntRep', 'FloatRep', ... +-- * False of 'LiftedRep', +-- * False for type variables and type family applications. +isUnliftedRuntimeRep :: RuntimeRepType -> Bool +isUnliftedRuntimeRep rep = + runtimeRepLevity_maybe rep == Just Unlifted + +-- | An INLINE helper for functions such as 'isLiftedLevity' and 'isUnliftedLevity'. +-- +-- Checks whether the type is a nullary 'TyCon' application, +-- for a 'TyCon' with the given 'Unique'. +isNullaryTyConKeyApp :: Unique -> Type -> Bool +isNullaryTyConKeyApp key ty + | Just args <- isTyConKeyApp_maybe key ty + = assert (null args) True + | otherwise + = False +{-# INLINE isNullaryTyConKeyApp #-} + +isLiftedLevity :: Type -> Bool +isLiftedLevity = isNullaryTyConKeyApp liftedDataConKey + +isUnliftedLevity :: Type -> Bool +isUnliftedLevity = isNullaryTyConKeyApp unliftedDataConKey + +-- | Is this the type 'Levity'? +isLevityTy :: Type -> Bool +isLevityTy = isNullaryTyConKeyApp levityTyConKey + +-- | Is this the type 'RuntimeRep'? +isRuntimeRepTy :: Type -> Bool +isRuntimeRepTy = isNullaryTyConKeyApp runtimeRepTyConKey + +-- | Is a tyvar of type 'RuntimeRep'? +isRuntimeRepVar :: TyVar -> Bool +isRuntimeRepVar = isRuntimeRepTy . tyVarKind + +-- | Is a tyvar of type 'Levity'? +isLevityVar :: TyVar -> Bool +isLevityVar = isLevityTy . tyVarKind + +-- | Is this the type 'Multiplicity'? +isMultiplicityTy :: Type -> Bool +isMultiplicityTy = isNullaryTyConKeyApp multiplicityTyConKey + +-- | Is a tyvar of type 'Multiplicity'? +isMultiplicityVar :: TyVar -> Bool +isMultiplicityVar = isMultiplicityTy . tyVarKind + +-------------------------------------------- +-- Splitting RuntimeRep +-------------------------------------------- + +-- | (splitRuntimeRep_maybe rr) takes a Type rr :: RuntimeRep, and +-- returns the (TyCon,[Type]) for the RuntimeRep, if possible, where +-- the TyCon is one of the promoted DataCons of RuntimeRep. +-- Remember: the unique on TyCon that is a a promoted DataCon is the +-- same as the unique on the DataCon +-- See Note [Promoted data constructors] in GHC.Core.TyCon +-- May not be possible if `rr` is a type variable or type +-- family application +splitRuntimeRep_maybe :: RuntimeRepType -> Maybe (TyCon, [Type]) +splitRuntimeRep_maybe rep + | TyConApp rr_tc args <- coreFullView rep + , isPromotedDataCon rr_tc + -- isPromotedDataCon: be careful of type families (F tys) :: RuntimeRep, + = Just (rr_tc, args) + | otherwise + = Nothing + +-- | See 'isBoxedRuntimeRep_maybe'. +isBoxedRuntimeRep :: RuntimeRepType -> Bool +isBoxedRuntimeRep rep = isJust (isBoxedRuntimeRep_maybe rep) + +-- | `isBoxedRuntimeRep_maybe (rep :: RuntimeRep)` returns `Just lev` if `rep` +-- 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 rep + | Just (rr_tc, args) <- splitRuntimeRep_maybe rep + , rr_tc `hasKey` boxedRepDataConKey + , [lev] <- args + = Just lev + | otherwise + = Nothing + +-- | Check whether a type of kind 'RuntimeRep' is lifted, unlifted, or unknown. +-- +-- `isLiftedRuntimeRep rr` returns: +-- +-- * `Just Lifted` if `rr` is `LiftedRep :: RuntimeRep` +-- * `Just Unlifted` if `rr` is definitely unlifted, e.g. `IntRep` +-- * `Nothing` if not known (e.g. it's a type variable or a type family application). +runtimeRepLevity_maybe :: RuntimeRepType -> Maybe Levity +runtimeRepLevity_maybe rep + | Just (rr_tc, args) <- splitRuntimeRep_maybe rep + = -- NB: args might be non-empty e.g. TupleRep [r1, .., rn] + if (rr_tc `hasKey` boxedRepDataConKey) + then case args of + [lev] -> levityType_maybe lev + _ -> pprPanic "runtimeRepLevity_maybe" (ppr rep) + else Just Unlifted + -- Avoid searching all the unlifted RuntimeRep type cons + -- In the RuntimeRep data type, only LiftedRep is lifted + | otherwise + = Nothing + +-------------------------------------------- +-- Splitting Levity +-------------------------------------------- + +-- | `levity_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 + | TyConApp lev_tc args <- coreFullView lev + = if | lev_tc `hasKey` liftedDataConKey -> assert( null args) $ Just Lifted + | lev_tc `hasKey` unliftedDataConKey -> assert( null args) $ Just Unlifted + | otherwise -> Nothing + | otherwise + = Nothing + + +{- ********************************************************************* +* * + mapType +* * +************************************************************************ + +These functions do a map-like operation over types, performing some operation +on all variables and binding sites. Primarily used for zonking. + +Note [Efficiency for ForAllCo case of mapTyCoX] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As noted in Note [Forall coercions] 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. + +The problem is that tcm_tybinder will affect the TyCoVar's kind and +mapCoercion will affect the Coercion, and we hope that the results will be +the same. Even if they are the same (which should generally happen with +correct algorithms), then there is an efficiency issue. In particular, +this problem seems to make what should be a linear algorithm into a potentially +exponential one. But it's only going to be bad in the case where there's +lots of foralls in the kinds of other foralls. Like this: + + forall a : (forall b : (forall c : ...). ...). ... + +This construction seems unlikely. So we'll do the inefficient, easy way +for now. + +Note [Specialising mappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These INLINE pragmas are indispensable. mapTyCo and mapTyCoX are used +to implement zonking, and it's vital that they get specialised to the TcM +monad and the particular mapper in use. + +Even specialising to the monad alone made a 20% allocation difference +in perf/compiler/T5030. + +See Note [Specialising foldType] in "GHC.Core.TyCo.Rep" for more details of this +idiom. +-} + +-- | This describes how a "map" operation over a type/coercion should behave +data TyCoMapper env m + = TyCoMapper + { tcm_tyvar :: env -> TyVar -> m Type + , tcm_covar :: env -> CoVar -> m Coercion + , tcm_hole :: env -> CoercionHole -> m Coercion + -- ^ What to do with coercion holes. + -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep". + + , tcm_tycobinder :: env -> TyCoVar -> ForAllTyFlag -> m (env, TyCoVar) + -- ^ The returned env is used in the extended scope + + , tcm_tycon :: TyCon -> m TyCon + -- ^ This is used only for TcTyCons + -- a) To zonk TcTyCons + -- b) To turn TcTyCons into TyCons. + -- See Note [Type checking recursive type and class declarations] + -- in "GHC.Tc.TyCl" + } + +{-# INLINE mapTyCo #-} -- See Note [Specialising mappers] +mapTyCo :: Monad m => TyCoMapper () m + -> ( 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 + -> ( env -> Type -> m Type + , env -> [Type] -> m [Type] + , env -> Coercion -> m Coercion + , env -> [Coercion] -> m[Coercion]) +mapTyCoX (TyCoMapper { tcm_tyvar = tyvar + , tcm_tycobinder = tycobinder + , tcm_tycon = tycon + , tcm_covar = covar + , 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 + + 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) + = 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) + | isTcTyCon tc + = do { tc' <- tycon tc + ; mkTyConApp tc' <$> go_tys env tys } + + -- Not a TcTyCon + | null tys -- Avoid allocation in this very + = return ty -- common case (E.g. Int, LiftedRep etc) + + | otherwise + = mkTyConApp tc <$> go_tys env tys + + go_ty env (ForAllTy (Bndr tv vis) inner) + = do { (env', tv') <- tycobinder env tv vis + ; 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 + + 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 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) + | isTcTyCon tc + = do { tc' <- tycon tc + ; mkTyConAppCo r tc' <$> go_cos env cos } + + -- Not a TcTyCon + | null cos -- Avoid allocation in this very + = return co -- common case (E.g. Int, LiftedRep etc) + + | otherwise + = mkTyConAppCo r tc <$> go_cos env cos + go_co env (ForAllCo tv kind_co co) + = do { kind_co' <- go_co env kind_co + ; (env', tv') <- tycobinder env tv Inferred + ; co' <- go_co env' co + ; return $ mkForAllCo tv' 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 + + +{- ********************************************************************* +* * + TyVarTy +* * +********************************************************************* -} + +-- | Attempts to obtain the type variable underlying a 'Type', and panics with the +-- given message if this is not a type variable type. See also 'getTyVar_maybe' +getTyVar :: HasDebugCallStack => Type -> TyVar +getTyVar ty = case getTyVar_maybe ty of + Just tv -> tv + Nothing -> pprPanic "getTyVar" (ppr ty) + +-- | Attempts to obtain the type variable underlying a 'Type' +getTyVar_maybe :: Type -> Maybe TyVar +getTyVar_maybe = repGetTyVar_maybe . coreFullView + +-- | Attempts to obtain the type variable underlying a 'Type', without +-- any expansion +repGetTyVar_maybe :: Type -> Maybe TyVar +repGetTyVar_maybe (TyVarTy tv) = Just tv +repGetTyVar_maybe _ = Nothing + +isTyVarTy :: Type -> Bool +isTyVarTy ty = isJust (getTyVar_maybe ty) + +-- | If the type is a tyvar, possibly under a cast, returns it, along +-- with the coercion. Thus, the co is :: kind tv ~N kind ty +getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) +getCastedTyVar_maybe ty = case coreFullView ty of + CastTy (TyVarTy tv) co -> Just (tv, co) + TyVarTy tv -> Just (tv, mkReflCo Nominal (tyVarKind tv)) + _ -> Nothing + + +{- ********************************************************************* +* * + AppTy +* * +********************************************************************* -} + +{- We need to be pretty careful with AppTy to make sure we obey the +invariant that a TyConApp is always visibly so. mkAppTy maintains the +invariant: use it. + +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 +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 + i p = typeRep p + + j = i (Proxy :: Proxy (Eq Int => Int)) +The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, +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. +-} + +-- | Applies a type to another, as in e.g. @k a@ +mkAppTy :: Type -> Type -> Type + -- See Note [Respecting definitional equality], invariant (EQ1). +mkAppTy (CastTy fun_ty co) arg_ty + | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty] + = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co + +mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) +mkAppTy ty1 ty2 = AppTy ty1 ty2 + -- Note that the TyConApp could be an + -- under-saturated type synonym. GHC allows that; e.g. + -- type Foo k = k a -> k a + -- type Id x = x + -- foo :: Foo Id -> Foo Id + -- + -- Here Id is partially applied in the type sig for Foo, + -- but once the type synonyms are expanded all is well + -- + -- Moreover in GHC.Tc.Types.tcInferTyApps we build up a type + -- (T t1 t2 t3) one argument at a type, thus forming + -- (T t1), (T t1 t2), etc + +mkAppTys :: Type -> [Type] -> Type +mkAppTys ty1 [] = ty1 +mkAppTys (CastTy fun_ty co) arg_tys -- much more efficient then nested mkAppTy + -- Why do this? See (EQ1) of + -- Note [Respecting definitional equality] + -- in GHC.Core.TyCo.Rep + = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers + where + (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys + (args_to_cast, leftovers) = splitAtList arg_cos arg_tys + casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos +mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) +mkAppTys ty1 tys2 = foldl' AppTy ty1 tys2 + +------------- +splitAppTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Attempt to take a type application apart, whether it is a +-- function, type constructor, or plain type application. Note +-- that type family applications are NEVER unsaturated by this! +splitAppTy_maybe = splitAppTyNoView_maybe . coreFullView + +splitAppTy :: Type -> (Type, Type) +-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', +-- and panics if this is not possible +splitAppTy ty = splitAppTy_maybe ty `orElse` pprPanic "splitAppTy" (ppr ty) + +------------- +splitAppTyNoView_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) +-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that +-- any coreView stuff is already done +splitAppTyNoView_maybe (AppTy ty1 ty2) + = Just (ty1, ty2) + +splitAppTyNoView_maybe (FunTy af w ty1 ty2) + | Just (tc, tys) <- funTyConAppTy_maybe af w ty1 ty2 + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') + +splitAppTyNoView_maybe (TyConApp tc tys) + | not (tyConMustBeSaturated tc) || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! + +splitAppTyNoView_maybe _other = Nothing + +tcSplitAppTyNoView_maybe :: Type -> Maybe (Type,Type) +-- ^ Just like splitAppTyNoView_maybe, but does not split (c => t) +-- See Note [Decomposing fat arrow c=>t] +tcSplitAppTyNoView_maybe ty + | FunTy { ft_af = af } <- ty + , not (isVisibleFunArg af) -- See Note [Decomposing fat arrow c=>t] + = Nothing + | otherwise + = splitAppTyNoView_maybe ty + +------------- +splitAppTys :: 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. +splitAppTys ty = split ty ty [] + where + split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args + split _ (AppTy ty arg) args = split ty ty (arg:args) + split _ (TyConApp tc tc_args) args + = let -- keep type families saturated + n | tyConMustBeSaturated tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split _ (FunTy af w ty1 ty2) args + | Just (tc,tys) <- funTyConAppTy_maybe af w ty1 ty2 + = assert (null args ) + (TyConApp tc [], tys) + + split orig_ty _ args = (orig_ty, args) + +-- | Like 'splitAppTys', but doesn't look through type synonyms +splitAppTysNoView :: HasDebugCallStack => Type -> (Type, [Type]) +splitAppTysNoView ty = split ty [] + where + split (AppTy ty arg) args = split ty (arg:args) + split (TyConApp tc tc_args) args + = let n | tyConMustBeSaturated tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split (FunTy af w ty1 ty2) args + | Just (tc, tys) <- funTyConAppTy_maybe af w ty1 ty2 + = assert (null args ) + (TyConApp tc [], tys) + + split ty args = (ty, args) + + +{- ********************************************************************* +* * + LitTy +* * +********************************************************************* -} + +mkNumLitTy :: Integer -> Type +mkNumLitTy n = LitTy (NumTyLit n) + +-- | Is this a numeric literal. We also look through type synonyms. +isNumLitTy :: Type -> Maybe Integer +isNumLitTy ty + | LitTy (NumTyLit n) <- coreFullView ty = Just n + | otherwise = Nothing + +mkStrLitTy :: FastString -> Type +mkStrLitTy s = LitTy (StrTyLit s) + +-- | Is this a symbol literal. We also look through type synonyms. +isStrLitTy :: Type -> Maybe FastString +isStrLitTy ty + | LitTy (StrTyLit s) <- coreFullView ty = Just s + | otherwise = Nothing + +mkCharLitTy :: Char -> Type +mkCharLitTy c = LitTy (CharTyLit c) + +-- | Is this a char literal? We also look through type synonyms. +isCharLitTy :: Type -> Maybe Char +isCharLitTy ty + | LitTy (CharTyLit s) <- coreFullView ty = Just s + | otherwise = Nothing + + +-- | Is this a type literal (symbol, numeric, or char)? +isLitTy :: Type -> Maybe TyLit +isLitTy ty + | LitTy l <- coreFullView ty = Just l + | otherwise = Nothing + +-- | 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 + -- There may be more than 2 arguments, if the type error is + -- used as a type constructor (e.g. at kind `Type -> Type`). + + ; guard (tyConName tc == errorMessageTypeErrorFamName) + ; return msg } + +-- | Render a type corresponding to a user type error into a SDoc. +pprUserTypeErrorTy :: Type -> SDoc +pprUserTypeErrorTy ty = + case splitTyConApp_maybe ty of + + -- Text "Something" + Just (tc,[txt]) + | tyConName tc == typeErrorTextDataConName + , Just str <- isStrLitTy txt -> ftext str + + -- ShowType t + Just (tc,[_k,t]) + | tyConName tc == typeErrorShowTypeDataConName -> ppr t + + -- t1 :<>: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorAppendDataConName -> + pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 + + -- t1 :$$: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorVAppendDataConName -> + pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 + + -- An unevaluated type function + _ -> ppr ty + + +{- ********************************************************************* +* * + FunTy +* * +********************************************************************* -} + +{- Note [Representation of function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Functions (e.g. Int -> Char) can be thought of as being applications +of funTyCon (known in Haskell surface syntax as (->)), (note that +`RuntimeRep' quantifiers are left inferred) + + (->) :: forall {r1 :: RuntimeRep} {r2 :: RuntimeRep} + (a :: TYPE r1) (b :: TYPE r2). + a -> b -> Type + +However, for efficiency's sake we represent saturated applications of (->) +with FunTy. For instance, the type, + + (->) r1 r2 a b + +is equivalent to, + + FunTy (Anon a) b + +Note how the RuntimeReps are implied in the FunTy representation. For this +reason we must be careful when reconstructing the TyConApp representation (see, +for instance, splitTyConApp_maybe). + +In the compiler we maintain the invariant that all saturated applications of +(->) are represented with FunTy. + +See #11714. +-} + +----------------------------------------------- +funTyConAppTy_maybe :: FunTyFlag -> Type -> Type -> Type + -> Maybe (TyCon, [Type]) +-- ^ Given the components of a FunTy +-- figure out the corresponding TyConApp. +funTyConAppTy_maybe af mult arg res + | Just arg_rep <- getRuntimeRep_maybe arg + , Just res_rep <- getRuntimeRep_maybe res + , let args | isFUNArg af = [mult, arg_rep, res_rep, arg, res] + | otherwise = [ arg_rep, res_rep, arg, res] + = Just $ (funTyFlagTyCon af, args) + | otherwise + = Nothing + +tyConAppFunTy_maybe :: HasDebugCallStack => TyCon -> [Type] -> Maybe Type +-- ^ Return Just if this TyConApp should be represented as a FunTy +tyConAppFunTy_maybe tc tys + | Just (af, mult, arg, res) <- ty_con_app_fun_maybe manyDataConTy tc tys + = Just (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) + | otherwise = Nothing + +tyConAppFunCo_maybe :: HasDebugCallStack => Role -> TyCon -> [Coercion] + -> 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 + +ty_con_app_fun_maybe :: (HasDebugCallStack, Outputable a) => a -> TyCon -> [a] + -> Maybe (FunTyFlag, a, a, a) +{-# INLINE ty_con_app_fun_maybe #-} +-- Specialise this function for its two call sites +ty_con_app_fun_maybe many_ty_co tc args + | tc_uniq == fUNTyConKey = fUN_case + | tc_uniq == tcArrowTyConKey = non_FUN_case FTF_T_C + | tc_uniq == ctArrowTyConKey = non_FUN_case FTF_C_T + | tc_uniq == ccArrowTyConKey = non_FUN_case FTF_C_C + | otherwise = Nothing + where + tc_uniq = tyConUnique tc + + fUN_case + | (w:_r1:_r2:a1:a2:rest) <- args + = assertPpr (null rest) (ppr tc <+> ppr args) $ + Just (FTF_T_T, w, a1, a2) + | otherwise = Nothing + + non_FUN_case ftf + | (_r1:_r2:a1:a2:rest) <- args + = assertPpr (null rest) (ppr tc <+> ppr args) $ + Just (ftf, many_ty_co, a1, a2) + | otherwise + = Nothing + +mkFunctionType :: HasDebugCallStack => Mult -> Type -> Type -> Type +-- ^ This one works out the FunTyFlag from the argument type +-- See GHC.Types.Var Note [FunTyFlag] +mkFunctionType mult arg_ty res_ty + = FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty + , ft_mult = assertPpr mult_ok (ppr [mult, arg_ty, res_ty]) $ + mult } + where + af = chooseFunTyFlag arg_ty res_ty + mult_ok = isVisibleFunArg af || isManyTy mult + +mkScaledFunctionTys :: [Scaled Type] -> Type -> Type +-- ^ Like mkFunctionType, compute the FunTyFlag from the arguments +mkScaledFunctionTys arg_tys res_ty + = foldr mk res_ty arg_tys + where + mk (Scaled mult arg_ty) res_ty + = mkFunTy (chooseFunTyFlag arg_ty res_ty) + mult arg_ty res_ty + +chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag +-- ^ See GHC.Types.Var Note [FunTyFlag] +chooseFunTyFlag arg_ty res_ty + = mkFunTyFlag (typeTypeOrConstraint arg_ty) (typeTypeOrConstraint res_ty) + +splitFunTy :: Type -> (Mult, Type, Type) +-- ^ Attempts to extract the multiplicity, argument and result types from a type, +-- and panics if that is not possible. See also 'splitFunTy_maybe' +splitFunTy ty = case splitFunTy_maybe ty of + Just (_af, mult, arg, res) -> (mult,arg,res) + Nothing -> pprPanic "splitFunTy" (ppr ty) + +{-# INLINE splitFunTy_maybe #-} +splitFunTy_maybe :: Type -> Maybe (FunTyFlag, Mult, Type, Type) +-- ^ Attempts to extract the multiplicity, argument and result types from a type +splitFunTy_maybe ty + | FunTy af w arg res <- coreFullView ty = Just (af, w, arg, res) + | otherwise = Nothing + +splitFunTys :: Type -> ([Scaled Type], Type) +splitFunTys ty = split [] ty ty + where + -- common case first + split args _ (FunTy _ w arg res) = split (Scaled w arg : args) res res + split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' + split args orig_ty _ = (reverse args, orig_ty) + +funResultTy :: HasDebugCallStack => Type -> Type +-- ^ Extract the function result type and panic if that is not possible +funResultTy ty + | FunTy { ft_res = res } <- coreFullView ty = res + | otherwise = pprPanic "funResultTy" (ppr ty) + +funArgTy :: Type -> Type +-- ^ Extract the function argument type and panic if that is not possible +funArgTy ty + | FunTy { ft_arg = arg } <- coreFullView ty = arg + | otherwise = pprPanic "funArgTy" (ppr ty) + +-- ^ Just like 'piResultTys' but for a single argument +-- Try not to iterate 'piResultTy', because it's inefficient to substitute +-- one variable at a time; instead use 'piResultTys" +piResultTy :: HasDebugCallStack => Type -> Type -> Type +piResultTy ty arg = case piResultTy_maybe ty arg of + Just res -> res + Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) + +piResultTy_maybe :: Type -> Type -> Maybe Type +-- We don't need a 'tc' version, because +-- this function behaves the same for Type and Constraint +piResultTy_maybe ty arg = case coreFullView ty of + FunTy { ft_res = res } -> Just res + + ForAllTy (Bndr tv _) res + -> let empty_subst = mkEmptySubst $ mkInScopeSet $ + tyCoVarsOfTypes [arg,res] + in Just (substTy (extendTCvSubst empty_subst tv arg) res) + + _ -> Nothing + +-- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) +-- where f :: f_ty +-- 'piResultTys' is interesting because: +-- 1. 'f_ty' may have more for-alls than there are args +-- 2. Less obviously, it may have fewer for-alls +-- For case 2. think of: +-- piResultTys (forall a.a) [forall b.b, Int] +-- This really can happen, but only (I think) in situations involving +-- undefined. For example: +-- undefined :: forall a. a +-- Term: undefined @(forall b. b->b) @Int +-- This term should have type (Int -> Int), but notice that +-- there are more type args than foralls in 'undefined's type. + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in GHC.Core.Lint + +-- This is a heavily used function (e.g. from typeKind), +-- so we pay attention to efficiency, especially in the special case +-- where there are no for-alls so we are just dropping arrows from +-- a function type/kind. +piResultTys :: HasDebugCallStack => Type -> [Type] -> Type +piResultTys ty [] = ty +piResultTys ty orig_args@(arg:args) + | FunTy { ft_res = res } <- ty + = piResultTys res args + + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst init_subst tv arg) res args + + | Just ty' <- coreView ty + = piResultTys ty' orig_args + + | otherwise + = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) + where + init_subst = mkEmptySubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) + + go :: Subst -> Type -> [Type] -> Type + go subst ty [] = substTyUnchecked subst ty + + go subst ty all_args@(arg:args) + | FunTy { ft_res = res } <- ty + = go subst res args + + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst subst tv arg) res args + + | Just ty' <- coreView ty + = go subst ty' all_args + + | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] + = go init_subst + (substTy subst ty) + all_args + + | otherwise + = -- We have not run out of arguments, but the function doesn't + -- have the right kind to apply to them; so panic. + -- Without the explicit isEmptyVarEnv test, an ill-kinded type + -- would give an infinite loop, which is very unhelpful + -- c.f. #15473 + pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) + +applyTysX :: [TyVar] -> Type -> [Type] -> Type +-- applyTysX beta-reduces (/\tvs. body_ty) arg_tys +-- Assumes that (/\tvs. body_ty) is closed +applyTysX tvs body_ty arg_tys + = assertPpr (tvs `leLength` arg_tys) pp_stuff $ + assertPpr (tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs) pp_stuff $ + mkAppTys (substTyWith tvs arg_tys_prefix body_ty) + arg_tys_rest + where + pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys] + (arg_tys_prefix, arg_tys_rest) = splitAtList tvs arg_tys + + +{- Note [Care with kind instantiation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + T :: forall k. k +and we are finding the kind of + T (forall b. b -> b) * Int +Then + T (forall b. b->b) :: k[ k :-> forall b. b->b] + :: forall b. b -> b +So + T (forall b. b->b) * :: (b -> b)[ b :-> *] + :: * -> * + +In other words we must instantiate the forall! + +Similarly (#15428) + S :: forall k f. k -> f k +and we are finding the kind of + S * (* ->) Int Bool +We have + S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)] + :: * -> * -> * +So again we must instantiate. + +The same thing happens in GHC.CoreToIface.toIfaceAppArgsX. +-} + + +{- ********************************************************************* +* * + TyConApp +* * +********************************************************************* -} + +-- splitTyConApp "looks through" synonyms, because they don't +-- mean a distinct type, but all other type-constructor applications +-- including functions are returned as Just .. + +-- | Retrieve the tycon heading this type, if there is one. Does /not/ +-- look through synonyms. +tyConAppTyConPicky_maybe :: Type -> Maybe TyCon +tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc +tyConAppTyConPicky_maybe (FunTy { ft_af = af }) = Just (funTyFlagTyCon af) +tyConAppTyConPicky_maybe _ = Nothing + + +-- | The same as @fst . splitTyConApp@ +-- We can short-cut the FunTy case +{-# INLINE tyConAppTyCon_maybe #-} +tyConAppTyCon_maybe :: Type -> Maybe TyCon +tyConAppTyCon_maybe ty = case coreFullView ty of + TyConApp tc _ -> Just tc + FunTy { ft_af = af } -> Just (funTyFlagTyCon af) + _ -> Nothing + +tyConAppTyCon :: HasDebugCallStack => Type -> TyCon +tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) + +-- | The same as @snd . splitTyConApp@ +tyConAppArgs_maybe :: Type -> Maybe [Type] +tyConAppArgs_maybe ty = case splitTyConApp_maybe ty of + Just (_, tys) -> Just tys + Nothing -> Nothing + +tyConAppArgs :: HasCallStack => 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 +-- of a number of arguments to that constructor. Panics if that is not possible. +-- See also 'splitTyConApp_maybe' +splitTyConApp :: Type -> (TyCon, [Type]) +splitTyConApp ty = splitTyConApp_maybe ty `orElse` pprPanic "splitTyConApp" (ppr ty) + +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor +splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +splitTyConApp_maybe ty = splitTyConAppNoView_maybe (coreFullView ty) + +splitTyConAppNoView_maybe :: Type -> Maybe (TyCon, [Type]) +-- Same as splitTyConApp_maybe but without looking through synonyms +splitTyConAppNoView_maybe ty + = case ty of + FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res} + -> funTyConAppTy_maybe af w arg res + TyConApp tc tys -> Just (tc, tys) + _ -> Nothing + +-- | tcSplitTyConApp_maybe splits a type constructor application into +-- its type constructor and applied types. +-- +-- Differs from splitTyConApp_maybe in that it does *not* split types +-- headed with (=>), as that's not a TyCon in the type-checker. +-- +-- Note that this may fail (in funTyConAppTy_maybe) in the case +-- 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 +-- 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]) +-- Defined here to avoid module loops between Unify and TcType. +tcSplitTyConApp_maybe ty + = case coreFullView ty of + FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res} + | isVisibleFunArg af -- Visible args only + -- See Note [Decomposing fat arrow c=>t] + -> funTyConAppTy_maybe af w arg res + TyConApp tc tys -> Just (tc, tys) + _ -> Nothing + +tcSplitTyConApp :: Type -> (TyCon, [Type]) +tcSplitTyConApp ty + = tcSplitTyConApp_maybe ty `orElse` pprPanic "tcSplitTyConApp" (ppr ty) + +--------------------------- +newTyConInstRhs :: TyCon -> [Type] -> Type +-- ^ Unwrap one 'layer' of newtype on a type constructor and its +-- arguments, using an eta-reduced version of the @newtype@ if possible. +-- This requires tys to have at least @newTyConInstArity tycon@ elements. +newTyConInstRhs tycon tys + = assertPpr (tvs `leLength` tys) (ppr tycon $$ ppr tys $$ ppr tvs) $ + applyTysX tvs rhs tys + where + (tvs, rhs) = newTyConEtadRhs tycon + + +{- ********************************************************************* +* * + CastTy +* * +********************************************************************* -} + +splitCastTy_maybe :: Type -> Maybe (Type, Coercion) +splitCastTy_maybe ty + | CastTy ty' co <- coreFullView ty = Just (ty', co) + | otherwise = Nothing + +-- | Make a 'CastTy'. The Coercion must be nominal. Checks the +-- Coercion for reflexivity, dropping it if it's reflexive. +-- See @Note [Respecting definitional equality]@ in "GHC.Core.TyCo.Rep" +mkCastTy :: Type -> Coercion -> Type +mkCastTy orig_ty co | isReflexiveCo co = orig_ty -- (EQ2) from the Note +-- NB: Do the slow check here. This is important to keep the splitXXX +-- functions working properly. Otherwise, we may end up with something +-- like (((->) |> something_reflexive_but_not_obviously_so) biz baz) +-- fails under splitFunTy_maybe. This happened with the cheaper check +-- in test dependent/should_compile/dynamic-paper. +mkCastTy orig_ty co = mk_cast_ty orig_ty co + +-- | Like 'mkCastTy', but avoids checking the coercion for reflexivity, +-- as that can be expensive. +mk_cast_ty :: Type -> Coercion -> Type +mk_cast_ty orig_ty co = go orig_ty + where + go :: Type -> Type + -- See Note [Using coreView in mk_cast_ty] + go ty | Just ty' <- coreView ty = go ty' + + go (CastTy ty co1) + -- (EQ3) from the Note + = mkCastTy ty (co1 `mkTransCo` co) + -- call mkCastTy again for the reflexivity check + + go (ForAllTy (Bndr tv vis) inner_ty) + -- (EQ4) from the Note + -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep. + | isTyVar tv + , let fvs = tyCoVarsOfCo co + = -- have to make sure that pushing the co in doesn't capture the bound var! + if tv `elemVarSet` fvs + then let empty_subst = mkEmptySubst (mkInScopeSet fvs) + (subst, tv') = substVarBndr empty_subst tv + in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mk_cast_ty` co) + else ForAllTy (Bndr tv vis) (inner_ty `mk_cast_ty` co) + + go _ = CastTy orig_ty co -- NB: orig_ty: preserve synonyms if possible + +{- +Note [Using coreView in mk_cast_ty] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariants (EQ3) and (EQ4) of Note [Respecting definitional equality] in +GHC.Core.TyCo.Rep must apply regardless of type synonyms. For instance, +consider this example (#19742): + + type EqSameNat = () |> co + useNatEq :: EqSameNat |> sym co + +(Those casts aren't visible in the user-source code, of course; see #19742 for +what the user might write.) + +The type `EqSameNat |> sym co` looks as if it satisfies (EQ3), as it has no +nested casts, but if we expand EqSameNat, we see that it doesn't. +And then Bad Things happen. + +The solution is easy: just use `coreView` when establishing (EQ3) and (EQ4) in +`mk_cast_ty`. +-} + +{- ********************************************************************* +* * + CoercionTy + CoercionTy allows us to inject coercions into types. A CoercionTy + should appear only in the right-hand side of an application. +* * +********************************************************************* -} + +mkCoercionTy :: Coercion -> Type +mkCoercionTy = CoercionTy + +isCoercionTy :: Type -> Bool +isCoercionTy (CoercionTy _) = True +isCoercionTy _ = False + +isCoercionTy_maybe :: Type -> Maybe Coercion +isCoercionTy_maybe (CoercionTy co) = Just co +isCoercionTy_maybe _ = Nothing + +stripCoercionTy :: Type -> Coercion +stripCoercionTy (CoercionTy co) = co +stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) + + +{- ********************************************************************* +* * + ForAllTy +* * +********************************************************************* -} + +tyConBindersPiTyBinders :: [TyConBinder] -> [PiTyBinder] +-- Return the tyConBinders in PiTyBinder form +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 + +-- | Make a dependent forall over an 'Inferred' variable +mkTyCoInvForAllTy :: TyCoVar -> Type -> Type +mkTyCoInvForAllTy tv ty + | isCoVar tv + , not (tv `elemVarSet` tyCoVarsOfType ty) + = mkVisFunTyMany (varType tv) ty + | otherwise + = ForAllTy (Bndr tv Inferred) ty + +-- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar +mkInfForAllTy :: TyVar -> Type -> Type +mkInfForAllTy tv ty = assert (isTyVar tv ) + ForAllTy (Bndr tv Inferred) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Inferred', a common case +mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type +mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs + +-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar +mkInfForAllTys :: [TyVar] -> Type -> Type +mkInfForAllTys tvs ty = foldr mkInfForAllTy ty tvs + +-- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', +-- a common case +mkSpecForAllTy :: TyVar -> Type -> Type +mkSpecForAllTy tv ty = assert (isTyVar tv ) + -- covar is always Inferred, so input should be tyvar + ForAllTy (Bndr tv Specified) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Specified', a common case +mkSpecForAllTys :: [TyVar] -> Type -> Type +mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs + +-- | Like mkForAllTys, but assumes all variables are dependent and visible +mkVisForAllTys :: [TyVar] -> Type -> Type +mkVisForAllTys tvs = assert (all isTyVar tvs ) + -- covar is always Inferred, so all inputs should be tyvar + mkForAllTys [ Bndr tv Required | tv <- tvs ] + +-- | Given a list of type-level vars and the free vars of a result kind, +-- makes PiTyBinders, preferring anonymous binders +-- if the variable is, in fact, not dependent. +-- e.g. mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k) +-- We want (k:*) Named, (b:k) Anon, (c:k) Anon +-- +-- All non-coercion binders are /visible/. +mkTyConBindersPreferAnon :: [TyVar] -- ^ binders + -> TyCoVarSet -- ^ free variables of result + -> [TyConBinder] +mkTyConBindersPreferAnon vars inner_tkvs = assert (all isTyVar vars) + fst (go vars) + where + go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars + go [] = ([], inner_tkvs) + go (v:vs) | v `elemVarSet` fvs + = ( Bndr v (NamedTCB Required) : binders + , fvs `delVarSet` v `unionVarSet` kind_vars ) + | otherwise + = ( Bndr v (AnonTCB visArgTypeLike) : binders + , fvs `unionVarSet` kind_vars ) + where + (binders, fvs) = go vs + kind_vars = tyCoVarsOfType $ tyVarKind v + +-- | Take a ForAllTy apart, returning the binders and result type +splitForAllForAllTyBinders :: Type -> ([ForAllTyBinder], Type) +splitForAllForAllTyBinders ty = split ty ty [] + where + split _ (ForAllTy b res) bs = split res res (b:bs) + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split orig_ty _ bs = (reverse bs, orig_ty) +{-# INLINE splitForAllForAllTyBinders #-} + +-- | Take a ForAllTy apart, returning the list of tycovars and the result type. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitForAllTyCoVars :: Type -> ([TyCoVar], Type) +splitForAllTyCoVars ty = split ty ty [] + where + split _ (ForAllTy (Bndr tv _) ty) tvs = split ty ty (tv:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like 'splitForAllTyCoVars', but split only for tyvars. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitForAllTyVars :: Type -> ([TyVar], Type) +splitForAllTyVars ty = split ty ty [] + where + split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Required' type +-- variable binders. Furthermore, each returned tyvar is annotated with '()'. +splitForAllReqTyBinders :: Type -> ([ReqTyBinder], Type) +splitForAllReqTyBinders ty = split ty ty [] + where + split _ (ForAllTy (Bndr tv Required) ty) tvs = split ty ty (Bndr tv ():tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Invisible' type +-- variable binders. Furthermore, each returned tyvar is annotated with its +-- 'Specificity'. +splitForAllInvisTyBinders :: Type -> ([InvisTyBinder], Type) +splitForAllInvisTyBinders ty = split ty ty [] + where + split _ (ForAllTy (Bndr tv (Invisible spec)) ty) tvs = split ty ty (Bndr tv spec:tvs) + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Checks whether this is a proper forall (with a named binder) +isForAllTy :: Type -> Bool +isForAllTy ty + | ForAllTy {} <- coreFullView ty = True + | otherwise = False + +-- | Like `isForAllTy`, but returns True only if it is a tyvar binder +isForAllTy_ty :: Type -> Bool +isForAllTy_ty ty + | ForAllTy (Bndr tv _) _ <- 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 + | ForAllTy (Bndr tv _) _ <- coreFullView ty + , isCoVar tv + = True + + | otherwise = False + +-- | Is this a function or forall? +isPiTy :: Type -> Bool +isPiTy ty = case coreFullView ty of + ForAllTy {} -> True + FunTy {} -> True + _ -> False + +-- | Is this a function? +isFunTy :: Type -> Bool +isFunTy ty + | FunTy {} <- coreFullView ty = True + | otherwise = False + +-- | Take a forall type apart, or panics if that is not possible. +splitForAllTyCoVar :: Type -> (TyCoVar, Type) +splitForAllTyCoVar ty + | Just answer <- splitForAllTyCoVar_maybe ty = answer + | otherwise = pprPanic "splitForAllTyCoVar" (ppr ty) + +-- | Drops all ForAllTys +dropForAlls :: Type -> Type +dropForAlls ty = go ty + where + go (ForAllTy _ res) = go res + 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 +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. +splitForAllTyVar_maybe :: Type -> Maybe (TyVar, Type) +splitForAllTyVar_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty + , isTyVar tv + = Just (tv, inner_ty) + + | otherwise = Nothing + +-- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a covar binder. +splitForAllCoVar_maybe :: Type -> Maybe (CoVar, Type) +splitForAllCoVar_maybe ty + | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty + , isCoVar tv + = Just (tv, inner_ty) + + | otherwise = Nothing + +-- | Attempts to take a forall type apart; works with proper foralls and +-- functions +{-# INLINE splitPiTy_maybe #-} -- callers will immediately deconstruct +splitPiTy_maybe :: Type -> Maybe (PiTyBinder, Type) +splitPiTy_maybe ty = case coreFullView ty of + ForAllTy bndr ty -> Just (Named bndr, ty) + FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res} + -> Just (Anon (mkScaled w arg) af, res) + _ -> Nothing + +-- | Takes a forall type apart, or panics +splitPiTy :: Type -> (PiTyBinder, Type) +splitPiTy ty + | Just answer <- splitPiTy_maybe ty = answer + | otherwise = pprPanic "splitPiTy" (ppr ty) + +-- | Split off all PiTyBinders to a type, splitting both proper foralls +-- and functions +splitPiTys :: Type -> ([PiTyBinder], Type) +splitPiTys ty = split ty ty [] + where + split _ (ForAllTy b res) bs = split res res (Named b : bs) + split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) bs + = split res res (Anon (Scaled w arg) af : bs) + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split orig_ty _ bs = (reverse bs, orig_ty) + +-- | Extracts a list of run-time arguments from a function type, +-- looking through newtypes to the right of arrows. +-- +-- Examples: +-- +-- @ +-- newtype Identity a = I a +-- +-- getRuntimeArgTys (Int -> Bool -> Double) == [(Int, FTF_T_T), (Bool, FTF_T_T)] +-- getRuntimeArgTys (Identity Int -> Bool -> Double) == [(Identity Int, FTF_T_T), (Bool, FTF_T_T)] +-- getRuntimeArgTys (Int -> Identity (Bool -> Identity Double)) == [(Int, FTF_T_T), (Bool, FTF_T_T)] +-- getRuntimeArgTys (forall a. Show a => Identity a -> a -> Int -> Bool) +-- == [(Show a, FTF_C_T), (Identity a, FTF_T_T),(a, FTF_T_T),(Int, FTF_T_T)] +-- @ +-- +-- Note that, in the last case, the returned types might mention an out-of-scope +-- type variable. This function is used only when we really care about the /kinds/ +-- of the returned types, so this is OK. +-- +-- **Warning**: this function can return an infinite list. For example: +-- +-- @ +-- newtype N a = MkN (a -> N a) +-- getRuntimeArgTys (N a) == repeat (a, FTF_T_T) +-- @ +getRuntimeArgTys :: Type -> [(Scaled Type, FunTyFlag)] +getRuntimeArgTys = go + where + go :: Type -> [(Scaled Type, FunTyFlag)] + go (ForAllTy _ res) + = go res + go (FunTy { ft_mult = w, ft_arg = arg, ft_res = res, ft_af = af }) + = (Scaled w arg, af) : go res + go ty + | Just ty' <- coreView ty + = go ty' + | Just (_,ty') <- topNormaliseNewType_maybe ty + = go ty' + | otherwise + = [] + +invisibleTyBndrCount :: 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)) + +-- | Like 'splitPiTys', but returns only *invisible* binders, including constraints. +-- Stops at the first visible binder. +splitInvisPiTys :: Type -> ([PiTyBinder], Type) +splitInvisPiTys ty = split ty ty [] + where + split _ (ForAllTy b res) bs + | Bndr _ vis <- b + , isInvisibleForAllTyFlag vis = split res res (Named b : bs) + split _ (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res }) bs + | isInvisibleFunArg af = split res res (Anon (mkScaled mult arg) af : bs) + split orig_ty ty bs + | Just ty' <- coreView ty = split orig_ty ty' bs + split orig_ty _ bs = (reverse bs, orig_ty) + +splitInvisPiTysN :: Int -> Type -> ([PiTyBinder], Type) +-- ^ Same as 'splitInvisPiTys', but stop when +-- - you have found @n@ 'PiTyBinder's, +-- - or you run out of invisible binders +splitInvisPiTysN n ty = split n ty ty [] + where + split n orig_ty ty bs + | n == 0 = (reverse bs, orig_ty) + | Just ty' <- coreView ty = split n orig_ty ty' bs + | ForAllTy b res <- ty + , Bndr _ vis <- b + , isInvisibleForAllTyFlag vis = split (n-1) res res (Named b : bs) + | FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res } <- ty + , isInvisibleFunArg af = split (n-1) res res (Anon (Scaled mult arg) af : bs) + | otherwise = (reverse bs, orig_ty) + +-- | Given a 'TyCon' and a list of argument types, filter out any invisible +-- (i.e., 'Inferred' or 'Specified') arguments. +filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] +filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys + +-- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred' +-- arguments. +filterOutInferredTypes :: TyCon -> [Type] -> [Type] +filterOutInferredTypes tc tys = + filterByList (map (/= Inferred) $ tyConForAllTyFlags tc tys) tys + +-- | Given a 'TyCon' and a list of argument types, partition the arguments +-- into: +-- +-- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and +-- +-- 2. 'Required' (i.e., visible) arguments +partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) +partitionInvisibleTypes tc tys = + partitionByList (map isInvisibleForAllTyFlag $ tyConForAllTyFlags tc tys) tys + +-- | Given a list of things paired with their visibilities, partition the +-- things into (invisible things, visible things). +partitionInvisibles :: [(a, ForAllTyFlag)] -> ([a], [a]) +partitionInvisibles = partitionWith pick_invis + where + pick_invis :: (a, ForAllTyFlag) -> Either a a + pick_invis (thing, vis) | isInvisibleForAllTyFlag vis = Left thing + | otherwise = Right thing + +-- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is +-- applied, determine each argument's visibility +-- ('Inferred', 'Specified', or 'Required'). +-- +-- Wrinkle: consider the following scenario: +-- +-- > T :: forall k. k -> k +-- > tyConForAllTyFlags T [forall m. m -> m -> m, S, R, Q] +-- +-- After substituting, we get +-- +-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n +-- +-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, +-- and @Q@ is visible. +tyConForAllTyFlags :: TyCon -> [Type] -> [ForAllTyFlag] +tyConForAllTyFlags tc = fun_kind_arg_flags (tyConKind tc) + +-- | Given a 'Type' and a list of argument types to which the 'Type' is +-- applied, determine each argument's visibility +-- ('Inferred', 'Specified', or 'Required'). +-- +-- Most of the time, the arguments will be 'Required', but not always. Consider +-- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is +-- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely +-- this sort of higher-rank situation in which 'appTyForAllTyFlags' comes in handy, +-- since @f Type Bool@ would be represented in Core using 'AppTy's. +-- (See also #15792). +appTyForAllTyFlags :: Type -> [Type] -> [ForAllTyFlag] +appTyForAllTyFlags ty = fun_kind_arg_flags (typeKind ty) + +-- | Given a function kind and a list of argument types (where each argument's +-- kind aligns with the corresponding position in the argument kind), determine +-- each argument's visibility ('Inferred', 'Specified', or 'Required'). +fun_kind_arg_flags :: Kind -> [Type] -> [ForAllTyFlag] +fun_kind_arg_flags = go emptySubst + where + go subst ki arg_tys + | Just ki' <- coreView ki = go subst ki' arg_tys + go _ _ [] = [] + go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys) + = argf : go subst' res_ki arg_tys + where + subst' = extendTvSubst subst tv arg_ty + go subst (TyVarTy tv) arg_tys + | Just ki <- lookupTyVar subst tv = go subst ki arg_tys + -- This FunTy case is important to handle kinds with nested foralls, such + -- as this kind (inspired by #16518): + -- + -- forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type + -- + -- Here, we want to get the following ForAllTyFlags: + -- + -- [Inferred, Specified, Required, Required, Specified, Required] + -- forall {k1}. forall k2. k1 -> k2 -> forall k3. k3 -> Type + go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys) + = argf : go subst res_ki arg_tys + where + argf | isVisibleFunArg af = Required + | otherwise = Inferred + go _ _ arg_tys = map (const Required) arg_tys + -- something is ill-kinded. But this can happen + -- when printing errors. Assume everything is Required. + +-- @isTauTy@ tests if a type has no foralls or (=>) +isTauTy :: Type -> Bool +isTauTy ty | Just ty' <- coreView ty = isTauTy ty' +isTauTy (TyVarTy _) = True +isTauTy (LitTy {}) = True +isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (FunTy { ft_af = af, ft_mult = w, ft_arg = a, ft_res = b }) + | isInvisibleFunArg af = False -- e.g., Eq a => b + | otherwise = isTauTy w && isTauTy a && isTauTy b -- e.g., a -> b +isTauTy (ForAllTy {}) = False +isTauTy (CastTy ty _) = isTauTy ty +isTauTy (CoercionTy _) = False -- Not sure about this + +isAtomicTy :: Type -> Bool +-- True if the type is just a single token, and can be printed compactly +-- Used when deciding how to lay out type error messages; see the +-- call in GHC.Tc.Errors +isAtomicTy (TyVarTy {}) = True +isAtomicTy (LitTy {}) = True +isAtomicTy (TyConApp _ []) = True + +isAtomicTy ty | isLiftedTypeKind ty = True + -- 'Type' prints compactly as * + -- See GHC.Iface.Type.ppr_kind_type + +isAtomicTy _ = False + +{- +************************************************************************ +* * +\subsection{Type families} +* * +************************************************************************ +-} + +mkFamilyTyConApp :: TyCon -> [Type] -> Type +-- ^ Given a family instance TyCon and its arg types, return the +-- corresponding family type. E.g: +-- +-- > data family T a +-- > data instance T (Maybe b) = MkT b +-- +-- Where the instance tycon is :RTL, so: +-- +-- > mkFamilyTyConApp :RTL Int = T (Maybe Int) +mkFamilyTyConApp tc tys + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc + , let tvs = tyConTyVars tc + fam_subst = assertPpr (tvs `equalLength` tys) (ppr tc <+> ppr tys) $ + zipTvSubst tvs tys + = mkTyConApp fam_tc (substTys fam_subst fam_tys) + | otherwise + = mkTyConApp tc tys + +-- | Get the type on the LHS of a coercion induced by a type/data +-- family instance. +coAxNthLHS :: CoAxiom br -> Int -> Type +coAxNthLHS ax ind = + mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) + +isFamFreeTy :: Type -> Bool +isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' +isFamFreeTy (TyVarTy _) = True +isFamFreeTy (LitTy {}) = True +isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc +isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b +isFamFreeTy (FunTy _ w a b) = isFamFreeTy w && isFamFreeTy a && isFamFreeTy b +isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty +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 + +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 + where + 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 + +{- +************************************************************************ +* * +\subsection{Liftedness} +* * +************************************************************************ +-} + +-- | Tries to compute the 'Levity' of the given type. Returns either +-- a definite 'Levity', or 'Nothing' if we aren't sure (e.g. the +-- type is representation-polymorphic). +-- +-- Panics if the kind does not have the shape @TYPE r@. +typeLevity_maybe :: HasDebugCallStack => Type -> Maybe Levity +typeLevity_maybe ty = runtimeRepLevity_maybe (getRuntimeRep ty) + +-- | Is the given type definitely unlifted? +-- See "Type#type_classification" for what an unlifted type is. +-- +-- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for +-- a more approximate predicate that behaves better in the presence of +-- representation polymorphism. +isUnliftedType :: HasDebugCallStack => Type -> Bool + -- 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)) + +-- | Returns: +-- +-- * 'False' if the type is /guaranteed/ unlifted or +-- * 'True' if it lifted, OR we aren't sure +-- (e.g. in a representation-polymorphic case) +mightBeLiftedType :: Type -> Bool +mightBeLiftedType = mightBeLifted . typeLevity_maybe + +-- | Returns: +-- +-- * 'False' if the type is /guaranteed/ lifted or +-- * 'True' if it is unlifted, OR we aren't sure +-- (e.g. in a representation-polymorphic case) +mightBeUnliftedType :: Type -> Bool +mightBeUnliftedType = mightBeUnlifted . typeLevity_maybe + +-- | 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 +-- representation polymorphism. +isBoxedType :: Type -> Bool +isBoxedType ty = isBoxedRuntimeRep (getRuntimeRep ty) + +-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) +isRuntimeRepKindedTy :: Type -> Bool +isRuntimeRepKindedTy = isRuntimeRepTy . typeKind + +-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. +-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: +-- +-- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep +-- , String, Int# ] == [String, Int#] +-- +dropRuntimeRepArgs :: [Type] -> [Type] +dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = Just LiftedRep@. Returns 'Nothing' if this is not +-- possible. +getRuntimeRep_maybe :: HasDebugCallStack + => Type -> Maybe RuntimeRepType +getRuntimeRep_maybe = kindRep_maybe . typeKind + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. +getRuntimeRep :: HasDebugCallStack => Type -> RuntimeRepType +getRuntimeRep ty + = case getRuntimeRep_maybe ty of + Just r -> r + Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + +-- | Extract the 'Levity' of a type. For example, @getLevity_maybe Int = Just Lifted@, +-- @getLevity (Array# Int) = Just Unlifted@, @getLevity Float# = Nothing@. +-- +-- Returns 'Nothing' if this is not possible. Does not look through type family applications. +getLevity_maybe :: HasDebugCallStack => Type -> Maybe Type +getLevity_maybe ty + | Just rep <- getRuntimeRep_maybe ty + -- Directly matching on TyConApp after expanding type synonyms + -- saves allocations compared to `splitTyConApp_maybe`. See #22254. + -- Given that this is a pretty hot function we make use of the fact + -- and use isTyConKeyApp_maybe instead. + , Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep + = Just lev + | otherwise + = Nothing + +-- | Extract the 'Levity' of a type. For example, @getLevity Int = Lifted@, +-- or @getLevity (Array# Int) = Unlifted@. +-- +-- Panics if this is not possible. Does not look through type family applications. +getLevity :: HasDebugCallStack => Type -> Type +getLevity ty + | Just lev <- getLevity_maybe ty + = lev + | otherwise + = pprPanic "getLevity" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + +isUnboxedTupleType :: Type -> Bool +isUnboxedTupleType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey + -- NB: Do not use typePrimRep, as that can't tell the difference between + -- unboxed tuples and unboxed sums + + +isUnboxedSumType :: Type -> Bool +isUnboxedSumType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey + +-- | See "Type#type_classification" for what an algebraic type is. +-- Should only be applied to /types/, as opposed to e.g. partially +-- saturated type constructors +isAlgType :: Type -> Bool +isAlgType ty + = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc ) + 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'. +-- Panics on representation-polymorphic types. +isStrictType :: HasDebugCallStack => Type -> Bool +isStrictType = isUnliftedType + +isPrimitiveType :: Type -> Bool +-- ^ Returns true of types that are opaque to Haskell. +isPrimitiveType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc ) + isPrimTyCon tc + _ -> False + +{- +************************************************************************ +* * +\subsection{Join points} +* * +************************************************************************ +-} + +-- | Determine whether a type could be the type of a join point of given total +-- arity, according to the polymorphism rule. A join point cannot be polymorphic +-- in its return type, since given +-- join j @a @b x y z = e1 in e2, +-- the types of e1 and e2 must be the same, and a and b are not in scope for e2. +-- (See Note [The polymorphism rule of join points] in "GHC.Core".) Returns False +-- also if the type simply doesn't have enough arguments. +-- +-- Note that we need to know how many arguments (type *and* value) the putative +-- join point takes; for instance, if +-- j :: forall a. a -> Int +-- then j could be a binary join point returning an Int, but it could *not* be a +-- unary join point returning a -> Int. +-- +-- TODO: See Note [Excess polymorphism and join points] +isValidJoinPointType :: JoinArity -> Type -> Bool +isValidJoinPointType arity ty + = valid_under emptyVarSet arity ty + where + valid_under tvs arity ty + | arity == 0 + = tvs `disjointVarSet` tyCoVarsOfType ty + | Just (t, ty') <- splitForAllTyCoVar_maybe ty + = valid_under (tvs `extendVarSet` t) (arity-1) ty' + | Just (_, _, _, res_ty) <- splitFunTy_maybe ty + = valid_under tvs (arity-1) res_ty + | otherwise + = False + +{- Note [Excess polymorphism and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In principle, if a function would be a join point except that it fails +the polymorphism rule (see Note [The polymorphism rule of join points] in +GHC.Core), it can still be made a join point with some effort. This is because +all tail calls must return the same type (they return to the same context!), and +thus if the return type depends on an argument, that argument must always be the +same. + +For instance, consider: + + let f :: forall a. a -> Char -> [a] + f @a x c = ... f @a y 'a' ... + in ... f @Int 1 'b' ... f @Int 2 'c' ... + +(where the calls are tail calls). `f` fails the polymorphism rule because its +return type is [a], where [a] is bound. But since the type argument is always +'Int', we can rewrite it as: + + let f' :: Int -> Char -> [Int] + f' x c = ... f' y 'a' ... + in ... f' 1 'b' ... f 2 'c' ... + +and now we can make f' a join point: + + join f' :: Int -> Char -> [Int] + f' x c = ... jump f' y 'a' ... + in ... jump f' 1 'b' ... jump f' 2 'c' ... + +It's not clear that this comes up often, however. TODO: Measure how often and +add this analysis if necessary. See #14620. + + +************************************************************************ +* * +\subsection{Sequencing on types} +* * +************************************************************************ +-} + +seqType :: Type -> () +seqType (LitTy n) = n `seq` () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (FunTy _ w t1 t2) = seqType w `seq` seqType t1 `seq` seqType t2 +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty +seqType (CastTy ty co) = seqType ty `seq` seqCo co +seqType (CoercionTy co) = seqCo co + +seqTypes :: [Type] -> () +seqTypes [] = () +seqTypes (ty:tys) = seqType ty `seq` seqTypes tys + +{- +************************************************************************ +* * + The kind of a type +* * +************************************************************************ + +Note [Kinding rules for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here are the key kinding rules for types + + torc1 is TYPE or CONSTRAINT + torc2 is TYPE or CONSTRAINT + t1 : torc1 rep1 + t2 : torc2 rep2 + (FUN) ---------------- + t1 -> t2 : torc2 LiftedRep + -- In fact the arrow varies with torc1/torc2 + -- See Note [Function type constructors and FunTy] + -- in GHC.Builtin.Types.Prim + + torc is TYPE or CONSTRAINT + ty : body_torc rep + bndr_torc is Type or Constraint + ki : bndr_torc + `a` is a type variable + `a` is not free in rep +(FORALL1) ----------------------- + forall (a::ki). ty : torc rep + + torc is TYPE or CONSTRAINT + ty : body_torc rep + `c` is a coercion variable + `c` is not free in rep + `c` is free in ty -- Surprise 1! +(FORALL2) ------------------------- + forall (cv::k1 ~#{N,R} k2). ty : body_torc LiftedRep + -- Surprise 2! + +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] + +* (FORALL2) Surprise 2: coercion abstractions are not erased, so + this must be LiftedRep, just like (FUN). (FORALL2) is just a + dependent form of (FUN). + + +Note [Phantom type variables in kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + type K (r :: RuntimeRep) = Type -- Note 'r' is unused + data T r :: K r -- T :: forall r -> K r + foo :: forall r. T r + +The body of the forall in foo's type has kind (K r), and +normally it would make no sense to have + forall r. (ty :: K r) +because the kind of the forall would escape the binding +of 'r'. But in this case it's fine because (K r) expands +to Type, so we explicitly /permit/ the type + forall r. T r + +To accommodate such a type, in typeKind (forall a.ty) we use +occCheckExpand to expand any type synonyms in the kind of 'ty' +to eliminate 'a'. See kinding rule (FORALL) in +Note [Kinding rules for types] + + +See also + * GHC.Core.Type.occCheckExpand + * GHC.Core.Utils.coreAltsType + * GHC.Tc.Validity.checkEscapingKind +all of which grapple with the same problem. + +See #14939. +-} + +----------------------------- +typeKind :: HasDebugCallStack => Type -> Kind +-- 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 (TyVarTy tyvar) = tyVarKind tyvar +typeKind (CastTy _ty co) = coercionRKind co +typeKind (CoercionTy co) = coercionType co + +typeKind (AppTy fun arg) + = go fun [arg] + where + -- Accumulate the type arguments, so we can call piResultTys, + -- rather than a succession of calls to piResultTy (which is + -- asymptotically costly as the number of arguments increases) + go (AppTy fun arg) args = go fun (arg:args) + 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! + -- See Note [Phantom type variables in kinds] + Nothing -> pprPanic "typeKind" + (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) + + Just k' | all isTyVar tvs -> k' -- Rule (FORALL1) + | otherwise -> lifted_kind_from_body -- Rule (FORALL2) + where + (tvs, body) = splitForAllTyVars ty + 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) + +--------------------------------------------- + +sORTKind_maybe :: Kind -> Maybe (TypeOrConstraint, Type) +-- Sees if the argument is of form (TYPE rep) or (CONSTRAINT rep) +-- and if so returns which, and the runtime rep +-- +-- This is a "hot" function. Do not call splitTyConApp_maybe here, +-- to avoid the faff with FunTy +sORTKind_maybe (TyConApp tc tys) + -- First, short-cuts for Type and Constraint that do no allocation + | tc_uniq == liftedTypeKindTyConKey = assert( null tys ) $ Just (TypeLike, liftedRepTy) + | tc_uniq == constraintKindTyConKey = assert( null tys ) $ Just (ConstraintLike, liftedRepTy) + | tc_uniq == tYPETyConKey = get_rep TypeLike + | tc_uniq == cONSTRAINTTyConKey = get_rep ConstraintLike + | Just ty' <- expandSynTyConApp_maybe tc tys = sORTKind_maybe ty' + where + !tc_uniq = tyConUnique tc + -- This bang on tc_uniq is important. It means that sORTKind_maybe starts + -- by evaluating tc_uniq, and then ends up with a single case with a 4-way branch + + get_rep torc = case tys of + (rep:_reps) -> assert (null _reps) $ Just (torc, rep) + [] -> Nothing + +sORTKind_maybe _ = Nothing + +typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint +-- Precondition: expects a type that classifies values. +-- Returns whether it is TypeLike or ConstraintLike. +-- Equivalent to calling sORTKind_maybe, but faster in the FunTy case +typeTypeOrConstraint ty + = case coreFullView ty of + FunTy { ft_af = af } -> funTyFlagResultTypeOrConstraint af + ty' | Just (torc, _) <- sORTKind_maybe (typeKind ty') + -> torc + | 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 +-- ^ True of a kind `TYPE _` or `CONSTRAINT _` +isTYPEorCONSTRAINT k = isJust (sORTKind_maybe k) + +tyConIsTYPEorCONSTRAINT :: TyCon -> Bool +tyConIsTYPEorCONSTRAINT tc + = tc_uniq == tYPETyConKey || tc_uniq == cONSTRAINTTyConKey + where + !tc_uniq = tyConUnique tc + +isConstraintLikeKind :: Kind -> Bool +-- True of (CONSTRAINT _) +isConstraintLikeKind kind + = case sORTKind_maybe kind of + Just (ConstraintLike, _) -> True + _ -> False + +isConstraintKind :: Kind -> Bool +-- True of (CONSTRAINT LiftedRep) +isConstraintKind kind + = case sORTKind_maybe kind of + Just (ConstraintLike, rep) -> isLiftedRuntimeRep rep + _ -> False + +tcIsLiftedTypeKind :: Kind -> Bool +-- ^ Is this kind equivalent to 'Type' i.e. TYPE LiftedRep? +tcIsLiftedTypeKind kind + | Just (TypeLike, rep) <- sORTKind_maybe kind + = isLiftedRuntimeRep rep + | otherwise + = False + +tcIsBoxedTypeKind :: Kind -> Bool +-- ^ Is this kind equivalent to @TYPE (BoxedRep l)@ for some @l :: Levity@? +tcIsBoxedTypeKind kind + | Just (TypeLike, rep) <- sORTKind_maybe kind + = isBoxedRuntimeRep rep + | otherwise + = False + +-- | Is this kind equivalent to @TYPE r@ (for some unknown r)? +-- +-- This considers 'Constraint' to be distinct from @*@. +isTypeLikeKind :: Kind -> Bool +isTypeLikeKind kind + = case sORTKind_maybe kind of + Just (TypeLike, _) -> True + _ -> False + +returnsConstraintKind :: Kind -> Bool +-- True <=> the Kind ultimately returns a Constraint +-- E.g. * -> Constraint +-- forall k. k -> Constraint +returnsConstraintKind kind + | Just kind' <- coreView kind = returnsConstraintKind kind' +returnsConstraintKind (ForAllTy _ ty) = returnsConstraintKind ty +returnsConstraintKind (FunTy { ft_res = ty }) = returnsConstraintKind ty +returnsConstraintKind kind = isConstraintLikeKind kind + +-------------------------- +typeLiteralKind :: TyLit -> Kind +typeLiteralKind (NumTyLit {}) = naturalTy +typeLiteralKind (StrTyLit {}) = typeSymbolKind +typeLiteralKind (CharTyLit {}) = charTy + +-- | Returns True if a type has a syntactically fixed runtime rep, +-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. +-- +-- This function is equivalent to `isFixedRuntimeRepKind . typeKind` +-- but much faster. +-- +-- __Precondition:__ The type has kind @('TYPE' blah)@ +typeHasFixedRuntimeRep :: HasDebugCallStack => Type -> Bool +typeHasFixedRuntimeRep = go + where + go (TyConApp tc _) + | tcHasFixedRuntimeRep tc = True + go (FunTy {}) = True + go (LitTy {}) = True + 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'. +-- +-- __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 + +-- | 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 + where + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy tv) = isConcreteTyVar tv + go (AppTy ty1 ty2) = go ty1 && go ty2 + go (TyConApp tc tys) + | isConcreteTyCon tc = all go tys + | otherwise = False + go ForAllTy{} = False + go (FunTy _ w t1 t2) = go w + && go (typeKind t1) && go t1 + && go (typeKind t2) && go t2 + go LitTy{} = True + go CastTy{} = False + go CoercionTy{} = False + + +{- +%************************************************************************ +%* * + Pretty-printing +%* * +%************************************************************************ + +Most pretty-printing is either in GHC.Core.TyCo.Rep or GHC.Iface.Type. + +-} + +-- | Does a 'TyCon' (that is applied to some number of arguments) need to be +-- ascribed with an explicit kind signature to resolve ambiguity if rendered as +-- a source-syntax type? +-- (See @Note [When does a tycon application need an explicit kind signature?]@ +-- for a full explanation of what this function checks for.) +tyConAppNeedsKindSig + :: Bool -- ^ Should specified binders count towards injective positions in + -- the kind of the TyCon? (If you're using visible kind + -- applications, then you want True here. + -> TyCon + -> Int -- ^ The number of args the 'TyCon' is applied to. + -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the + -- number of arguments) +tyConAppNeedsKindSig spec_inj_pos tc n_args + | LT <- listLengthCmp tc_binders n_args + = False + | otherwise + = let (dropped_binders, remaining_binders) + = splitAt n_args tc_binders + result_kind = mkTyConKind remaining_binders tc_res_kind + result_vars = tyCoVarsOfType result_kind + dropped_vars = fvVarSet $ + mapUnionFV injective_vars_of_binder dropped_binders + + in not (subVarSet result_vars dropped_vars) + where + tc_binders = tyConBinders tc + tc_res_kind = tyConResKind tc + + -- Returns the variables that would be fixed by knowing a TyConBinder. See + -- Note [When does a tycon application need an explicit kind signature?] + -- for a more detailed explanation of what this function does. + injective_vars_of_binder :: TyConBinder -> FV + injective_vars_of_binder (Bndr tv vis) = + case vis of + AnonTCB af | isVisibleFunArg af + -> injectiveVarsOfType False -- conservative choice + (varType tv) + NamedTCB argf | source_of_injectivity argf + -> unitFV tv `unionFV` + injectiveVarsOfType False (varType tv) + _ -> emptyFV + + source_of_injectivity Required = True + source_of_injectivity Specified = spec_inj_pos + source_of_injectivity Inferred = False + +{- +Note [When does a tycon application need an explicit kind signature?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a couple of places in GHC where we convert Core Types into forms that +more closely resemble user-written syntax. These include: + +1. Template Haskell Type reification (see, for instance, GHC.Tc.Gen.Splice.reify_tc_app) +2. Converting Types to LHsTypes (such as in Haddock.Convert in haddock) + +This conversion presents a challenge: how do we ensure that the resulting type +has enough kind information so as not to be ambiguous? To better motivate this +question, consider the following Core type: + + -- Foo :: Type -> Type + type Foo = Proxy Type + +There is nothing ambiguous about the RHS of Foo in Core. But if we were to, +say, reify it into a TH Type, then it's tempting to just drop the invisible +Type argument and simply return `Proxy`. But now we've lost crucial kind +information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` +or `Proxy Int` or something else! We've inadvertently introduced ambiguity. + +Unlike in other situations in GHC, we can't just turn on +-fprint-explicit-kinds, as we need to produce something which has the same +structure as a source-syntax type. Moreover, we can't rely on visible kind +application, since the first kind argument to Proxy is inferred, not specified. +Our solution is to annotate certain tycons with their kinds whenever they +appear in applied form in order to resolve the ambiguity. For instance, we +would reify the RHS of Foo like so: + + type Foo = (Proxy :: Type -> Type) + +We need to devise an algorithm that determines precisely which tycons need +these explicit kind signatures. We certainly don't want to annotate _every_ +tycon with a kind signature, or else we might end up with horribly bloated +types like the following: + + (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) + +We only want to annotate tycons that absolutely require kind signatures in +order to resolve some sort of ambiguity, and nothing more. + +Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type +require a kind signature? It might require it when we need to fill in any of +T's omitted arguments. By "omitted argument", we mean one that is dropped when +reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and +specified arguments (e.g., TH reification in GHC.Tc.Gen.Splice), and sometimes the +omitted arguments are only the inferred ones (e.g., in situations where +specified arguments are reified through visible kind application). +Regardless, the key idea is that _some_ arguments are going to be omitted after +reification, and the only mechanism we have at our disposal for filling them in +is through explicit kind signatures. + +What do we mean by "fill in"? Let's consider this small example: + + T :: forall {k}. Type -> (k -> Type) -> k + +Moreover, we have this application of T: + + T @{j} Int aty + +When we reify this type, we omit the inferred argument @{j}. Is it fixed by the +other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then +we'll generate an equality constraint (kappa -> Type) and, assuming we can +solve it, that will fix `kappa`. (Here, `kappa` is the unification variable +that we instantiate `k` with.) + +Therefore, for any application of a tycon T to some arguments, the Question We +Must Answer is: + +* Given the first n arguments of T, do the kinds of the non-omitted arguments + fill in the omitted arguments? + +(This is still a bit hand-wavy, but we'll refine this question incrementally +as we explain more of the machinery underlying this process.) + +Answering this question is precisely the role that the `injectiveVarsOfType` +and `injective_vars_of_binder` functions exist to serve. If an omitted argument +`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing +`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a +bit.) + +More formally, if +`a` is in `injectiveVarsOfType ty` +and S1(ty) ~ S2(ty), +then S1(a) ~ S2(a), +where S1 and S2 are arbitrary substitutions. + +For example, is `F` is a non-injective type family, then + + injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} + +Now that we know what this function does, here is a second attempt at the +Question We Must Answer: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. Do the injective + variables of these binders fill in the remainder of T's kind? + +Alright, we're getting closer. Next, we need to clarify what the injective +variables of a tycon binder are. This the role that the +`injective_vars_of_binder` function serves. Here is what this function does for +each form of tycon binder: + +* Anonymous binders are injective positions. For example, in the promoted data + constructor '(:): + + '(:) :: forall a. a -> [a] -> [a] + + The second and third tyvar binders (of kinds `a` and `[a]`) are both + anonymous, so if we had '(:) 'True '[], then the kinds of 'True and + '[] would contribute to the kind of '(:) 'True '[]. Therefore, + injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. + (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) +* Named binders: + - Inferred binders are never injective positions. For example, in this data + type: + + data Proxy a + Proxy :: forall {k}. k -> Type + + If we had Proxy 'True, then the kind of 'True would not contribute to the + kind of Proxy 'True. Therefore, + injective_vars_of_binder(forall {k}. ...) = {}. + - Required binders are injective positions. For example, in this data type: + + data Wurble k (a :: k) :: k + Wurble :: forall k -> k -> k + + The first tyvar binder (of kind `forall k`) has required visibility, so if + we had Wurble (Maybe a) Nothing, then the kind of Maybe a would + contribute to the kind of Wurble (Maybe a) Nothing. Hence, + injective_vars_of_binder(forall a -> ...) = {a}. + - Specified binders /might/ be injective positions, depending on how you + approach things. Continuing the '(:) example: + + '(:) :: forall a. a -> [a] -> [a] + + Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind + of '(:) 'True '[], since it's not explicitly instantiated by the user. But + if visible kind application is enabled, then this is possible, since the + user can write '(:) @Bool 'True '[]. (In that case, + injective_vars_of_binder(forall a. ...) = {a}.) + + There are some situations where using visible kind application is appropriate + and others where it is not (e.g., TH + reification), so the `injective_vars_of_binder` function is parameterized by + a Bool which decides if specified binders should be counted towards + injective positions or not. + +Now that we've defined injective_vars_of_binder, we can refine the Question We +Must Answer once more: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the remainder of T's kind? + +If the answer to this question is "no", then (T ty_1 ... ty_n) needs an +explicit kind signature, since T's kind has kind variables leftover that +aren't fixed by the non-omitted arguments. + +One last sticking point: what does "the remainder of T's kind" mean? You might +be tempted to think that it corresponds to all of the arguments in the kind of +T that would normally be instantiated by omitted arguments. But this isn't +quite right, strictly speaking. Consider the following (silly) example: + + S :: forall {k}. Type -> Type + +And suppose we have this application of S: + + S Int Bool + +The Int argument would be omitted, and +injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which +might suggest that (S Bool) needs an explicit kind signature. But +(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature +only affects the /result/ of the application, not all of the individual +arguments. So adding a kind signature here won't make a difference. Therefore, +the fourth (and final) iteration of the Question We Must Answer is: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the kind of (T ty_1 ... ty_n)? + +Phew, that was a lot of work! + +How can be sure that this is correct? That is, how can we be sure that in the +event that we leave off a kind annotation, that one could infer the kind of the +tycon application from its arguments? It's essentially a proof by induction: if +we can infer the kinds of every subtree of a type, then the whole tycon +application will have an inferrable kind--unless, of course, the remainder of +the tycon application's kind has uninstantiated kind variables. + +What happens if T is oversaturated? That is, if T's kind has fewer than n +arguments, in the case that the concrete application instantiates a result +kind variable with an arrow kind? If we run out of arguments, we do not attach +a kind annotation. This should be a rare case, indeed. Here is an example: + + data T1 :: k1 -> k2 -> * + data T2 :: k1 -> k2 -> * + + type family G (a :: k) :: k + type instance G T1 = T2 + + type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above + +Here G's kind is (forall k. k -> k), and the desugared RHS of that last +instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to +the algorithm above, there are 3 arguments to G so we should peel off 3 +arguments in G's kind. But G's kind has only two arguments. This is the +rare special case, and we choose not to annotate the application of G with +a kind signature. After all, we needn't do this, since that instance would +be reified as: + + type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool + +So the kind of G isn't ambiguous anymore due to the explicit kind annotation +on its argument. See #8953 and test th/T8953. +-} + +{- +************************************************************************ +* * + Multiplicities +* * +************************************************************************ + +These functions would prefer to be in GHC.Core.Multiplicity, but +they some are used elsewhere in this module, and wanted to bring +their friends here with them. +-} + +unrestricted, linear, tymult :: a -> Scaled a + +-- | Scale a payload by Many +unrestricted = Scaled ManyTy + +-- | Scale a payload by One +linear = Scaled OneTy + +-- | Scale a payload by Many; used for type arguments in core +tymult = Scaled ManyTy + +irrelevantMult :: Scaled a -> a +irrelevantMult = scaledThing + +mkScaled :: Mult -> a -> Scaled a +mkScaled = Scaled + +scaledSet :: Scaled a -> b -> Scaled b +scaledSet (Scaled m _) b = Scaled m b + +pattern OneTy :: Mult +pattern OneTy <- (isOneTy -> True) + where OneTy = oneDataConTy + +pattern ManyTy :: Mult +pattern ManyTy <- (isManyTy -> True) + where ManyTy = manyDataConTy + +isManyTy :: Mult -> Bool +isManyTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` manyDataConKey +isManyTy _ = False + +isOneTy :: Mult -> Bool +isOneTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` oneDataConKey +isOneTy _ = False + +isLinearType :: Type -> Bool +-- ^ @isLinear t@ returns @True@ of a if @t@ is a type of (curried) function +-- where at least one argument is linear (or otherwise non-unrestricted). We use +-- this function to check whether it is safe to eta reduce an Id in CorePrep. It +-- is always safe to return 'True', because 'True' deactivates the optimisation. +isLinearType ty = case ty of + FunTy _ ManyTy _ res -> isLinearType res + FunTy _ _ _ _ -> True + ForAllTy _ res -> isLinearType res + _ -> False + +{- ********************************************************************* +* * + Space-saving construction +* * +********************************************************************* -} + +{- Note [Using synonyms to compress types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Was: [Prefer Type over TYPE (BoxedRep Lifted)] + +The Core of nearly any program will have numerous occurrences of the Types + + TyConApp BoxedRep [TyConApp Lifted []] -- Synonym LiftedRep + TyConApp BoxedRep [TyConApp Unlifted []] -- Synonym UnliftedREp + TyConApp TYPE [TyConApp LiftedRep []] -- Synonym Type + TyConApp TYPE [TyConApp UnliftedRep []] -- Synonym UnliftedType + +While investigating #17292 we found that these constituted a majority +of all TyConApp constructors on the heap: + + (From a sample of 100000 TyConApp closures) + 0x45f3523 - 28732 - `Type` + 0x420b840702 - 9629 - generic type constructors + 0x42055b7e46 - 9596 + 0x420559b582 - 9511 + 0x420bb15a1e - 9509 + 0x420b86c6ba - 9501 + 0x42055bac1e - 9496 + 0x45e68fd - 538 - `TYPE ...` + +Consequently, we try hard to ensure that operations on such types are +efficient. Specifically, we strive to + + a. Avoid heap allocation of such types; use a single static TyConApp + b. Use a small (shallow in the tree-depth sense) representation + for such types + +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". + +To accomplish these we use a number of tricks, implemented by mkTyConApp. + + 1. Instead of (TyConApp BoxedRep [TyConApp Lifted []]), + we prefer a statically-allocated (TyConApp LiftedRep []) + where `LiftedRep` is a type synonym: + type LiftedRep = BoxedRep Lifted + Similarly for UnliftedRep + + 2. Instead of (TyConApp TYPE [TyConApp LiftedRep []]) + we prefer the statically-allocated (TyConApp Type []) + where `Type` is a type synonym + type Type = TYPE LiftedRep + Similarly for UnliftedType + +These serve goal (b) since there are no applied type arguments to traverse, +e.g., during comparison. + + 3. We have a single, statically allocated top-level binding to + represent `TyConApp GHC.Types.Type []` (namely + 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we don't + need to allocate such types (goal (a)). See functions + mkTYPEapp and mkBoxedRepApp + + 4. We use the sharing mechanism described in Note [Sharing nullary TyConApps] + in GHC.Core.TyCon to ensure that we never need to allocate such + nullary applications (goal (a)). + +See #17958, #20541 +-} + +-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to +-- its arguments. Applies its arguments to the constructor from left to right. +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon [] + = -- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon + mkTyConTy tycon + +mkTyConApp tycon tys@(ty1:rest) + | Just fun_ty <- tyConAppFunTy_maybe tycon tys + = fun_ty + + -- See Note [Using synonyms to compress types] + | key == tYPETyConKey + , Just ty <- mkTYPEapp_maybe ty1 + = assert (null rest) ty + + | key == cONSTRAINTTyConKey + , Just ty <- mkCONSTRAINTapp_maybe ty1 + = assert (null rest) ty + + -- See Note [Using synonyms to compress types] + | key == boxedRepDataConTyConKey + , Just ty <- mkBoxedRepApp_maybe ty1 + = assert (null rest) ty + + | key == tupleRepDataConTyConKey + , Just ty <- mkTupleRepApp_maybe ty1 + = assert (null rest) ty + + -- The catch-all case + | otherwise + = TyConApp tycon tys + where + key = tyConUnique tycon + + +{- Note [Care using synonyms to compress types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Using a synonym to compress a types has a tricky wrinkle. Consider +coreView applied to (TyConApp LiftedRep []) + +* coreView expands the LiftedRep synonym: + type LiftedRep = BoxedRep Lifted + +* Danger: we might apply the empty substitution to the RHS of the + synonym. And substTy calls mkTyConApp BoxedRep [Lifted]. And + mkTyConApp compresses that back to LiftedRep. Loop! + +* Solution: in expandSynTyConApp_maybe, don't call substTy for nullary + type synonyms. That's more efficient anyway. +-} + + +mkTYPEapp :: RuntimeRepType -> Type +mkTYPEapp rr + = case mkTYPEapp_maybe rr of + Just ty -> ty + Nothing -> TyConApp tYPETyCon [rr] + +mkTYPEapp_maybe :: RuntimeRepType -> Maybe Type +-- ^ Given a @RuntimeRep@, applies @TYPE@ to it. +-- On the fly it rewrites +-- TYPE LiftedRep --> liftedTypeKind (a synonym) +-- TYPE UnliftedRep --> unliftedTypeKind (ditto) +-- TYPE ZeroBitRep --> zeroBitTypeKind (ditto) +-- NB: no need to check for TYPE (BoxedRep Lifted), TYPE (BoxedRep Unlifted) +-- because those inner types should already have been rewritten +-- to LiftedRep and UnliftedRep respectively, by mkTyConApp +-- +-- see Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim. +-- See Note [Using synonyms to compress types] in GHC.Core.Type +{-# NOINLINE mkTYPEapp_maybe #-} +mkTYPEapp_maybe (TyConApp tc args) + | key == liftedRepTyConKey = assert (null args) $ Just liftedTypeKind -- TYPE LiftedRep + | key == unliftedRepTyConKey = assert (null args) $ Just unliftedTypeKind -- TYPE UnliftedRep + | key == zeroBitRepTyConKey = assert (null args) $ Just zeroBitTypeKind -- TYPE ZeroBitRep + where + key = tyConUnique tc +mkTYPEapp_maybe _ = Nothing + +------------------ +mkCONSTRAINTapp :: RuntimeRepType -> Type +-- ^ Just like mkTYPEapp +mkCONSTRAINTapp rr + = case mkCONSTRAINTapp_maybe rr of + Just ty -> ty + Nothing -> TyConApp cONSTRAINTTyCon [rr] + +mkCONSTRAINTapp_maybe :: RuntimeRepType -> Maybe Type +-- ^ Just like mkTYPEapp_maybe +{-# NOINLINE mkCONSTRAINTapp_maybe #-} +mkCONSTRAINTapp_maybe (TyConApp tc args) + | tc `hasKey` liftedRepTyConKey = assert (null args) $ + Just constraintKind -- CONSTRAINT LiftedRep +mkCONSTRAINTapp_maybe _ = Nothing + +------------------ +mkBoxedRepApp_maybe :: LevityType -> Maybe Type +-- ^ Given a `Levity`, apply `BoxedRep` to it +-- On the fly, rewrite +-- BoxedRep Lifted --> liftedRepTy (a synonym) +-- BoxedRep Unlifted --> unliftedRepTy (ditto) +-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim. +-- See Note [Using synonyms to compress types] in GHC.Core.Type +{-# NOINLINE mkBoxedRepApp_maybe #-} +mkBoxedRepApp_maybe (TyConApp tc args) + | key == liftedDataConKey = assert (null args) $ Just liftedRepTy -- BoxedRep Lifted + | key == unliftedDataConKey = assert (null args) $ Just unliftedRepTy -- BoxedRep Unlifted + where + key = tyConUnique tc +mkBoxedRepApp_maybe _ = Nothing + +mkTupleRepApp_maybe :: Type -> Maybe Type +-- ^ Given a `[RuntimeRep]`, apply `TupleRep` to it +-- On the fly, rewrite +-- TupleRep [] -> zeroBitRepTy (a synonym) +-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim. +-- See Note [Using synonyms to compress types] in GHC.Core.Type +{-# NOINLINE mkTupleRepApp_maybe #-} +mkTupleRepApp_maybe (TyConApp tc args) + | key == nilDataConKey = assert (isSingleton args) $ Just zeroBitRepTy -- ZeroBitRep + where + key = tyConUnique tc +mkTupleRepApp_maybe _ = Nothing + +typeOrConstraintKind :: TypeOrConstraint -> RuntimeRepType -> Kind +typeOrConstraintKind TypeLike rep = mkTYPEapp rep +typeOrConstraintKind ConstraintLike rep = mkCONSTRAINTapp rep 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 @@ -6,27 +6,33 @@ import {-# SOURCE #-} GHC.Core.TyCon import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Coercion ) import GHC.Utils.Misc +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 -mkTyConTy :: TyCon -> 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 -tcView :: Type -> Maybe Type isRuntimeRepTy :: Type -> Bool isLevityTy :: Type -> Bool isMultiplicityTy :: Type -> Bool isLiftedTypeKind :: Type -> Bool -mkTYPEapp :: Type -> Type 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 diff --git a/GHC/Core/Unfold.hs b/GHC/Core/Unfold.hs --- a/GHC/Core/Unfold.hs +++ b/GHC/Core/Unfold.hs @@ -47,10 +47,10 @@ import GHC.Types.Literal import GHC.Builtin.PrimOps import GHC.Types.Id.Info -import GHC.Types.Basic ( Arity ) +import GHC.Types.RepType ( isZeroBitTy ) +import GHC.Types.Basic ( Arity, RecFlag(..) ) import GHC.Core.Type import GHC.Builtin.Names -import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Data.Bag import GHC.Utils.Logger import GHC.Utils.Misc @@ -431,7 +431,7 @@ size_up (Type _) = sizeZero -- Types cost nothing size_up (Coercion _) = sizeZero size_up (Lit lit) = sizeN (litSize lit) - size_up (Var f) | isRealWorldId f = sizeZero + size_up (Var f) | isZeroBitId f = sizeZero -- Make sure we get constructor discounts even -- on nullary constructors | otherwise = size_up_call f [] 0 @@ -439,10 +439,10 @@ size_up (App fun arg) | isTyCoArg arg = size_up fun | otherwise = size_up arg `addSizeNSD` - size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0) + size_up_app fun [arg] (if isZeroBitExpr arg then 1 else 0) size_up (Lam b e) - | isId b && not (isRealWorldId b) = lamScrutDiscount opts (size_up e `addSizeN` 10) + | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up e `addSizeN` 10) | otherwise = size_up e size_up (Let (NonRec binder rhs) body) @@ -528,9 +528,9 @@ is_inline_scrut scrut | (Var f, _) <- collectArgs scrut = case idDetails f of - FCallId fc -> not (isSafeForeignCall fc) - PrimOpId op -> not (primOpOutOfLine op) - _other -> False + FCallId fc -> not (isSafeForeignCall fc) + PrimOpId op _ -> not (primOpOutOfLine op) + _other -> False | otherwise = False @@ -546,7 +546,7 @@ -- size_up_app is used when there's ONE OR MORE value args size_up_app (App fun arg) args voids | isTyCoArg arg = size_up_app fun args voids - | isRealWorldExpr arg = size_up_app fun (arg:args) (voids + 1) + | isZeroBitExpr arg = size_up_app fun (arg:args) (voids + 1) | otherwise = size_up arg `addSizeNSD` size_up_app fun (arg:args) voids size_up_app (Var fun) args voids = size_up_call fun args voids @@ -564,7 +564,7 @@ = 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) + PrimOpId op _ -> primOpSize op (length val_args) ClassOpId _ -> classOpSize opts top_args val_args _ -> funSize opts top_args fun (length val_args) voids @@ -580,10 +580,9 @@ ------------ -- Cost to allocate binding with given binder size_up_alloc bndr - | isTyVar bndr -- Doesn't exist at runtime - || isJoinId bndr -- Not allocated at all - || isUnliftedType (idType bndr) -- Doesn't live in heap - -- OK to call isUnliftedType: binders have a fixed RuntimeRep (search for FRRBinder) + | isTyVar bndr -- Doesn't exist at runtime + || isJoinId bndr -- Not allocated at all + || not (isBoxedType (idType bndr)) -- Doesn't live in heap = 0 | otherwise = 10 @@ -611,12 +610,14 @@ (xs `unionBags` ys) d2 -- Ignore d1 - isRealWorldId id = idType id `eqType` realWorldStatePrimTy + -- don't count expressions such as State# RealWorld + -- exclude join points, because they can be rep-polymorphic + -- and typePrimRep will crash + isZeroBitId id = not (isJoinId id) && isZeroBitTy (idType id) - -- an expression of type State# RealWorld must be a variable - isRealWorldExpr (Var id) = isRealWorldId id - isRealWorldExpr (Tick _ e) = isRealWorldExpr e - isRealWorldExpr _ = False + isZeroBitExpr (Var id) = isZeroBitId id + isZeroBitExpr (Tick _ e) = isZeroBitExpr e + isZeroBitExpr _ = False -- | Finds a nominal size of a string literal. litSize :: Literal -> Int @@ -734,7 +735,7 @@ charge 10 for each case alternative (see size_up_alt). If we give a bigger discount (say 20) in conSize, we'll make the case expression cost *nothing*, and that can make a huge case tree cost nothing. This -leads to massive, sometimes exponenial inlinings (#18282). In short, +leads to massive, sometimes exponential inlinings (#18282). In short, don't give a discount that give a negative size to a sub-expression! Historical note 2: Much longer ago, Simon M tried a MUCH bigger @@ -1001,7 +1002,7 @@ data CallCtxt = BoringCtxt - | RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets] + | 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 @@ -1016,7 +1017,7 @@ ppr CaseCtxt = text "CaseCtxt" ppr ValAppCtxt = text "ValAppCtxt" ppr BoringCtxt = text "BoringCtxt" - ppr RhsCtxt = text "RhsCtxt" + ppr (RhsCtxt ir)= text "RhsCtxt" <> parens (ppr ir) ppr DiscArgCtxt = text "DiscArgCtxt" ppr RuleArgCtxt = text "RuleArgCtxt" @@ -1170,7 +1171,7 @@ 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)] + -- 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 @@ -1219,7 +1220,7 @@ , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] ctx = log_default_dump_context (logFlags logger) - str = "Considering inlining: " ++ renderWithContext ctx (ppr id) + str = "Considering inlining: " ++ showSDocOneLine ctx (ppr id) n_val_args = length arg_infos -- some_benefit is used when the RHS is small enough @@ -1249,21 +1250,17 @@ = 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 [Unfold info lazy contexts] + RuleArgCtxt -> uf_arity > 0 -- See Note [RHS of lets] DiscArgCtxt -> uf_arity > 0 -- Note [Inlining in ArgCtxt] - RhsCtxt -> uf_arity > 0 -- + RhsCtxt NonRecursive + -> uf_arity > 0 -- See Note [RHS of lets] _other -> False -- See Note [Nested functions] -{- -Note [Unfold into lazy contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Merged into Note [RHS of lets]. - -Note [RHS of lets] -~~~~~~~~~~~~~~~~~~ +{- 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. For example +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, @@ -1272,8 +1269,12 @@ could be expensive whereas x = case v of (a,b) -> a is patently cheap and may allow more eta expansion. -So we treat the RHS of a let as not-totally-boring. +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 @@ -1313,20 +1314,6 @@ Make sure that x does not inline unconditionally! Lest we get extra allocation. -Note [Inlining an InlineRule] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An InlineRules is used for - (a) programmer INLINE pragmas - (b) inlinings from worker/wrapper - -For (a) the RHS may be large, and our contract is that we *only* inline -when the function is applied to all the arguments on the LHS of the -source-code defn. (The uf_arity in the rule.) - -However for worker/wrapper it may be worth inlining even if the -arity is not satisfied (as we do in the CoreUnfolding case) so we don't -require saturation. - Note [Nested functions] ~~~~~~~~~~~~~~~~~~~~~~~ At one time we treated a call of a non-top-level function as @@ -1367,8 +1354,11 @@ 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 +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 @@ -1405,8 +1395,8 @@ However, watch out: * Consider this: - foo = _inline_ (\n. [n]) - bar = _inline_ (foo 20) + 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 @@ -1414,9 +1404,9 @@ structure rather than a list. So the non-inlining of lone_variables should only apply if the - unfolding is regarded as cheap; because that is when exprIsConApp_maybe - looks through the unfolding. Hence the "&& is_wf" in the - InlineRule branch. + 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 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 @@ -9,13 +9,12 @@ , mkFinalUnfolding' , mkSimpleUnfolding , mkWorkerUnfolding - , mkInlineUnfolding - , mkInlineUnfoldingWithArity + , mkInlineUnfoldingWithArity, mkInlineUnfoldingNoArity , mkInlinableUnfolding , mkWrapperUnfolding - , mkCompulsoryUnfolding - , mkCompulsoryUnfolding' + , mkCompulsoryUnfolding, mkCompulsoryUnfolding' , mkDFunUnfolding + , mkDataConUnfolding , specUnfolding , certainlyWillInline ) @@ -44,10 +43,10 @@ -mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Maybe UnfoldingCache -> Unfolding +mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Unfolding -- "Final" in the sense that this is a GlobalId that will not be further -- simplified; so the unfolding should be occurrence-analysed -mkFinalUnfolding opts src strict_sig expr = mkFinalUnfolding' opts src strict_sig expr +mkFinalUnfolding opts src strict_sig expr = mkFinalUnfolding' opts src strict_sig expr Nothing -- See Note [Tying the 'CoreUnfolding' knot] for why interfaces need -- to pass a precomputed 'UnfoldingCache' @@ -60,15 +59,14 @@ (isDeadEndSig strict_sig) expr --- | Used for things that absolutely must be unfolded -mkCompulsoryUnfolding :: SimpleOpts -> CoreExpr -> Unfolding -mkCompulsoryUnfolding opts expr = mkCompulsoryUnfolding' (simpleOptExpr opts expr) +-- | Same as 'mkCompulsoryUnfolding' but simplifies the unfolding first +mkCompulsoryUnfolding' :: SimpleOpts -> CoreExpr -> Unfolding +mkCompulsoryUnfolding' opts expr = mkCompulsoryUnfolding (simpleOptExpr opts expr) --- | Same as 'mkCompulsoryUnfolding' but no simple optimiser pass is performed --- on the unfolding. -mkCompulsoryUnfolding' :: CoreExpr -> Unfolding -mkCompulsoryUnfolding' expr - = mkCoreUnfolding InlineCompulsory True +-- | Used for things that absolutely must be unfolded +mkCompulsoryUnfolding :: CoreExpr -> Unfolding +mkCompulsoryUnfolding expr + = mkCoreUnfolding CompulsorySrc True expr Nothing (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) @@ -81,7 +79,7 @@ mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding mkSimpleUnfolding !opts rhs - = mkUnfolding opts InlineRhs False False rhs Nothing + = mkUnfolding opts VanillaSrc False False rhs Nothing mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding mkDFunUnfolding bndrs con ops @@ -90,11 +88,21 @@ , df_args = map occurAnalyseExpr ops } -- See Note [Occurrence analysis of unfoldings] +mkDataConUnfolding :: CoreExpr -> Unfolding +-- Used for non-newtype data constructors with non-trivial wrappers +mkDataConUnfolding expr + = mkCoreUnfolding StableSystemSrc True expr Nothing guide + -- No need to simplify the expression + where + guide = UnfWhen { ug_arity = manifestArity expr + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = False } + mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding -- Make the unfolding for the wrapper in a worker/wrapper split -- after demand/CPR analysis mkWrapperUnfolding opts expr arity - = mkCoreUnfolding InlineStable True + = mkCoreUnfolding StableSystemSrc True (simpleOptExpr opts expr) Nothing (UnfWhen { ug_arity = arity , ug_unsat_ok = unSaturatedOk @@ -113,13 +121,13 @@ mkWorkerUnfolding _ _ _ = noUnfolding --- | Make an unfolding that may be used unsaturated +-- | Make an INLINE unfolding that may be used unsaturated -- (ug_unsat_ok = unSaturatedOk) and that is reported as having its -- manifest arity (the number of outer lambdas applications will -- resolve before doing any work). -mkInlineUnfolding :: SimpleOpts -> CoreExpr -> Unfolding -mkInlineUnfolding opts expr - = mkCoreUnfolding InlineStable +mkInlineUnfoldingNoArity :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding +mkInlineUnfoldingNoArity opts src expr + = mkCoreUnfolding src True -- Note [Top-level flag on inline rules] expr' Nothing guide where @@ -129,11 +137,11 @@ , ug_boring_ok = boring_ok } boring_ok = inlineBoringOk expr' --- | Make an unfolding that will be used once the RHS has been saturated +-- | Make an INLINE unfolding that will be used once the RHS has been saturated -- to the given arity. -mkInlineUnfoldingWithArity :: Arity -> SimpleOpts -> CoreExpr -> Unfolding -mkInlineUnfoldingWithArity arity opts expr - = mkCoreUnfolding InlineStable +mkInlineUnfoldingWithArity :: SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding +mkInlineUnfoldingWithArity opts src arity expr + = mkCoreUnfolding src True -- Note [Top-level flag on inline rules] expr' Nothing guide where @@ -146,9 +154,9 @@ boring_ok | arity == 0 = True | otherwise = inlineBoringOk expr' -mkInlinableUnfolding :: SimpleOpts -> CoreExpr -> Unfolding -mkInlinableUnfolding opts expr - = mkUnfolding (so_uf_opts opts) InlineStable False False expr' Nothing +mkInlinableUnfolding :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding +mkInlinableUnfolding opts src expr + = mkUnfolding (so_uf_opts opts) src False False expr' Nothing where expr' = simpleOptExpr opts expr @@ -164,7 +172,7 @@ df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args }) = assertPpr (rule_lhs_args `equalLength` old_bndrs) (ppr df $$ ppr rule_lhs_args) $ - -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise + -- For this ASSERT see Note [Specialising DFuns] in GHC.Core.Opt.Specialise mkDFunUnfolding spec_bndrs con (map spec_arg args) -- For DFunUnfoldings we transform -- \obs. MkD ... @@ -203,25 +211,41 @@ must do so too! Otherwise we lose the magic rules that make it interact with ClassOps -* There is a bit of hack for INLINABLE functions: - f :: Ord a => .... - f = - {- INLINABLE f #-} - Now if we specialise f, should the specialised version still have - an INLINABLE pragma? If it does, we'll capture a specialised copy - of as its unfolding, and that probably won't inline. But - if we don't, the specialised version of might be small - enough to inline at a call site. This happens with Control.Monad.liftM3, - and can cause a lot more allocation as a result (nofib n-body shows this). +* For a /stable/ CoreUnfolding, we specialise the unfolding, no matter + how big, iff it has UnfWhen guidance. This happens for INLINE + functions, and for wrappers. For these, it would be very odd if a + function marked INLINE was specialised (because of some local use), + and then forever after (including importing modules) the specialised + version wasn't INLINEd! After all, the programmer said INLINE. - Moreover, keeping the INLINABLE thing isn't much help, because +* However, for a stable CoreUnfolding with guidance UnfoldIfGoodArgs, + which arises from INLINABLE functions, we drop the unfolding. + See #4874 for persuasive examples. Suppose we have + {-# INLINABLE f #-} + f :: Ord a => [a] -> Int f xs = letrec f' = ...f'... in f' + + Then, when f is specialised and optimised we might get + wgo :: [Int] -> Int# + wgo = ...wgo... + f_spec :: [Int] -> Int + f_spec xs = case wgo xs of { r -> I# r } + + and we clearly want to inline f_spec at call sites. But if we still + have the big, un-optimised of f (albeit specialised) captured in the + stable unfolding for f_spec, we won't get that optimisation. + + This happens with Control.Monad.liftM3, and can cause a lot more + allocation as a result (nofib n-body shows this). + + Moreover, keeping the stable unfolding isn't much help, because the specialised function (probably) isn't overloaded any more. - Conclusion: drop the INLINEALE pragma. In practice what this means is: - if a stable unfolding has UnfoldingGuidance of UnfWhen, - we keep it (so the specialised thing too will always inline) - if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs - (which arises from INLINABLE), we discard it + TL;DR: we simply drop the stable unfolding when specialising. It's not + really a complete solution; ignoring specialisation for now, INLINABLE + functions don't get properly strictness analysed, for example. + Moreover, it means that the specialised function has an INLINEABLE + pragma, but no stable unfolding. But it works well for examples + involving specialisation, which is the dominant use of INLINABLE. Note [Honour INLINE on 0-ary bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -310,6 +334,7 @@ mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr -> Maybe UnfoldingCache -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it mkCoreUnfolding src top_lvl expr precomputed_cache guidance = CoreUnfolding { uf_tmpl = cache `seq` occurAnalyseExpr expr @@ -354,15 +379,13 @@ UnfIfGoodArgs { ug_size = size, ug_args = args } -> do_cunf size args src' tmpl' where - src' = -- Do not change InlineCompulsory! - case src of - InlineCompulsory -> InlineCompulsory - _ -> InlineStable - tmpl' = -- Do not overwrite stable unfoldings! - case src of - InlineRhs -> occurAnalyseExpr rhs' - _ -> uf_tmpl fn_unf + src' | isCompulsorySource src = src -- Do not change InlineCompulsory! + | otherwise = StableSystemSrc + tmpl' | isStableSource src = uf_tmpl fn_unf + | otherwise = occurAnalyseExpr rhs' + -- Do not overwrite stable unfoldings! + DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense -- to do so, and even if it is currently a -- loop breaker, it may not be later @@ -430,12 +453,12 @@ Core expressions retained in unfoldings is one of biggest uses of memory when compiling a program. Therefore we have to be careful about retaining copies of old or redundant -templates (see !6202 for a particularlly bad case). +templates (see !6202 for a particularly bad case). With that in mind we want to maintain the invariant that each unfolding only references a single CoreExpr. One place where we have to be careful is in mkCoreUnfolding. -* The template of the unfolding is the result of performing occurence analysis +* The template of the unfolding is the result of performing occurrence analysis (Note [Occurrence analysis of unfoldings]) * Predicates are applied to the unanalysed expression @@ -456,7 +479,7 @@ 1. Perform the predicates on the analysed expression. 2. Force the predicates to remove retainer to the old expression if we force the template. -Option 1 is bad because occurence analysis is expensive and destroys any sharing of the unfolding +Option 1 is bad because occurrence analysis is expensive and destroys any sharing of the unfolding with the actual program. (Testing this approach showed peak 25G memory usage) Therefore we got for Option 2 which performs a little more work but compensates by diff --git a/GHC/Core/Unify.hs b/GHC/Core/Unify.hs --- a/GHC/Core/Unify.hs +++ b/GHC/Core/Unify.hs @@ -1,6 +1,6 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE ScopedTypeVariables, PatternSynonyms, MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-} {-# LANGUAGE DeriveFunctor #-} @@ -10,21 +10,19 @@ tcMatchTyX, tcMatchTysX, tcMatchTyKisX, tcMatchTyX_BM, ruleMatchTyKiX, - -- * Rough matching - RoughMatchTc(..), roughMatchTcs, roughMatchTcsLookup, instanceCantMatch, - typesCantMatch, isRoughWildcard, - -- 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 + flattenTys, flattenTysX, + ) where import GHC.Prelude @@ -37,20 +35,18 @@ import GHC.Core.Coercion hiding ( getCvSubstEnv ) import GHC.Core.TyCon import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.FVs ( tyCoVarsOfCoList, tyCoFVsOfTypes ) -import GHC.Core.TyCo.Subst ( mkTvSubst ) -import GHC.Core.RoughMap +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, fvVarSet, fvVarList ) +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 {-# SOURCE #-} GHC.Tc.Utils.TcType ( tcEqType ) import GHC.Exts( oneShot ) -import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.FastString @@ -58,8 +54,6 @@ import Control.Monad import qualified Data.Semigroup as S -import GHC.Builtin.Names (constraintKindTyConKey, liftedTypeKindTyConKey) - {- Unification is much tricker than you might think. @@ -134,27 +128,27 @@ -- 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 TCvSubst +tcMatchTy :: Type -> Type -> Maybe Subst tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] -tcMatchTyX_BM :: BindFun -> TCvSubst - -> Type -> Type -> Maybe TCvSubst +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 TCvSubst +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 :: TCvSubst -- ^ Substitution to extend +tcMatchTyX :: Subst -- ^ Substitution to extend -> Type -- ^ Template -> Type -- ^ Target - -> Maybe TCvSubst + -> Maybe Subst tcMatchTyX subst ty1 ty2 = tc_match_tys_x alwaysBindFun False subst [ty1] [ty2] @@ -162,7 +156,7 @@ -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTys :: [Type] -- ^ Template -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot; in principle the template + -> 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 @@ -171,25 +165,25 @@ -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTyKis :: [Type] -- ^ Template -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution + -> 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 :: TCvSubst -- ^ Substitution to extend +tcMatchTysX :: Subst -- ^ Substitution to extend -> [Type] -- ^ Template -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution + -> 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 :: TCvSubst -- ^ Substitution to extend +tcMatchTyKisX :: Subst -- ^ Substitution to extend -> [Type] -- ^ Template -> [Type] -- ^ Target - -> Maybe TCvSubst -- ^ One-shot substitution + -> Maybe Subst -- ^ One-shot substitution tcMatchTyKisX subst tys1 tys2 = tc_match_tys_x alwaysBindFun True subst tys1 tys2 @@ -198,27 +192,27 @@ -> Bool -- ^ match kinds? -> [Type] -> [Type] - -> Maybe TCvSubst + -> Maybe Subst tc_match_tys bind_me match_kis tys1 tys2 - = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) 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? - -> TCvSubst + -> Subst -> [Type] -> [Type] - -> Maybe TCvSubst -tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2 + -> 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 $ TCvSubst in_scope tv_env' cv_env' + -> Just $ Subst in_scope id_env tv_env' cv_env' _ -> Nothing -- | This one is called from the expression matcher, @@ -255,62 +249,6 @@ alwaysBindFun :: BindFun alwaysBindFun _tv _ty = BindMe -{- ********************************************************************* -* * - Rough matching -* * -********************************************************************* -} - -{- Note [Rough matching in class and family instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - instance C (Maybe [Tree a]) Bool -and suppose we are looking up - C Bool Bool - -We can very quickly rule the instance out, because the first -argument is headed by Maybe, whereas in the constraint we are looking -up has first argument headed by Bool. These "headed by" TyCons are -called the "rough match TyCons" of the constraint or instance. -They are used for a quick filter, to check when an instance cannot -possibly match. - -The main motivation is to avoid sucking in whole instance -declarations that are utterly useless. See GHC.Core.InstEnv -Note [ClsInst laziness and the rough-match fields]. - -INVARIANT: a rough-match TyCons `tc` is always a real, generative tycon, -like Maybe or Either, including a newtype or a data family, both of -which are generative. It replies True to `isGenerativeTyCon tc Nominal`. - -But it is never - - A type synonym - E.g. Int and (S Bool) might match - if (S Bool) is a synonym for Int - - - A type family (#19336) - E.g. (Just a) and (F a) might match if (F a) reduces to (Just a) - albeit perhaps only after 'a' is instantiated. --} - -roughMatchTcs :: [Type] -> [RoughMatchTc] -roughMatchTcs tys = map typeToRoughMatchTc tys - -roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc] -roughMatchTcsLookup tys = map typeToRoughMatchLookupTc tys - -instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool --- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot --- possibly be instantiated to actual, nor vice versa; --- False is non-committal -instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as -instanceCantMatch _ _ = False -- Safe - -itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool -itemCantMatch (RM_KnownTc t) (RM_KnownTc a) = t /= a -itemCantMatch _ _ = False - - {- ************************************************************************ * * @@ -352,13 +290,12 @@ -- apart, even after arbitrary type function evaluation and substitution? typesCantMatch :: [(Type,Type)] -> Bool -- See Note [Pruning dead case alternatives] -typesCantMatch prs = any (uncurry cant_match) prs - where - cant_match :: Type -> Type -> Bool - cant_match t1 t2 = case tcUnifyTysFG alwaysBindFun [t1] [t2] of - SurelyApart -> True - _ -> False +typesCantMatch prs = any (uncurry typesAreApart) prs +typesAreApart :: Type -> Type -> Bool +typesAreApart t1 t2 = case tcUnifyTysFG alwaysBindFun [t1] [t2] of + SurelyApart -> True + _ -> False {- ************************************************************************ * * @@ -461,12 +398,12 @@ -- | Simple unification of two types; all type variables are bindable -- Precondition: the kinds are already equal tcUnifyTy :: Type -> Type -- All tyvars are bindable - -> Maybe TCvSubst + -> 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 TCvSubst +tcUnifyTyKi :: Type -> Type -> Maybe Subst tcUnifyTyKi t1 t2 = tcUnifyTyKis alwaysBindFun [t1] [t2] -- | Unify two types, treating type family applications as possibly unifying @@ -475,32 +412,33 @@ tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; -- False <=> do one-way matching. -- See end of sec 5.2 from the paper - -> Type -> Type -> Maybe TCvSubst + -> 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 t1 t2 +tcUnifyTyWithTFs twoWay in_scope t1 t2 = case tc_unify_tys alwaysBindFun twoWay True False rn_env emptyTvSubstEnv emptyCvSubstEnv [t1] [t2] of - Unifiable (subst, _) -> Just $ maybe_fix subst - MaybeApart _reason (subst, _) -> Just $ maybe_fix subst + 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 - in_scope = mkInScopeSet $ tyCoVarsOfTypes [t1, t2] rn_env = mkRnEnv2 in_scope - maybe_fix | twoWay = niFixTCvSubst + maybe_fix | twoWay = niFixSubst in_scope | otherwise = mkTvSubst in_scope -- when matching, don't confuse -- domain with range ----------------- tcUnifyTys :: BindFun -> [Type] -> [Type] - -> Maybe TCvSubst + -> Maybe Subst -- ^ A regular one-shot (idempotent) substitution -- that unifies the erased types. See comments -- for 'tcUnifyTysFG' @@ -515,7 +453,7 @@ -- | Like 'tcUnifyTys' but also unifies the kinds tcUnifyTyKis :: BindFun -> [Type] -> [Type] - -> Maybe TCvSubst + -> Maybe Subst tcUnifyTyKis bind_fn tys1 tys2 = case tcUnifyTyKisFG bind_fn tys1 tys2 of Unifiable result -> Just result @@ -523,7 +461,7 @@ -- 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 TCvSubst +type UnifyResult = UnifyResultM Subst -- | See Note [Unification result] data UnifyResultM a = Unifiable a -- the subst that unifies the types @@ -538,11 +476,14 @@ -- 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 - -- See Note [coreView vs tcView] in GHC.Core.Type +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" @@ -588,13 +529,13 @@ -> [Type] -> [Type] -> UnifyResult tc_unify_tys_fg match_kis bind_fn tys1 tys2 - = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env + = do { (env, _) <- tc_unify_tys bind_fn True False match_kis rn_env emptyTvSubstEnv emptyCvSubstEnv tys1 tys2 - ; return $ niFixTCvSubst env } + ; return $ niFixSubst in_scope env } where - vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 - env = mkRnEnv2 $ mkInScopeSet vars + 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. @@ -727,13 +668,13 @@ shadowing. -} -niFixTCvSubst :: TvSubstEnv -> TCvSubst +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? -niFixTCvSubst tenv - | not_fixpoint = niFixTCvSubst (mapVarEnv (substTy subst) tenv) +niFixSubst in_scope tenv + | not_fixpoint = niFixSubst in_scope (mapVarEnv (substTy subst) tenv) | otherwise = subst where range_fvs :: FV @@ -750,12 +691,11 @@ free_tvs = scopedSort (filterOut in_domain range_tvs) -- See Note [Finding the substitution fixpoint], Step 6 - init_in_scope = mkInScopeSet (fvVarSet range_fvs) subst = foldl' add_free_tv - (mkTvSubst init_in_scope tenv) + (mkTvSubst in_scope tenv) free_tvs - add_free_tv :: TCvSubst -> TyVar -> TCvSubst + add_free_tv :: Subst -> TyVar -> Subst add_free_tv subst tv = extendTvSubst subst tv (mkTyVarTy tv') where @@ -944,10 +884,18 @@ kind of the right-hand type. Note that we do not unify kinds at the leaves (as we did previously). We thus have -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. +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 @@ -1046,59 +994,6 @@ (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 ----------- @@ -1111,6 +1006,8 @@ -> 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 @@ -1119,19 +1016,10 @@ | tc1 == tc2 = return () - -- See Note [coreView vs tcView] in GHC.Core.Type. - | tc1 `hasKey` constraintKindTyConKey - , tc2 `hasKey` liftedTypeKindTyConKey - = maybeApart MARTypeVsConstraint - - | tc2 `hasKey` constraintKindTyConKey - , tc1 `hasKey` liftedTypeKindTyConKey - = maybeApart MARTypeVsConstraint - unify_ty env ty1 ty2 kco -- Now handle the cases we can "look through": synonyms and casts. - | Just ty1' <- tcView ty1 = unify_ty env ty1' ty2 kco - | Just ty2' <- tcView ty2 = unify_ty env ty1 ty2' kco + | 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)] @@ -1147,89 +1035,70 @@ = 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 + | Just (tc1, tys1) <- mb_tc_app1 + , Just (tc2, tys2) <- 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 + = if isInjectiveTyCon tc1 Nominal + then unify_tys env tys1 tys2 + else do { let inj | isTypeFamilyTyCon tc1 + = case tyConInjectivityInfo tc1 of + NotInjective -> repeat False + Injective bs -> bs + | otherwise + = repeat False - ; 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 } + (inj_tys1, noninj_tys1) = partitionByList inj tys1 + (inj_tys2, noninj_tys2) = partitionByList inj tys2 - | Just _ <- isSatTyFamApp mb_tc_app1 -- (C2) A (not-over-saturated) type-family application - = maybeApart MARTypeFamily -- behaves like a type variable; might match + ; 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_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 + | isTyFamApp mb_tc_app1 -- A (not-over-saturated) type-family application + = maybeApart MARTypeFamily -- behaves like a type variable; might match - -- 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) <- tcRepSplitAppTy_maybe ty1 - , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 - -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3) - | otherwise -> surelyApart -- (C4) + | isTyFamApp mb_tc_app2 -- A (not-over-saturated) type-family application + , um_unif env -- behaves like a type variable; might unify + = maybeApart MARTypeFamily - | Just (tc2, _) <- mb_tc_app2 - , isTypeFamilyTyCon tc2 - = if | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 - , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 - -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3) - | otherwise -> surelyApart -- (C4) + -- 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 {} <- sORTKind_maybe ty1 + , Just {} <- sORTKind_maybe ty2 + = maybeApart MARTypeVsConstraint + -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim + -- Note [Type and Constraint are not apart] - -- 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 - } + -- 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 = tcSplitTyConApp_maybe ty1 - mb_tc_app2 = tcSplitTyConApp_maybe ty2 + 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) <- tcRepSplitAppTy_maybe ty2 + | 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) <- tcRepSplitAppTy_maybe ty1 + | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1 = unify_ty_app env ty1a [ty1b] ty2a [ty2b] - -- tcSplitTyConApp won't split a (=>), so we handle this separately. -unify_ty env (FunTy InvisArg _w1 arg1 res1) (FunTy InvisArg _w2 arg2 res2) _kco - -- Look at result representations, but arg representations would be redundant - -- as anything that can appear to the left of => is lifted. - -- And anything that can appear to the left of => is unrestricted, so skip the - -- multiplicities. - | Just res_rep1 <- getRuntimeRep_maybe res1 - , Just res_rep2 <- getRuntimeRep_maybe res2 - = unify_tys env [res_rep1, arg1, res1] [res_rep2, arg2, res2] - unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco @@ -1244,7 +1113,7 @@ CoVarCo cv | not (um_unif env) , not (cv `elemVarEnv` c_subst) - , let (_, co_l, co_r) = decomposeFunCo Nominal kco + , 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 @@ -1261,8 +1130,8 @@ unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM () unify_ty_app env ty1 ty1args ty2 ty2args - | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 - , Just (ty2', ty2a) <- repSplitAppTy_maybe ty2 + | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1 + , Just (ty2', ty2a) <- splitAppTyNoView_maybe ty2 = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args) | otherwise @@ -1276,6 +1145,7 @@ ; 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 @@ -1290,16 +1160,16 @@ -- 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 +isTyFamApp :: Maybe (TyCon, [Type]) -> Bool +-- True if we have a saturated or under-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 +isTyFamApp (Just (tc, tys)) + = not (isGenerativeTyCon tc Nominal) -- Type family-ish && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated - = tapp -isSatTyFamApp _ = Nothing +isTyFamApp Nothing + = False --------------------------------- uVar :: UMEnv @@ -1345,8 +1215,7 @@ -- We know that tv1 isn't refined uUnrefined env tv1' ty2 ty2' kco - -- Use tcView, not coreView. See Note [coreView vs tcView] in GHC.Core.Type. - | Just ty2'' <- tcView ty2' + | Just ty2'' <- coreView ty2' = uUnrefined env tv1' ty2 ty2'' kco -- Unwrap synonyms -- This is essential, in case we have -- type Foo a = a @@ -1520,11 +1389,11 @@ getCvSubstEnv :: UM CvSubstEnv getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) -getSubst :: UMEnv -> UM TCvSubst +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)) } + ; return (mkSubst in_scope tv_env cv_env emptyIdSubstEnv) } extendTvEnv :: TyVar -> Type -> UM () extendTvEnv tv ty = UM $ \state -> @@ -1614,7 +1483,7 @@ = 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 (mkEmptyTCvSubst in_scope) cenv2) } + ; return (LC (mkEmptySubst in_scope) cenv2) } where menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) @@ -1640,8 +1509,6 @@ -- 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 - -- why coreView here, not tcView? Because we're firmly after type-checking. - -- This function is used only during coercion optimisation. -- handle Refl case: | tyCoVarsOfType ty `isNotInDomainOf` subst @@ -1662,7 +1529,7 @@ 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 = mkEmptyTCvSubst (rnInScopeSet (me_env menv)) + = 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 @@ -1700,25 +1567,25 @@ | 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) <- repSplitAppTy_maybe ty1 + | 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 _ w ty1 ty2) co _lkco _rkco - | Just (tc, [co_mult,rrco1,rrco2,co1,co2]) <- splitTyConAppCo_maybe co - , tc == funTyCon - = let rr1 = getRuntimeRep ty1 - rr2 = getRuntimeRep ty2 - Pair lkcos rkcos = traverse (fmap (mkNomReflCo . typeKind) . coercionKind) - [co_mult,rrco1, rrco2,co1,co2] - in -- NB: we include the RuntimeRep arguments in the matching; not doing so caused #21205. - ty_co_match_args menv subst - [w, rr1, rr2, ty1, ty2] - [co_mult, rrco1, rrco2, co1, co2] - lkcos rkcos +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 @@ -1740,9 +1607,9 @@ -- 1. Given: -- cv1 :: (s1 :: k1) ~r (s2 :: k2) -- kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2) --- eta1 = mkNthCo role 2 (downgradeRole r Nominal kind_co2) +-- eta1 = mkSelCo (SelTyCon 2 role) (downgradeRole r Nominal kind_co2) -- :: s1' ~ t1 --- eta2 = mkNthCo role 3 (downgradeRole r Nominal kind_co2) +-- eta2 = mkSelCo (SelTyCon 3 role) (downgradeRole r Nominal kind_co2) -- :: s2' ~ t2 -- Wanted: -- subst1 <- ty_co_match menv subst s1 eta1 kco1 kco2 @@ -1772,7 +1639,6 @@ 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 @@ -1783,16 +1649,13 @@ -> Maybe LiftCoEnv ty_co_match_tc menv subst tc1 tys1 tc2 cos2 = do { guard (tc1 == tc2) - ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos } - where - Pair lkcos rkcos - = traverse (fmap (mkNomReflCo . typeKind) . coercionKind) cos2 + ; 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) <- repSplitAppTy_maybe ty1 + | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1 , Just (co2', co2a) <- splitAppCo_maybe co2 = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args) @@ -1800,34 +1663,32 @@ = 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 - ; let Pair lkcos rkcos = traverse (fmap (mkNomReflCo . typeKind) . coercionKind) co2args - ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos } + ; 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] -> [Coercion] -> [Coercion] +ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion] -> Maybe LiftCoEnv -ty_co_match_args _ subst [] [] _ _ = Just subst -ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos) - = do { subst' <- ty_co_match menv subst ty arg lkco rkco - ; ty_co_match_args menv subst' tys args lkcos rkcos } -ty_co_match_args _ _ _ _ _ _ = Nothing +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 _ w ty1 ty2, r) - | Just rep1 <- getRuntimeRep_maybe ty1 - , Just rep2 <- getRuntimeRep_maybe ty2 - -> Just (TyConAppCo r funTyCon [ multToCo w, mkReflCo r rep1, mkReflCo r rep2 - , mkReflCo r ty1, mkReflCo r 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 (tyConRolesX r tc) tys)) + -> 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! @@ -1952,7 +1813,7 @@ 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 TCvSubst contains its own in-scope set, we don't carry a TCvSubst; + 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. @@ -2124,7 +1985,7 @@ in (env'', ty') where arity = tyConArity fam_tc - tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv + 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 @@ -2150,3 +2011,4 @@ = let uniq = unsafeGetFreshLocalUnique in_scope name = mkSystemVarName uniq (fsLit "flc") in mkCoVar name kind + diff --git a/GHC/Core/UsageEnv.hs b/GHC/Core/UsageEnv.hs --- a/GHC/Core/UsageEnv.hs +++ b/GHC/Core/UsageEnv.hs @@ -46,10 +46,10 @@ addUsage (MUsage x) (MUsage y) = MUsage $ mkMultAdd x y scaleUsage :: Mult -> Usage -> Usage -scaleUsage One Bottom = Bottom -scaleUsage _ Zero = Zero -scaleUsage x Bottom = MUsage x -scaleUsage x (MUsage y) = MUsage $ mkMultMul x y +scaleUsage OneTy Bottom = Bottom +scaleUsage _ Zero = Zero +scaleUsage x Bottom = MUsage x +scaleUsage x (MUsage y) = MUsage $ mkMultMul x y -- For now, we use extra multiplicity Bottom for empty case. data UsageEnv = UsageEnv !(NameEnv Mult) Bool @@ -67,19 +67,19 @@ UsageEnv (plusNameEnv_C mkMultAdd e1 e2) (b1 || b2) scaleUE :: Mult -> UsageEnv -> UsageEnv -scaleUE One ue = ue +scaleUE OneTy ue = ue scaleUE w (UsageEnv e _) = UsageEnv (mapNameEnv (mkMultMul w) e) False supUE :: UsageEnv -> UsageEnv -> UsageEnv supUE (UsageEnv e1 False) (UsageEnv e2 False) = - UsageEnv (plusNameEnv_CD mkMultSup e1 Many e2 Many) False + UsageEnv (plusNameEnv_CD mkMultSup e1 ManyTy e2 ManyTy) False supUE (UsageEnv e1 b1) (UsageEnv e2 b2) = UsageEnv (plusNameEnv_CD2 combineUsage e1 e2) (b1 && b2) where combineUsage (Just x) (Just y) = mkMultSup x y combineUsage Nothing (Just x) | b1 = x - | otherwise = Many + | otherwise = ManyTy combineUsage (Just x) Nothing | b2 = x - | otherwise = Many + | otherwise = ManyTy combineUsage Nothing Nothing = pprPanic "supUE" (ppr e1 <+> ppr e2) -- Note: If you are changing this logic, check 'mkMultSup' in Multiplicity as well. diff --git a/GHC/Core/Utils.hs b/GHC/Core/Utils.hs --- a/GHC/Core/Utils.hs +++ b/GHC/Core/Utils.hs @@ -23,7 +23,7 @@ -- * Properties of expressions exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes, mkFunctionType, - exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd, + exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval, @@ -31,14 +31,10 @@ isCheapApp, isExpandableApp, isSaturatedConApp, exprIsTickedString, exprIsTickedString_maybe, exprIsTopLevelBindable, - altsAreExhaustive, + altsAreExhaustive, etaExpansionTick, -- * Equality - cheapEqExpr, cheapEqExpr', eqExpr, - diffBinds, - - -- * Lambdas and eta reduction - tryEtaReduce, canEtaReduceToArity, + cheapEqExpr, cheapEqExpr', diffBinds, -- * Manipulating data constructors and types exprToType, @@ -50,6 +46,9 @@ stripTicksTop, stripTicksTopE, stripTicksTopT, stripTicksE, stripTicksT, + -- * InScopeSet things which work over CoreBinds + mkInScopeSetBndrs, extendInScopeSetBind, extendInScopeSetBndrs, + -- * StaticPtr collectMakeStaticArgs, @@ -71,22 +70,18 @@ import GHC.Core import GHC.Core.Ppr -import GHC.Core.FVs( exprFreeVars ) import GHC.Core.DataCon import GHC.Core.Type as Type import GHC.Core.FamInstEnv -import GHC.Core.Predicate -import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder ) +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.Core.Map.Expr ( eqCoreExpr ) import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey ) import GHC.Builtin.PrimOps -import GHC.Data.Graph.UnVar import GHC.Types.Var import GHC.Types.SrcLoc import GHC.Types.Var.Env @@ -100,11 +95,11 @@ ) 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.Pair import GHC.Data.OrdList import GHC.Utils.Constants (debugIsOn) @@ -112,7 +107,6 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Misc -import GHC.Utils.Trace import Data.ByteString ( ByteString ) import Data.Function ( on ) @@ -120,7 +114,6 @@ import Data.Ord ( comparing ) import qualified Data.Set as Set import GHC.Types.RepType (isZeroBitTy) -import GHC.Types.Demand (isStrictDmd, isAbsDmd, isDeadEndAppSig) {- ************************************************************************ @@ -142,7 +135,7 @@ , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body) | otherwise = exprType body exprType (Case _ _ ty _) = ty -exprType (Cast _ co) = pSnd (coercionKind co) +exprType (Cast _ co) = coercionRKind co exprType (Tick _ e) = exprType e exprType (Lam binder expr) = mkLamType binder (exprType expr) exprType e@(App _ _) @@ -176,26 +169,15 @@ mkLamType v body_ty | isTyVar v - = mkForAllTy v Inferred body_ty + = mkForAllTy (Bndr v Inferred) body_ty | isCoVar v , v `elemVarSet` tyCoVarsOfType body_ty - = mkForAllTy v Required body_ty + = mkForAllTy (Bndr v Required) body_ty | otherwise = mkFunctionType (varMult v) (varType v) body_ty -mkFunctionType :: Mult -> Type -> Type -> Type --- This one works out the AnonArgFlag from the argument type --- See GHC.Types.Var Note [AnonArgFlag] -mkFunctionType mult arg_ty res_ty - | isPredTy arg_ty -- See GHC.Types.Var Note [AnonArgFlag] - = assert (eqType mult Many) $ - mkInvisFunTy mult arg_ty res_ty - - | otherwise - = mkVisFunTy mult arg_ty res_ty - mkLamTypes vs ty = foldr mkLamType ty vs {- @@ -245,7 +227,7 @@ 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 op_ty (_ : args) | Just (_, _, _, res_ty) <- splitFunTy_maybe op_ty = go res_ty args go _ args = pprPanic "applyTypeToArgs" (panic_msg args) @@ -282,7 +264,7 @@ -- | Wrap the given expression in the coercion safely, dropping -- identity coercions and coalescing nested coercions -mkCast :: CoreExpr -> CoercionR -> CoreExpr +mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr mkCast e co | assertPpr (coercionRole co == Representational) (text "coercion" <+> ppr co <+> text "passed to mkCast" @@ -335,6 +317,11 @@ -- 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 @@ -499,7 +486,7 @@ ************************************************************************ -} -bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr +bindNonRec :: HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr -- ^ @bindNonRec x r b@ produces either: -- -- > let x = r in b @@ -525,8 +512,8 @@ 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_app_invariant" +-- | 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) @@ -708,7 +695,11 @@ -- 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, addDefault trimmed_alts maybe_deflt) + = 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] @@ -739,9 +730,8 @@ 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) -- 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! + , 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 @@ -801,7 +791,7 @@ 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 exapple (Simon Jacobi) +2. combineIdenticalAlts does a better job. For example (Simon Jacobi) data D = C0 | C1 | C2 case e of @@ -826,6 +816,39 @@ `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 @@ -949,7 +972,7 @@ 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 -> [] -- See Note [ + DEFAULT -> [] _ -> [con1] cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 @@ -1075,63 +1098,8 @@ go (Var v) = Just v go _ = Nothing -{- -exprIsDeadEnd is a very cheap and cheerful function; it may return -False for bottoming expressions, but it never costs much to ask. See -also GHC.Core.Opt.Arity.exprBotStrictness_maybe, but that's a bit more -expensive. --} -exprIsDeadEnd :: CoreExpr -> Bool --- See Note [Bottoming expressions] -exprIsDeadEnd e - | isEmptyTy (exprType e) - = True - | otherwise - = go 0 e - where - go n (Var v) = isDeadEndAppSig (idDmdSig v) n - go n (App e a) | isTypeArg a = go n e - | otherwise = go (n+1) e - go n (Tick _ e) = go n e - go n (Cast e _) = go n e - go n (Let _ e) = go n e - go n (Lam v e) | isTyVar v = go n e - go _ (Case _ _ _ alts) = null alts - -- See Note [Empty case alternatives] in GHC.Core - go _ _ = False - -{- Note [Bottoming expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A bottoming expression is guaranteed to diverge, or raise an -exception. We can test for it in two different ways, and exprIsDeadEnd -checks for both of these situations: - -* Visibly-bottom computations. For example - (error Int "Hello") - is visibly bottom. The strictness analyser also finds out if - a function diverges or raises an exception, and puts that info - in its strictness signature. - -* Empty types. If a type is empty, its only inhabitant is bottom. - For example: - data T - f :: T -> Bool - f = \(x:t). case x of Bool {} - Since T has no data constructors, the case alternatives are of course - empty. However note that 'x' is not bound to a visibly-bottom value; - it's the *type* that tells us it's going to diverge. - -A GADT may also be empty even though it has constructors: - data T a where - T1 :: a -> T Bool - T2 :: T Int - ...(case (x::T Char) of {})... -Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), -which is likewise uninhabited. - - -************************************************************************ +{- ********************************************************************* * * exprIsDupable * * @@ -1225,7 +1193,6 @@ 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 @@ -1422,7 +1389,7 @@ DataConWorkId {} -> True -- Actually handled by isWorkFreeApp RecSelId {} -> n_val_args == 1 -- See Note [Record selection] ClassOpId {} -> n_val_args == 1 - PrimOpId op -> primOpIsCheap op + PrimOpId op _ -> primOpIsCheap op _ -> False -- In principle we should worry about primops -- that return a type variable, since the result @@ -1454,9 +1421,8 @@ | Just (bndr, ty) <- splitPiTy_maybe ty = case bndr of - Named {} -> all_pred_args n_val_args ty - Anon InvisArg _ -> all_pred_args (n_val_args-1) ty - Anon VisArg _ -> False + Named {} -> all_pred_args n_val_args ty + Anon _ af -> isInvisibleFunArg af && all_pred_args (n_val_args-1) ty | otherwise = False @@ -1641,7 +1607,7 @@ -- been expressed by its "wrapper", so we don't need -- to take the arguments into account - PrimOpId op + PrimOpId op _ | primOpIsDiv op , [arg1, Lit lit] <- args -> not (isZeroLit lit) && expr_ok fun_ok primop_ok arg1 @@ -1661,7 +1627,7 @@ | otherwise -> primop_ok op -- Check the primop itself - && and (zipWith primop_arg_ok arg_tys args) -- Check the arguments + && and (zipWith arg_ok arg_tys args) -- Check the arguments _ -- Unlifted types -- c.f. the Var case of exprIsHNF @@ -1673,7 +1639,8 @@ -- and we'd need to actually test n_val_args == 0. -- Partial applications - | idArity fun > n_val_args -> True + | 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] @@ -1687,9 +1654,10 @@ n_val_args = valArgCount args (arg_tys, _) = splitPiTys (idType fun) - primop_arg_ok :: TyBinder -> CoreExpr -> Bool - primop_arg_ok (Named _) _ = True -- A type argument - primop_arg_ok (Anon _ ty) arg -- A term argument + -- 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 @@ -1711,6 +1679,15 @@ -- 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. @@ -1730,12 +1707,12 @@ ; False -> e2 } in ...) ... - Does the RHS of v satisfy the let/app invariant? Previously we said + 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/app invariant, because x is + 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 @@ -1839,25 +1816,25 @@ * case x of y { DEFAULT -> ....y.... } Should 'y' (alone) be considered ok-for-speculation? - * case x of y { DEFAULT -> ....f (dataToTag# y)... } + * 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 -> ....f (dataToTag# x)... } + case x of y { DEFAULT -> ....let z = dataToTag# x... } -And now the expression does not obey the let/app invariant! Yikes! -Moreover we really might float (f (dataToTag# x)) outside the case, -and then it really, really doesn't obey the let/app invariant. +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/app invariant to worry about. +it doesn't have the trickiness of the let-can-float invariant to worry about. Note [Discarding unnecessary unsafeEqualityProofs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1908,9 +1885,8 @@ -- -- > C (f x :: Int#) -- --- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't --- happen: see "GHC.Core#let_app_invariant". This invariant states that arguments of --- unboxed type must be ok-for-speculation (or trivial). +-- 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 @@ -1924,7 +1900,7 @@ -- constructors / CONLIKE functions (as determined by the function argument) -- or PAPs. -- -exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool +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 @@ -1965,7 +1941,13 @@ 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) + | 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 @@ -2045,7 +2027,7 @@ -- -- ex_tvs are intended to be used as binders for existential type args -- --- arg_ids are indended to be used as binders for value arguments, +-- 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) @@ -2088,7 +2070,7 @@ (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst (zip3 ex_tvs ex_fss ex_uniqs) - mk_ex_var :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar) + mk_ex_var :: Subst -> (TyCoVar, FastString, Unique) -> (Subst, TyCoVar) mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv new_tv , new_tv) @@ -2156,12 +2138,6 @@ -eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool --- Compares for equality, modulo alpha --- TODO: remove eqExpr once GHC 9.4 is released -eqExpr _ = eqCoreExpr -{-# DEPRECATED eqExpr "Use 'GHC.Core.Map.Expr.eqCoreExpr', 'eqExpr' will be removed in GHC 9.6" #-} - -- 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) @@ -2187,14 +2163,17 @@ diffBinds top env binds1 = go (length binds1) env binds1 where go _ env [] [] = ([], env) - go fuel env binds1 binds2 - -- No binds left to compare? Bail out early. - | null binds1 || null binds2 - = (warn env binds1 binds2, 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 (head binds1) + = 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 @@ -2210,7 +2189,6 @@ binds1 (binds2l ++ binds2r) | otherwise -- No match, so push back (FIXME O(n^2)) = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2 - go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough -- We have tried everything, but couldn't find a good match. So -- now we just return the comparison results when we pair up @@ -2288,7 +2266,6 @@ && occInfo info1 == occInfo info2 && demandInfo info1 == demandInfo info2 && callArityInfo info1 == callArityInfo info2 - && levityInfo info1 == levityInfo info2 = locBind "in unfolding of" bndr1 bndr2 $ diffUnfold env (realUnfoldingInfo info1) (realUnfoldingInfo info2) | otherwise @@ -2322,241 +2299,7 @@ bindLoc | b1 == b2 = ppr b1 | otherwise = ppr b1 <> char '/' <> ppr b2 -{- -************************************************************************ -* * - Eta reduction -* * -************************************************************************ -Note [Eta reduction conditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We try for eta reduction here, but *only* if we get all the way to an -trivial expression. We don't want to remove extra lambdas unless we -are going to avoid allocating this thing altogether. - -There are some particularly delicate points here: - -* We want to eta-reduce if doing so leaves a trivial expression, - *including* a cast. For example - \x. f |> co --> f |> co - (provided co doesn't mention x) - -* Eta reduction is not valid in general: - \x. bot /= bot - This matters, partly for old-fashioned correctness reasons but, - worse, getting it wrong can yield a seg fault. Consider - f = \x.f x - h y = case (case y of { True -> f `seq` True; False -> False }) of - True -> ...; False -> ... - - If we (unsoundly) eta-reduce f to get f=f, the strictness analyser - says f=bottom, and replaces the (f `seq` True) with just - (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it - *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands - the definition again, so that it does not terminate after all. - Result: seg-fault because the boolean case actually gets a function value. - See #1947. - - So it's important to do the right thing. - -* 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. - -* Note [Arity care] - ~~~~~~~~~~~~~~~~~ - We need to be careful if we just look at f's - arity. Currently (Dec07), f's arity is visible in its own RHS (see - Note [Arity robustness] in GHC.Core.Opt.Simplify.Env) so we must *not* trust the - arity when checking that 'f' is a value. Otherwise we will - eta-reduce - f = \x. f x - to - f = f - Which might change a terminating program (think (f `seq` e)) to a - non-terminating one. So we check for being a loop breaker first. - - However for GlobalIds we can look at the arity; and for primops we - must, since they have no unfolding. - -* Regardless of whether 'f' is a value, we always want to - reduce (/\a -> f a) to f - This came up in a RULE: foldr (build (/\a -> g a)) - did not match foldr (build (/\b -> ...something complex...)) - The type checker can insert these eta-expanded versions, - with both type and dictionary lambdas; hence the slightly - ad-hoc isDictId - -* Never *reduce* arity. For example - f = \xy. g x y - Then if h has arity 1 we don't want to eta-reduce because then - f's arity would decrease, and that is bad - -These delicacies are why we don't use exprIsTrivial and exprIsHNF here. -Alas. - -Note [Eta reduction with casted arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - (\(x:t3). f (x |> g)) :: t3 -> t2 - where - f :: t1 -> t2 - g :: t3 ~ t1 -This should be eta-reduced to - - f |> (sym g -> t2) - -So we need to accumulate a coercion, pushing it inward (past -variable arguments only) thus: - f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x - f (x:t) |> co --> (f |> (t -> co)) x - f @ a |> co --> (f |> (forall a.co)) @ a - f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) -These are the equations for ok_arg. - -It's true that we could also hope to eta reduce these: - (\xy. (f x |> g) y) - (\xy. (f x y) |> g) -But the simplifier pushes those casts outwards, so we don't -need to address that here. --} - --- When updating this function, make sure to update --- CorePrep.tryEtaReducePrep as well! -tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> Maybe CoreExpr -tryEtaReduce rec_ids bndrs body - = go (reverse bndrs) body (mkRepReflCo (exprType body)) - where - incoming_arity = count isId bndrs - - go :: [Var] -- Binders, innermost first, types [a3,a2,a1] - -> CoreExpr -- Of type tr - -> Coercion -- Of type tr ~ ts - -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts - -- See Note [Eta reduction with casted arguments] - -- for why we have an accumulating coercion - go [] fun co - | ok_fun fun - , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co - , not (any (`elemVarSet` used_vars) bndrs) - = Just (mkCast fun co) -- Check for any of the binders free in the result - -- including the accumulated coercion - - go bs (Tick t e) co - | tickishFloatable t - = fmap (Tick t) $ go bs e co - -- Float app ticks: \x -> Tick t (e x) ==> Tick t e - - go (b : bs) (App fun arg) co - | Just (co', ticks) <- ok_arg b arg co (exprType fun) - = fmap (flip (foldr mkTick) ticks) $ go bs fun co' - -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e - - go _ _ _ = Nothing -- Failure! - - --------------- - -- Note [Eta reduction conditions] - ok_fun (App fun (Type {})) = ok_fun fun - ok_fun (Cast fun _) = ok_fun fun - ok_fun (Tick _ expr) = ok_fun expr - ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs - ok_fun _fun = False - - --------------- - ok_fun_id fun = - -- Don't eta-reduce in fun in its own recursive RHSs - not (fun `elemUnVarSet` rec_ids) && -- criterion (R) - -- There are arguments to reduce... - fun_arity fun >= incoming_arity && - -- ... and the function can be eta reduced to arity 0 - canEtaReduceToArity fun 0 0 - --------------- - fun_arity fun -- See Note [Arity care] - | arity > 0 = arity - | isEvaldUnfolding (idUnfolding fun) = 1 - -- See Note [Eta reduction of an eval'd function] - | otherwise = 0 - where - arity = idArity fun - - --------------- - ok_lam v = isTyVar v || isEvVar v - - --------------- - ok_arg :: Var -- Of type bndr_t - -> CoreExpr -- Of type arg_t - -> Coercion -- Of kind (t1~t2) - -> Type -- Type of the function to which the argument is applied - -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) - -- (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 (Var v) co fun_ty - | bndr == v - , let mult = idMult bndr - , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty - , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort - = Just (mkFunResCo Representational (idScaledType bndr) co, []) - ok_arg bndr (Cast e co_arg) co fun_ty - | (ticks, Var v) <- stripTicksTop tickishFloatable e - , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty - , bndr == v - , fun_mult `eqType` idMult bndr - = Just (mkFunCo Representational (multToCo fun_mult) (mkSymCo co_arg) co, ticks) - -- The simplifier combines multiple casts into one, - -- so we can have a simple-minded pattern match here - ok_arg bndr (Tick t arg) co fun_ty - | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty - = Just (co', t:ticks) - - ok_arg _ _ _ _ = Nothing - --- | Can we eta-reduce the given function to the specified arity? --- See Note [Eta reduction conditions]. -canEtaReduceToArity :: Id -> JoinArity -> Arity -> Bool -canEtaReduceToArity fun dest_join_arity dest_arity = - not $ - hasNoBinding fun - -- Don't undersaturate functions with no binding. - - || ( isJoinId fun && dest_join_arity < idJoinArity fun ) - -- Don't undersaturate join points. - -- See Note [Invariants on join points] in GHC.Core, and #20599 - - || ( dest_arity < idCbvMarkArity fun ) - -- Don't undersaturate StrictWorkerIds. - -- See Note [CBV Function Ids] in GHC.CoreToStg.Prep. - - || isLinearType (idType fun) - -- 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. - -- See Note [Eta reduction conditions]. - -{- -Note [Eta reduction of an eval'd function] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Haskell it is not true that f = \x. f x -because f might be bottom, and 'seq' can distinguish them. - -But it *is* true that f = f `seq` \x. f x -and we'd like to simplify the latter to the former. This amounts -to the rule that - * when there is just *one* value argument, - * f is not bottom -we can eta-reduce \x. f x ===> f - -This turned up in #7542. --} - {- ********************************************************************* * * \subsection{Determining non-updatable right-hand-sides} @@ -2607,6 +2350,26 @@ , 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 {- ***************************************************** diff --git a/GHC/Core/Utils.hs-boot b/GHC/Core/Utils.hs-boot deleted file mode 100644 --- a/GHC/Core/Utils.hs-boot +++ /dev/null @@ -1,6 +0,0 @@ -module GHC.Core.Utils where - -import GHC.Core.Multiplicity -import GHC.Core.Type - -mkFunctionType :: Mult -> Type -> Type -> Type diff --git a/GHC/CoreToIface.hs b/GHC/CoreToIface.hs --- a/GHC/CoreToIface.hs +++ b/GHC/CoreToIface.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*] -- | Functions for converting Core things to interface file things. @@ -8,8 +7,9 @@ , toIfaceTvBndrs , toIfaceIdBndr , toIfaceBndr + , toIfaceTopBndr , toIfaceForAllBndr - , toIfaceTyCoVarBinders + , toIfaceForAllBndrs , toIfaceTyVar -- * Types , toIfaceType, toIfaceTypeX @@ -36,6 +36,7 @@ , toIfUnfolding , toIfaceTickish , toIfaceBind + , toIfaceTopBind , toIfaceAlt , toIfaceCon , toIfaceApp @@ -62,18 +63,18 @@ import GHC.Core.Multiplicity import GHC.Core.PatSyn import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCo.Tidy ( tidyCo ) import GHC.Builtin.Types.Prim ( eqPrimTyCon, eqReprPrimTyCon ) import GHC.Builtin.Types ( heqTyCon ) -import GHC.Builtin.Names import GHC.Iface.Syntax import GHC.Data.FastString import GHC.Types.Id import GHC.Types.Id.Info -import GHC.Types.Id.Make ( noinlineIdName ) +import GHC.Types.Id.Make ( noinlineIdName, noinlineConstraintIdName ) import GHC.Types.Literal import GHC.Types.Name import GHC.Types.Basic @@ -87,9 +88,8 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Utils.Trace -import Data.Maybe ( catMaybes ) +import Data.Maybe ( isNothing, catMaybes ) {- Note [Avoiding space leaks in toIface*] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -149,12 +149,15 @@ | isId var = IfaceIdBndr (toIfaceIdBndrX fr var) | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var) -toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis -toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis +toIfaceForAllBndrs :: [VarBndr TyCoVar vis] -> [VarBndr IfaceBndr vis] +toIfaceForAllBndrs = map toIfaceForAllBndr -toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis] -toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder +toIfaceForAllBndr :: VarBndr TyCoVar flag -> VarBndr IfaceBndr flag +toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet +toIfaceForAllBndrX :: VarSet -> (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) +toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis + {- ************************************************************************ * * @@ -223,12 +226,6 @@ toIfaceCoVar :: CoVar -> FastString toIfaceCoVar = occNameFS . getOccName -toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) -toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet - -toIfaceForAllBndrX :: VarSet -> (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) -toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis - ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTyCon tc @@ -236,7 +233,7 @@ where tc_name = tyConName tc info = mkIfaceTyConInfo promoted sort - promoted | isPromotedDataCon tc = IsPromoted + promoted | isDataKindsPromotedDataCon tc = IsPromoted | otherwise = NotPromoted tupleSort :: TyCon -> Maybe IfaceTyConSort @@ -296,7 +293,7 @@ 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 (NthCo _r d co) = IfaceNthCo d (go co) + 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) @@ -306,13 +303,13 @@ go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) - go (TyConAppCo r tc cos) - | tc `hasKey` funTyConKey - , [_,_,_,_, _] <- cos = panic "toIfaceCoercion" - | otherwise = - IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) - go (FunCo r w co1 co2) = IfaceFunCo r (go w) (go co1) (go co2) + go co@(TyConAppCo r tc cos) + = assertPpr (isNothing (tyConAppFunCo_maybe r tc cos)) (ppr co) $ + IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) + 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) @@ -344,7 +341,10 @@ -- Is 'blib' visible? It depends on the visibility flag on j, -- so we have to substitute for k. Annoying! toIfaceAppArgsX fr kind ty_args - = go (mkEmptyTCvSubst in_scope) kind ty_args + | null ty_args + = IA_Nil + | otherwise + = go (mkEmptySubst in_scope) kind ty_args where in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) @@ -361,15 +361,14 @@ go env (FunTy { ft_af = af, ft_res = res }) (t:ts) = IA_Arg (toIfaceTypeX fr t) argf (go env res ts) where - argf = case af of - VisArg -> Required - InvisArg -> Inferred - -- It's rare for a kind to have a constraint argument, but - -- it can happen. See Note [AnonTCB InvisArg] in GHC.Core.TyCon. + 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. go env ty ts@(t1:ts1) | not (isEmptyTCvSubst env) - = go (zapTCvSubst env) (substTy env ty) ts + = go (zapSubst env) (substTy env ty) ts -- See Note [Care with kind instantiation] in GHC.Core.Type | otherwise @@ -416,8 +415,8 @@ (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps univ_bndrs = patSynUnivTyVarBinders ps ex_bndrs = patSynExTyVarBinders ps - (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs - (env2, ex_bndrs') = tidyTyCoVarBinders env1 ex_bndrs + (env1, univ_bndrs') = tidyForAllTyBinders emptyTidyEnv univ_bndrs + (env2, ex_bndrs') = tidyForAllTyBinders env1 ex_bndrs to_if_pr (name, _type, needs_dummy) = (name, needs_dummy) {- @@ -432,7 +431,7 @@ toIfaceBang _ HsLazy = IfNoBang toIfaceBang _ (HsUnpack Nothing) = IfUnpack toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co)) -toIfaceBang _ HsStrict = IfStrict +toIfaceBang _ (HsStrict _) = IfStrict toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang @@ -445,6 +444,15 @@ -- 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 +toIfaceTopBndr :: Id -> IfaceTopBndrInfo +toIfaceTopBndr id + = if isExternalName name + then IfGblTopBndr name + else IfLclTopBndr (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 @@ -464,7 +472,7 @@ toIfaceIdInfo :: IdInfo -> IfaceIdInfo toIfaceIdInfo id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo, - inline_hsinfo, unfold_hsinfo, levity_hsinfo] + inline_hsinfo, unfold_hsinfo] -- NB: strictness and arity must appear in the list before unfolding -- See GHC.IfaceToCore.tcUnfolding where @@ -498,10 +506,6 @@ inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing | otherwise = Just (HsInline inline_prag) - ------------ Representation polymorphism ---------- - levity_hsinfo | isNeverRepPolyIdInfo id_info = Just HsLevity - | otherwise = Nothing - toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar toIfaceJoinInfo Nothing = IfaceNotJoinPoint @@ -513,20 +517,11 @@ , uf_cache = cache , uf_guidance = guidance }) = Just $ HsUnfold lb $ - case src of - InlineStable - -> case guidance of - UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } - -> IfInlineRule arity unsat_ok boring_ok if_rhs - _other -> IfCoreUnfold True cache if_rhs - InlineCompulsory -> IfCompulsory if_rhs - InlineRhs -> IfCoreUnfold False cache if_rhs + IfCoreUnfold src cache (toIfGuidance src guidance) (toIfaceExpr rhs) -- Yes, even if guidance is UnfNever, expose the unfolding -- If we didn't want to expose the unfolding, GHC.Iface.Tidy would -- have stuck in NoUnfolding. For supercompilation we want -- to see that unfolding! - where - if_rhs = toIfaceExpr rhs toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args))) @@ -543,6 +538,12 @@ toIfUnfolding _ NoUnfolding = Nothing +toIfGuidance :: UnfoldingSource -> UnfoldingGuidance -> IfGuidance +toIfGuidance src guidance + | UnfWhen arity unsat_ok boring_ok <- guidance + , isStableSource src = IfWhen arity unsat_ok boring_ok + | otherwise = IfNoGuidance + {- ************************************************************************ * * @@ -553,7 +554,7 @@ toIfaceExpr :: CoreExpr -> IfaceExpr toIfaceExpr (Var v) = toIfaceVar v -toIfaceExpr (Lit (LitRubbish r)) = IfaceLitRubbish (toIfaceType r) +toIfaceExpr (Lit (LitRubbish tc r)) = IfaceLitRubbish tc (toIfaceType r) toIfaceExpr (Lit l) = IfaceLit l toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co) @@ -585,10 +586,37 @@ -- should not be serialised (#8333) --------------------- -toIfaceBind :: Bind Id -> IfaceBinding +toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] +toIfaceTopBind :: Bind Id -> IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo +toIfaceTopBind b = + case b of + NonRec b r -> uncurry IfaceNonRec (do_one (b, r)) + Rec prs -> IfaceRec (map do_one prs) + where + do_one (b, rhs) = + let top_bndr = toIfaceTopBndr b + rhs' = case top_bndr of + -- Use the existing unfolding for a global binder if we store that anyway. + -- See Note [Interface File with Core: Sharing RHSs] + IfGblTopBndr {} -> if already_has_unfolding b then IfUseUnfoldingRhs else IfRhs (toIfaceExpr rhs) + -- Local binders will have had unfoldings trimmed so have + -- to serialise the whole RHS. + IfLclTopBndr {} -> IfRhs (toIfaceExpr rhs) + in (top_bndr, rhs') + + -- The sharing behaviour is currently disabled due to #22807, and relies on + -- finished #220056 to be re-enabled. + disabledDueTo22807 = True + + already_has_unfolding b = not disabledDueTo22807 + && -- The identifier has an unfolding, which we are going to serialise anyway + hasCoreUnfolding (realIdUnfolding b) + -- But not a stable unfolding, we want the optimised unfoldings. + && not (isStableUnfolding (realIdUnfolding b)) + --------------------- toIfaceAlt :: CoreAlt -> IfaceAlt toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map getOccFS bs) (toIfaceExpr r) @@ -628,8 +656,8 @@ toIfaceVar v | isBootUnfolding (idUnfolding v) = -- See Note [Inlining and hs-boot files] - IfaceApp (IfaceApp (IfaceExt noinlineIdName) - (IfaceType (toIfaceType (idType v)))) + IfaceApp (IfaceApp (IfaceExt noinline_id) + (IfaceType (toIfaceType ty))) (IfaceExt name) -- don't use mkIfaceApps, or infinite loop | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) @@ -637,9 +665,14 @@ | isExternalName name = IfaceExt name | otherwise = IfaceLcl (getOccFS name) - where name = idName v + where + name = idName v + ty = idType v + noinline_id | isConstraintKind (typeKind ty) = noinlineConstraintIdName + | otherwise = noinlineIdName + --------------------- toIfaceLFInfo :: Name -> LambdaFormInfo -> IfaceLFInfo toIfaceLFInfo nm lfi = case lfi of @@ -726,7 +759,8 @@ 1. When we serialize out unfoldings to IfaceExprs (toIfaceVar), for every variable reference we see if we are referring to an 'Id' that came from an hs-boot file. If so, we add a `noinline` - to the reference. + to the reference. See Note [noinlineId magic] + in GHC.Types.Id.Make 2. But how do we know if a reference came from an hs-boot file or not? We could record this directly in the 'IdInfo', but @@ -742,5 +776,35 @@ slower by 8% overall (on #9872a-d, and T1969: the reason is that these NOINLINE'd functions now can't be profitably inlined outside of the hs-boot loop. + +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. + +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 +*any* unfolding. + +* Only global things have unfoldings, because local things have had their unfoldings stripped. +* For any global thing which has an unstable unfolding, we just use that. + +In order to implement this sharing: + +* 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. + +There are two main reasons why the mi_extra_decls field exists rather than shoe-horning +all the core bindings + +1. mi_extra_decls retains the recursive group structure of the original program which + is very convenient as otherwise we would have to do the analysis again when loading + the program. +2. There are additional local top-level bindings which don't make it into mi_decls. It's + best to keep these separate from mi_decls as mi_decls is used to compute the ABI hash. -} diff --git a/GHC/CoreToIface.hs-boot b/GHC/CoreToIface.hs-boot --- a/GHC/CoreToIface.hs-boot +++ b/GHC/CoreToIface.hs-boot @@ -11,7 +11,7 @@ -- For GHC.Core.TyCo.Rep toIfaceTypeX :: VarSet -> Type -> IfaceType toIfaceTyLit :: TyLit -> IfaceTyLit -toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) +toIfaceForAllBndrs :: [VarBndr TyCoVar flag] -> [VarBndr IfaceBndr flag] toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion diff --git a/GHC/CoreToStg.hs b/GHC/CoreToStg.hs --- a/GHC/CoreToStg.hs +++ b/GHC/CoreToStg.hs @@ -14,13 +14,10 @@ -- And, as we have the info in hand, we may convert some lets to -- let-no-escapes. -module GHC.CoreToStg ( coreToStg ) where +module GHC.CoreToStg ( CoreToStgOpts (..), coreToStg ) where import GHC.Prelude -import GHC.Driver.Session -import GHC.Driver.Config.Stg.Debug - import GHC.Core import GHC.Core.Utils ( exprType, findDefault, isJoinBind , exprIsTickedString_maybe ) @@ -41,7 +38,7 @@ import GHC.Types.Tickish import GHC.Types.Var.Env import GHC.Types.Name ( isExternalName, nameModule_maybe ) -import GHC.Types.Basic ( Arity ) +import GHC.Types.Basic ( Arity, TypeOrConstraint(..) ) import GHC.Types.Literal import GHC.Types.ForeignCall import GHC.Types.IPE @@ -49,21 +46,19 @@ import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) import GHC.Unit.Module -import GHC.Builtin.Types ( unboxedUnitDataCon ) import GHC.Data.FastString +import GHC.Platform ( Platform ) import GHC.Platform.Ways -import GHC.Builtin.PrimOps ( PrimCall(..) ) +import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId ) import GHC.Utils.Outputable import GHC.Utils.Monad import GHC.Utils.Misc (HasDebugCallStack) import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Trace import Control.Monad (ap) import Data.Maybe (fromMaybe) -import Data.Tuple (swap) -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~ @@ -236,24 +231,29 @@ -- -------------------------------------------------------------- -coreToStg :: DynFlags -> Module -> ModLocation -> CoreProgram +coreToStg :: CoreToStgOpts -> Module -> ModLocation -> CoreProgram -> ([StgTopBinding], InfoTableProvMap, CollectedCCs) -coreToStg dflags this_mod ml pgm +coreToStg opts@CoreToStgOpts + { coreToStg_ways = ways + , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs + , coreToStg_InfoTableMap = opt_InfoTableMap + , coreToStg_stgDebugOpts = stgDebugOpts + } this_mod ml pgm = (pgm'', denv, final_ccs) where (_, (local_ccs, local_cc_stacks), pgm') - = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm + = coreTopBindsToStg opts this_mod emptyVarEnv emptyCollectedCCs pgm -- See Note [Mapping Info Tables to Source Positions] - (!pgm'', !denv) = - if gopt Opt_InfoTableMap dflags - then collectDebugInformation (initStgDebugOpts dflags) ml pgm' - else (pgm', emptyInfoTableProvMap) + (!pgm'', !denv) + | opt_InfoTableMap + = collectDebugInformation stgDebugOpts ml pgm' + | otherwise = (pgm', emptyInfoTableProvMap) - prof = ways dflags `hasWay` WayProf + prof = hasWay ways WayProf final_ccs - | prof && gopt Opt_AutoSccsOnIndividualCafs dflags + | prof && opt_AutoSccsOnIndividualCafs = (local_ccs,local_cc_stacks) -- don't need "all CAFs" CC | prof = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks) @@ -263,7 +263,7 @@ (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod coreTopBindsToStg - :: DynFlags + :: CoreToStgOpts -> Module -> IdEnv HowBound -- environment for the bindings -> CollectedCCs @@ -272,17 +272,17 @@ coreTopBindsToStg _ _ env ccs [] = (env, ccs, []) -coreTopBindsToStg dflags this_mod env ccs (b:bs) +coreTopBindsToStg opts this_mod env ccs (b:bs) | NonRec _ rhs <- b, isTyCoArg rhs - = coreTopBindsToStg dflags this_mod env1 ccs1 bs + = coreTopBindsToStg opts this_mod env1 ccs1 bs | otherwise = (env2, ccs2, b':bs') where - (env1, ccs1, b' ) = coreTopBindToStg dflags this_mod env ccs b - (env2, ccs2, bs') = coreTopBindsToStg dflags this_mod env1 ccs1 bs + (env1, ccs1, b' ) = coreTopBindToStg opts this_mod env ccs b + (env2, ccs2, bs') = coreTopBindsToStg opts this_mod env1 ccs1 bs coreTopBindToStg - :: DynFlags + :: CoreToStgOpts -> Module -> IdEnv HowBound -> CollectedCCs @@ -298,16 +298,18 @@ how_bound = LetBound TopLet 0 in (env', ccs, StgTopStringLit id str) -coreTopBindToStg dflags this_mod env ccs (NonRec id rhs) +coreTopBindToStg opts@CoreToStgOpts + { coreToStg_platform = platform + } this_mod env ccs (NonRec id rhs) = let env' = extendVarEnv env id how_bound how_bound = LetBound TopLet $! manifestArity rhs - (stg_rhs, ccs') = - initCts dflags env $ - coreToTopStgRhs dflags ccs this_mod (id,rhs) + (ccs', (id', stg_rhs)) = + initCts platform env $ + coreToTopStgRhs opts this_mod ccs (id,rhs) - bind = StgTopLifted $ StgNonRec id stg_rhs + bind = StgTopLifted $ StgNonRec id' stg_rhs in -- NB: previously the assertion printed 'rhs' and 'bind' -- as well as 'id', but that led to a black hole @@ -315,42 +317,38 @@ -- assertion again! (env', ccs', bind) -coreTopBindToStg dflags this_mod env ccs (Rec pairs) +coreTopBindToStg opts@CoreToStgOpts + { coreToStg_platform = platform + } this_mod env ccs (Rec pairs) = assert (not (null pairs)) $ let - binders = map fst pairs - extra_env' = [ (b, LetBound TopLet $! manifestArity rhs) | (b, rhs) <- pairs ] env' = extendVarEnvList env extra_env' -- generate StgTopBindings and CAF cost centres created for CAFs (ccs', stg_rhss) - = initCts dflags env' $ - mapAccumLM (\ccs rhs -> swap <$> coreToTopStgRhs dflags ccs this_mod rhs) - ccs - pairs - bind = StgTopLifted $ StgRec (zip binders stg_rhss) + = initCts platform env' $ mapAccumLM (coreToTopStgRhs opts this_mod) ccs pairs + bind = StgTopLifted $ StgRec stg_rhss in (env', ccs', bind) coreToTopStgRhs - :: DynFlags - -> CollectedCCs + :: CoreToStgOpts -> Module + -> CollectedCCs -> (Id,CoreExpr) - -> CtsM (StgRhs, CollectedCCs) + -> CtsM (CollectedCCs, (Id, StgRhs)) -coreToTopStgRhs dflags ccs this_mod (bndr, rhs) +coreToTopStgRhs opts this_mod ccs (bndr, rhs) = do { new_rhs <- coreToPreStgRhs rhs ; let (stg_rhs, ccs') = - mkTopStgRhs dflags this_mod ccs bndr new_rhs + mkTopStgRhs opts this_mod ccs bndr new_rhs stg_arity = stgRhsArity stg_rhs - ; return (assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs, - ccs') } + ; pure (ccs', (bndr, assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs)) } where -- It's vital that the arity on a top-level Id matches -- the arity of the generated STG binding, else an importing @@ -402,7 +400,11 @@ = case app_head of Var f -> coreToStgApp f args ticks -- Regular application Lit l | isLitRubbish l -- If there is LitRubbish at the head, - -> return (StgLit l) -- discard the arguments + -- 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)) _ -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr) where @@ -458,15 +460,6 @@ where vars_alt :: CoreAlt -> CtsM StgAlt vars_alt (Alt con binders rhs) - | DataAlt c <- con, c == unboxedUnitDataCon - = -- This case is a bit smelly. - -- See Note [Nullary unboxed tuple] in GHC.Core.Type - -- where a nullary tuple is mapped to (State# World#) - assert (null binders) $ - do { rhs2 <- coreToStgExpr rhs - ; return GenStgAlt{alt_con=DEFAULT,alt_bndrs=mempty,alt_rhs=rhs2} - } - | otherwise = let -- Remove type variables binders' = filterStgBinders binders in @@ -501,8 +494,7 @@ prim_reps = typePrimRep bndr_ty _is_poly_alt_tycon tc - = isFunTyCon tc - || isPrimTyCon tc -- "Any" is lifted but primitive + = isPrimTyCon tc -- "Any" is lifted but primitive || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict -- function application where argument has a -- type-family type @@ -554,7 +546,7 @@ -- Some primitive operator that might be implemented as a library call. -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps -- we require that primop applications be saturated. - PrimOpId op -> assert saturated $ + PrimOpId op _ -> -- assertPpr saturated (ppr f <+> ppr args) $ StgOpApp (StgPrimOp op) args' res_ty -- A call to some primitive Cmm function. @@ -606,10 +598,11 @@ let (aticks, arg'') = stripStgTicksTop tickishFloatable arg' stg_arg = case arg'' of - StgApp v [] -> StgVarArg v - StgConApp con _ [] _ -> StgVarArg (dataConWorkId con) - StgLit lit -> StgLitArg lit - _ -> pprPanic "coreToStgArgs" (ppr arg) + StgApp v [] -> StgVarArg v + StgConApp con _ [] _ -> StgVarArg (dataConWorkId con) + StgOpApp (StgPrimOp op) [] _ -> StgVarArg (primOpWrapperId op) + StgLit lit -> StgLitArg lit + _ -> pprPanic "coreToStgArgs" (ppr arg $$ pprStgExpr panicStgPprOpts arg' $$ pprStgExpr panicStgPprOpts arg'') -- WARNING: what if we have an argument like (v `cast` co) -- where 'co' changes the representation type? @@ -621,7 +614,7 @@ -- or foreign call. -- Wanted: a better solution than this hacky warning - platform <- targetPlatform <$> getDynFlags + platform <- getPlatform let arg_rep = typePrimRep (exprType arg) stg_arg_rep = typePrimRep (stgArgType stg_arg) @@ -703,23 +696,24 @@ -- 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 (Cast expr _) = coreToPreStgRhs expr -coreToPreStgRhs expr@(Lam _ _) = - let - (args, body) = myCollectBinders expr - args' = filterStgBinders args - in - extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do - body' <- coreToStgExpr body - return (PreStgRhs args' body') -coreToPreStgRhs expr = PreStgRhs [] <$> coreToStgExpr expr +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 :: DynFlags -> Module -> CollectedCCs +mkTopStgRhs :: CoreToStgOpts -> Module -> CollectedCCs -> Id -> PreStgRhs -> (StgRhs, CollectedCCs) -mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs) +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 @@ -732,14 +726,14 @@ -- so this is not a function binding | StgConApp con mn args _ <- unticked_rhs , -- Dynamic StgConApps are updatable - not (isDllConApp (targetPlatform dflags) (gopt Opt_ExternalDynamicRefs dflags) this_mod con args) + 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]. - | gopt Opt_AutoSccsOnIndividualCafs dflags + | opt_AutoSccsOnIndividualCafs = ( StgRhsClosure noExtFieldSilent caf_ccs upd_flag [] rhs @@ -863,7 +857,7 @@ -- *down*. newtype CtsM a = CtsM - { unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs + { unCtsM :: Platform -- Needed for checking for bad coercions in coreToStgArgs -> IdEnv HowBound -> a } @@ -901,8 +895,8 @@ -- The std monad functions: -initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a -initCts dflags env m = unCtsM m dflags env +initCts :: Platform -> IdEnv HowBound -> CtsM a -> a +initCts platform env m = unCtsM m platform env @@ -913,8 +907,8 @@ returnCts e = CtsM $ \_ _ -> e thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b -thenCts m k = CtsM $ \dflags env - -> unCtsM (k (unCtsM m dflags env)) dflags env +thenCts m k = CtsM $ \platform env + -> unCtsM (k (unCtsM m platform env)) platform env instance Applicative CtsM where pure = returnCts @@ -923,15 +917,15 @@ instance Monad CtsM where (>>=) = thenCts -instance HasDynFlags CtsM where - getDynFlags = CtsM $ \dflags _ -> dflags +getPlatform :: CtsM Platform +getPlatform = CtsM const -- Functions specific to this monad: extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a extendVarEnvCts ids_w_howbound expr - = CtsM $ \dflags env - -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound) + = CtsM $ \platform env + -> unCtsM expr platform (extendVarEnvList env ids_w_howbound) lookupVarCts :: Id -> CtsM HowBound lookupVarCts v = CtsM $ \_ env -> lookupBinding env v @@ -1003,3 +997,12 @@ stgArity _ (LetBound _ arity) = arity stgArity f ImportBound = idArity f stgArity _ LambdaBound = 0 + +data CoreToStgOpts = CoreToStgOpts + { coreToStg_platform :: Platform + , coreToStg_ways :: Ways + , coreToStg_AutoSccsOnIndividualCafs :: Bool + , coreToStg_InfoTableMap :: Bool + , coreToStg_ExternalDynamicRefs :: Bool + , coreToStg_stgDebugOpts :: StgDebugOpts + } diff --git a/GHC/CoreToStg/Prep.hs b/GHC/CoreToStg/Prep.hs --- a/GHC/CoreToStg/Prep.hs +++ b/GHC/CoreToStg/Prep.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -11,7 +10,9 @@ -} module GHC.CoreToStg.Prep - ( corePrepPgm + ( CorePrepConfig (..) + , CorePrepPgmConfig (..) + , corePrepPgm , corePrepExpr , mkConvertNumLiteral ) @@ -21,9 +22,7 @@ import GHC.Platform -import GHC.Driver.Session -import GHC.Driver.Env -import GHC.Driver.Ppr +import GHC.Driver.Flags import GHC.Tc.Utils.Env import GHC.Unit @@ -33,9 +32,7 @@ import GHC.Core.Utils import GHC.Core.Opt.Arity -import GHC.Core.FVs -import GHC.Core.Opt.Monad ( CoreToDo(..) ) -import GHC.Core.Lint ( endPassIO ) +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 @@ -58,17 +55,15 @@ import GHC.Utils.Outputable import GHC.Utils.Monad ( mapAccumLM ) import GHC.Utils.Logger -import GHC.Utils.Trace import GHC.Types.Demand import GHC.Types.Var -import GHC.Types.Var.Set 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 ( NamedThing(..), nameSrcSpan, isInternalName ) +import GHC.Types.Name ( Name, NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) import GHC.Types.Literal import GHC.Types.Tickish @@ -117,6 +112,17 @@ 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. @@ -126,26 +132,24 @@ We want curried definitions for all of these in case they aren't inlined by some caller. -9. Replace (lazy e) by e. See Note [lazyId magic] in GHC.Types.Id.Make - Also replace (noinline e) by e. - -10. Convert bignum literals into their core representation. + 9. Convert bignum literals into their core representation. -11. Uphold tick consistency while doing this: We move ticks out of +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. -12. Collect cost centres (including cost centres in unfoldings) if we're in - profiling mode. We have to do this here beucase we won't have unfoldings +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]. -13. Eliminate case clutter in favour of unsafe coercions. +12. Eliminate case clutter in favour of unsafe coercions. See Note [Unsafe coercions] -14. Eliminate some magic Ids, specifically +13. Eliminate some magic Ids, specifically runRW# (\s. e) ==> e[readWorldId/s] - lazy e ==> e + 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 @@ -185,7 +189,7 @@ Tiresome, but not difficult. These transformations get rid of "case clutter", leaving only casts. -We are doing no further significant tranformations, so the reasons +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. @@ -234,17 +238,28 @@ ************************************************************************ -} -corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon] +data CorePrepPgmConfig = CorePrepPgmConfig + { cpPgm_endPassConfig :: !EndPassConfig + , cpPgm_generateDebugInfo :: !Bool + } + +corePrepPgm :: Logger + -> CorePrepConfig + -> CorePrepPgmConfig + -> Module -> ModLocation -> CoreProgram -> [TyCon] -> IO CoreProgram -corePrepPgm hsc_env this_mod mod_loc binds data_tycons = +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' - initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env + let initialCorePrepEnv = mkInitialCorePrepEnv cp_cfg let - implicit_binds = mkDataConWorkers dflags mod_loc data_tycons + 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 @@ -253,18 +268,15 @@ floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds return (deFloatTop (floats1 `appendFloats` floats2)) - endPassIO hsc_env alwaysQualify CorePrep binds_out [] + endPassIO logger (cpPgm_endPassConfig pgm_cfg) + binds_out [] return binds_out - where - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env -corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr -corePrepExpr hsc_env expr = do - let logger = hsc_logger hsc_env +corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr +corePrepExpr logger config expr = do withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do us <- mkSplitUniqSupply 's' - initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env + 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 @@ -283,10 +295,10 @@ floatss <- go env' binds return (floats `appendFloats` floatss) -mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind] +mkDataConWorkers :: Bool -> ModLocation -> [TyCon] -> [CoreBind] -- See Note [Data constructor workers] -- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy -mkDataConWorkers dflags mod_loc data_tycons +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 @@ -297,11 +309,12 @@ -- 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 (needSourceNotes dflags) = id + | 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 $ showSDoc dflags (ppr name)) + where tick span = Tick $ SourceNote span $ + renderWithContext defaultSDocContext $ ppr name span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1 {- @@ -777,12 +790,12 @@ cpeRhsE env (Coercion co) = return (emptyFloats, Coercion (cpSubstCo env co)) cpeRhsE env expr@(Lit (LitNumber nt i)) - = case cpe_convertNumLit env nt i of + = 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 expr@(App {}) = cpeApp env expr cpeRhsE env (Let bind body) = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind @@ -793,7 +806,7 @@ cpeRhsE env (Tick tickish expr) -- Pull out ticks if they are allowed to be floated. - | floatableTick tickish + | tickishFloatable tickish = do { (floats, body) <- cpeRhsE env expr -- See [Floating Ticks in CorePrep] ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) } @@ -851,18 +864,11 @@ = do { (floats, scrut') <- cpeBody env scrut ; (env', bndr2) <- cpCloneBndr env bndr ; let alts' - -- 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. - | gopt Opt_CatchNonexhaustiveCases (cpe_dynFlags env) + | cp_catchNonexhaustiveCases $ cpe_config env , not (altsAreExhaustive alts) = addDefault alts (Just err) | otherwise = alts - where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty - "Bottoming expression returned" + where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative" ; alts'' <- mapM (sat_alt env') alts' ; return (floats, Case scrut' bndr2 ty alts'') } @@ -917,9 +923,7 @@ = do { (floats, e') <- rhsToBody e ; return (floats, Cast e' co) } -rhsToBody expr@(Lam {}) - | Just no_lam_result <- tryEtaReducePrep bndrs body - = return (emptyFloats, no_lam_result) +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 @@ -928,12 +932,30 @@ ; let float = FloatLet (NonRec fn rhs) ; return (unitFloat float, Var fn) } where - (bndrs,body) = collectBinders expr + (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 -- --------------------------------------------------------------------------- @@ -1013,10 +1035,12 @@ -- 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] - | floatableTick tickish || isProfTick tickish - , Var vh <- head + -- 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 - , hasNoBinding head' + , etaExpansionTick head' tickish = (head,as') where (head,as') = go fun (CpeTick tickish : as) @@ -1032,8 +1056,11 @@ 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 -- Replace (noinline a) with a + || 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: -- @@ -1084,7 +1111,7 @@ where depth = val_args args stricts = case idDmdSig v of - DmdSig (DmdType _ demands) + DmdSig (DmdType _ demands _) | listLengthCmp demands depth /= GT -> demands -- length demands <= depth | otherwise -> [] @@ -1118,7 +1145,7 @@ case info of CpeCast {} -> go infos n CpeTick tickish - | floatableTick tickish -> go infos n + | 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 @@ -1183,12 +1210,9 @@ arg_ty' = cpSubstTy env arg_ty CpeApp (Coercion co) - -> rebuild_app' env as (App fun' (Coercion co')) floats ss' rt_ticks req_depth + -> rebuild_app' env as (App fun' (Coercion co')) floats (drop 1 ss) rt_ticks req_depth where co' = cpSubstCo env co - ss' - | null ss = [] - | otherwise = tail ss CpeApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make @@ -1564,7 +1588,7 @@ 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 words for + generated (a little) and make things a little worse for code compiled without -O. The case in point is data constructor wrappers. @@ -1598,56 +1622,6 @@ | otherwise = etaExpand arity expr {- --- ----------------------------------------------------------------------------- --- Eta reduction --- ----------------------------------------------------------------------------- - -Why try eta reduction? Hasn't the simplifier already done eta? -But the simplifier only eta reduces if that leaves something -trivial (like f, or f Int). But for deLam it would be enough to -get to a partial application: - case x of { p -> \xs. map f xs } - ==> case x of { p -> map f } --} - --- When updating this function, make sure it lines up with --- GHC.Core.Utils.tryEtaReduce! -tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr -tryEtaReducePrep bndrs expr@(App _ _) - | ok_to_eta_reduce f - , n_remaining >= 0 - , and (zipWith ok bndrs last_args) - , not (any (`elemVarSet` fvs_remaining) bndrs) - , exprIsHNF remaining_expr -- Don't turn value into a non-value - -- else the behaviour with 'seq' changes - = - -- pprTrace "prep-reduce" ( - -- text "reduced:" <> ppr remaining_expr $$ - -- ppr (remaining_args) - -- ) $ - Just remaining_expr - where - (f, args) = collectArgs expr - remaining_expr = mkApps f remaining_args - fvs_remaining = exprFreeVars remaining_expr - (remaining_args, last_args) = splitAt n_remaining args - n_remaining = length args - length bndrs - n_remaining_vals = length $ filter isRuntimeArg remaining_args - - ok bndr (Var arg) = bndr == arg - ok _ _ = False - - ok_to_eta_reduce (Var f) = canEtaReduceToArity f n_remaining n_remaining_vals - ok_to_eta_reduce _ = False -- Safe. ToDo: generalise - - -tryEtaReducePrep bndrs (Tick tickish e) - | tickishFloatable tickish - = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e - -tryEtaReducePrep _ _ = Nothing - -{- ************************************************************************ * * Floats @@ -1990,8 +1964,25 @@ -} +data CorePrepConfig = CorePrepConfig + { cp_catchNonexhaustiveCases :: !Bool + -- ^ Whether to generate a default alternative with ``error`` in these + -- cases. This is helpful when debugging demand analysis or type + -- checker bugs which can sometimes manifest as segmentation faults. + + , cp_convertNumLit :: !(LitNumType -> Integer -> Maybe CoreExpr) + -- ^ Convert some numeric literals (Integer, Natural) into their final + -- Core form. + } + data CorePrepEnv - = CPE { cpe_dynFlags :: DynFlags + = 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: -- @@ -2007,20 +1998,14 @@ , cpe_tyco_env :: Maybe CpeTyCoEnv -- See Note [CpeTyCoEnv] - , cpe_convertNumLit :: LitNumType -> Integer -> Maybe CoreExpr - -- ^ Convert some numeric literals (Integer, Natural) into their - -- final Core form , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation] } -mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv -mkInitialCorePrepEnv hsc_env = do - convertNumLit <- mkConvertNumLiteral hsc_env - return $ CPE - { cpe_dynFlags = hsc_dflags hsc_env +mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv +mkInitialCorePrepEnv cfg = CPE + { cpe_config = cfg , cpe_env = emptyVarEnv , cpe_tyco_env = Nothing - , cpe_convertNumLit = convertNumLit , cpe_rec_ids = emptyUnVarSet } @@ -2054,7 +2039,7 @@ {- Note [CpeTyCoEnv] ~~~~~~~~~~~~~~~~~~~~ The cpe_tyco_env :: Maybe CpeTyCoEnv field carries a substitution -for type and coercion varibles +for type and coercion variables * We need the coercion substitution to support the elimination of unsafeEqualityProof (see Note [Unsafe coercions]) @@ -2179,7 +2164,9 @@ -- Drop (now-useless) rules/unfoldings -- See Note [Drop unfoldings and rules] -- and Note [Preserve evaluatedness] in GHC.Core.Tidy - ; let unfolding' = trimUnfolding (realIdUnfolding bndr) + -- 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' @@ -2232,9 +2219,7 @@ newVar :: Type -> UniqSM Id newVar ty - = seqType ty `seq` do - uniq <- getUniqueM - return (mkSysLocalOrCoVar (fsLit "sat") uniq Many ty) + = seqType ty `seq` mkSysLocalOrCoVarM (fsLit "sat") ManyTy ty ------------------------------------------------------------------------------ @@ -2292,24 +2277,18 @@ wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs) wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs) -floatableTick :: GenTickish pass -> Bool -floatableTick tickish = - tickishPlace tickish == PlaceNonLam && - tickish `tickishScopesLike` SoftScope - ------------------------------------------------------------------------------ -- Numeric literals -- --------------------------------------------------------------------------- -- | Create a function that converts Bignum literals into their final CoreExpr mkConvertNumLiteral - :: HscEnv + :: Platform + -> HomeUnit + -> (Name -> IO TyThing) -> IO (LitNumType -> Integer -> Maybe CoreExpr) -mkConvertNumLiteral hsc_env = do +mkConvertNumLiteral platform home_unit lookup_global = do let - dflags = hsc_dflags hsc_env - platform = targetPlatform dflags - home_unit = hsc_home_unit hsc_env guardBignum act | isHomeUnitInstanceOf home_unit primUnitId = return $ panic "Bignum literals are not supported in ghc-prim" @@ -2317,7 +2296,7 @@ = return $ panic "Bignum literals are not supported in ghc-bignum" | otherwise = act - lookupBignumId n = guardBignum (tyThingId <$> lookupGlobal hsc_env n) + 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. @@ -2334,8 +2313,6 @@ convertBignatPrim i = let - target = targetPlatform dflags - -- 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 @@ -2351,11 +2328,10 @@ f x = let low = x .&. mask high = x `shiftR` bits in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high) - bits = platformWordSizeInBits target + bits = platformWordSizeInBits platform mask = 2 ^ bits - 1 in mkApps (Var bignatFromWordListId) [words] return convertNumLit - diff --git a/GHC/Data/Bag.hs b/GHC/Data/Bag.hs --- a/GHC/Data/Bag.hs +++ b/GHC/Data/Bag.hs @@ -6,7 +6,7 @@ Bag: an unordered collection with duplicates -} -{-# LANGUAGE ScopedTypeVariables, DeriveFunctor, TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables, DeriveTraversable, TypeFamilies #-} module GHC.Data.Bag ( Bag, -- abstract type @@ -18,7 +18,7 @@ concatBag, catBagMaybes, foldBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, listToBag, nonEmptyToBag, bagToList, headMaybe, mapAccumBagL, - concatMapBag, concatMapBagPair, mapMaybeBag, + concatMapBag, concatMapBagPair, mapMaybeBag, unzipBag, mapBagM, mapBagM_, flatMapBagM, flatMapBagPairM, mapAndUnzipBagM, mapAccumBagLM, @@ -33,10 +33,10 @@ import GHC.Utils.Monad import Control.Monad import Data.Data -import Data.Maybe( mapMaybe, listToMaybe ) +import Data.Maybe( mapMaybe ) import Data.List ( partition, mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..) ) -import qualified Data.Foldable as Foldable +import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup ( (<>) ) infixr 3 `consBag` @@ -46,8 +46,8 @@ = EmptyBag | UnitBag a | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty - | ListBag [a] -- INVARIANT: the list is non-empty - deriving (Functor) + | ListBag (NonEmpty a) + deriving (Foldable, Functor, Traversable) emptyBag :: Bag a emptyBag = EmptyBag @@ -91,7 +91,7 @@ isSingletonBag EmptyBag = False isSingletonBag (UnitBag _) = True isSingletonBag (TwoBags _ _) = False -- Neither is empty -isSingletonBag (ListBag xs) = isSingleton xs +isSingletonBag (ListBag (_:|xs)) = null xs filterBag :: (a -> Bool) -> Bag a -> Bag a filterBag _ EmptyBag = EmptyBag @@ -99,7 +99,7 @@ filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 where sat1 = filterBag pred b1 sat2 = filterBag pred b2 -filterBag pred (ListBag vs) = listToBag (filter pred vs) +filterBag pred (ListBag vs) = listToBag (filter pred (toList vs)) filterBagM :: Monad m => (a -> m Bool) -> Bag a -> m (Bag a) filterBagM _ EmptyBag = return EmptyBag @@ -112,7 +112,7 @@ sat2 <- filterBagM pred b2 return (sat1 `unionBags` sat2) filterBagM pred (ListBag vs) = do - sat <- filterM pred vs + sat <- filterM pred (toList vs) return (listToBag sat) allBag :: (a -> Bool) -> Bag a -> Bool @@ -136,9 +136,7 @@ anyBagM p (ListBag xs) = anyM p xs concatBag :: Bag (Bag a) -> Bag a -concatBag bss = foldr add emptyBag bss - where - add bs rs = bs `unionBags` rs +concatBag = foldr unionBags emptyBag catBagMaybes :: Bag (Maybe a) -> Bag a catBagMaybes bs = foldr add emptyBag bs @@ -156,7 +154,7 @@ where (sat1, fail1) = partitionBag pred b1 (sat2, fail2) = partitionBag pred b2 partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) - where (sats, fails) = partition pred vs + where (sats, fails) = partition pred (toList vs) partitionBagWith :: (a -> Either b c) -> Bag a @@ -172,7 +170,7 @@ where (sat1, fail1) = partitionBagWith pred b1 (sat2, fail2) = partitionBagWith pred b2 partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails) - where (sats, fails) = partitionWith pred vs + where (sats, fails) = partitionWith pred (toList vs) foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative -> (a -> r) -- Replace UnitBag with this @@ -221,7 +219,7 @@ Nothing -> EmptyBag Just y -> UnitBag y mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2) -mapMaybeBag f (ListBag xs) = ListBag (mapMaybe f xs) +mapMaybeBag f (ListBag xs) = listToBag $ mapMaybe f (toList xs) mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) mapBagM _ EmptyBag = return EmptyBag @@ -268,7 +266,7 @@ (r2,s2) <- mapAndUnzipBagM f b2 return (TwoBags r1 r2, TwoBags s1 s2) mapAndUnzipBagM f (ListBag xs) = do ts <- mapM f xs - let (rs,ss) = unzip ts + let (rs,ss) = NE.unzip ts return (ListBag rs, ListBag ss) mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining function @@ -299,20 +297,31 @@ listToBag :: [a] -> Bag a listToBag [] = EmptyBag listToBag [x] = UnitBag x -listToBag vs = ListBag vs +listToBag (x:xs) = ListBag (x:|xs) nonEmptyToBag :: NonEmpty a -> Bag a nonEmptyToBag (x :| []) = UnitBag x -nonEmptyToBag (x :| xs) = ListBag (x : xs) +nonEmptyToBag xs = ListBag xs bagToList :: Bag a -> [a] bagToList b = foldr (:) [] b +unzipBag :: Bag (a, b) -> (Bag a, Bag b) +unzipBag EmptyBag = (EmptyBag, EmptyBag) +unzipBag (UnitBag (a, b)) = (UnitBag a, UnitBag b) +unzipBag (TwoBags xs1 xs2) = (TwoBags as1 as2, TwoBags bs1 bs2) + where + (as1, bs1) = unzipBag xs1 + (as2, bs2) = unzipBag xs2 +unzipBag (ListBag xs) = (ListBag as, ListBag bs) + where + (as, bs) = NE.unzip xs + headMaybe :: Bag a -> Maybe a headMaybe EmptyBag = Nothing headMaybe (UnitBag v) = Just v headMaybe (TwoBags b1 _) = headMaybe b1 -headMaybe (ListBag l) = listToMaybe l +headMaybe (ListBag (v:|_)) = Just v instance (Outputable a) => Outputable (Bag a) where ppr bag = braces (pprWithCommas ppr (bagToList bag)) @@ -323,28 +332,6 @@ gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Bag" dataCast1 x = gcast1 x - -instance Foldable.Foldable Bag where - foldr _ z EmptyBag = z - foldr k z (UnitBag x) = k x z - foldr k z (TwoBags b1 b2) = foldr k (foldr k z b2) b1 - foldr k z (ListBag xs) = foldr k z xs - - foldl _ z EmptyBag = z - foldl k z (UnitBag x) = k z x - foldl k z (TwoBags b1 b2) = foldl k (foldl k z b1) b2 - foldl k z (ListBag xs) = foldl k z xs - - foldl' _ z EmptyBag = z - foldl' k z (UnitBag x) = k z x - foldl' k z (TwoBags b1 b2) = let r1 = foldl' k z b1 in seq r1 $ foldl' k r1 b2 - foldl' k z (ListBag xs) = foldl' k z xs - -instance Traversable Bag where - traverse _ EmptyBag = pure EmptyBag - traverse f (UnitBag x) = UnitBag <$> f x - traverse f (TwoBags b1 b2) = TwoBags <$> traverse f b1 <*> traverse f b2 - traverse f (ListBag xs) = ListBag <$> traverse f xs instance IsList (Bag a) where type Item (Bag a) = a diff --git a/GHC/Data/Bool.hs b/GHC/Data/Bool.hs --- a/GHC/Data/Bool.hs +++ b/GHC/Data/Bool.hs @@ -4,7 +4,7 @@ ) where -import GHC.Prelude +import GHC.Prelude.Basic data OverridingBool = Auto diff --git a/GHC/Data/BooleanFormula.hs b/GHC/Data/BooleanFormula.hs --- a/GHC/Data/BooleanFormula.hs +++ b/GHC/Data/BooleanFormula.hs @@ -16,15 +16,16 @@ pprBooleanFormula, pprBooleanFormulaNice ) where -import GHC.Prelude +import GHC.Prelude hiding ( init, last ) import Data.List ( nub, 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 ) +import GHC.Parser.Annotation ( LocatedL, noLocA ) import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Set @@ -227,7 +228,7 @@ pprAnd p = cparen (p > 1) . pprAnd' pprAnd' [] = empty pprAnd' [x,y] = x <+> text "and" <+> y - pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs + 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 @@ -250,14 +251,14 @@ 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 xs - put_ bh (Or xs) = putByte bh 2 >> put_ bh xs - put_ bh (Parens x) = putByte bh 3 >> 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 <$> get bh - 2 -> Or <$> get bh - _ -> Parens <$> get bh + 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 @@ -15,11 +15,12 @@ import GHC.Prelude import GHC.Utils.Binary +import Control.DeepSeq import qualified Data.IntSet as IntSet newtype EnumSet a = EnumSet IntSet.IntSet - deriving (Semigroup, Monoid) + deriving (Semigroup, Monoid, NFData) member :: Enum a => a -> EnumSet a -> Bool member x (EnumSet s) = IntSet.member (fromEnum x) s diff --git a/GHC/Data/FastMutInt.hs b/GHC/Data/FastMutInt.hs --- a/GHC/Data/FastMutInt.hs +++ b/GHC/Data/FastMutInt.hs @@ -13,7 +13,7 @@ atomicFetchAddFastMut ) where -import GHC.Prelude +import GHC.Prelude.Basic import GHC.Base diff --git a/GHC/Data/FastString.hs b/GHC/Data/FastString.hs --- a/GHC/Data/FastString.hs +++ b/GHC/Data/FastString.hs @@ -30,8 +30,8 @@ -- * Pointer and size of a Latin-1 encoded string. -- * Practically no operations. -- * Outputting them is fast. --- * Generated by 'mkPtrString'. --- * Length of string literals (mkPtrString "abc") is computed statically +-- * Generated by 'mkPtrString#'. +-- * Length of string literals (mkPtrString# "abc"#) is computed statically -- * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ptext' -- * Requires manual memory management. -- Improper use may lead to memory leaks or dangling pointers. @@ -56,6 +56,7 @@ FastZString, hPutFZS, zString, + zStringTakeN, lengthFZS, -- * FastStrings @@ -82,11 +83,9 @@ lengthFS, nullFS, appendFS, - headFS, concatFS, consFS, nilFS, - isUnderscoreFS, lexicalCompareFS, uniqCompareFS, @@ -102,16 +101,16 @@ -- ** Construction mkPtrString#, - mkPtrString, -- ** Deconstruction unpackPtrString, + unpackPtrStringTakeN, -- ** Operations lengthPS ) where -import GHC.Prelude as Prelude +import GHC.Prelude.Basic as Prelude import GHC.Utils.Encoding import GHC.Utils.IO.Unsafe @@ -135,7 +134,6 @@ import System.IO import Data.Data import Data.IORef -import Data.Char import Data.Semigroup as Semi import Foreign @@ -183,6 +181,14 @@ zString (FastZString bs) = inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen +-- | @zStringTakeN n = 'take' n . 'zString'@ +-- but is performed in \(O(\min(n,l))\) rather than \(O(l)\), +-- where \(l\) is the length of the 'FastZString'. +zStringTakeN :: Int -> FastZString -> String +zStringTakeN n (FastZString bs) = + inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(cp, len) -> + peekCAStringLen (cp, min n len) + lengthFZS :: FastZString -> Int lengthFZS (FastZString bs) = BS.length bs @@ -459,8 +465,7 @@ FastStringTableSegment lock _ buckets# <- readIORef segmentRef let idx# = hashToIndex# buckets# hash# bucket <- IO $ readArray# buckets# idx# - res <- bucket_match bucket sbs - case res of + case bucket_match bucket sbs of Just found -> return found Nothing -> do -- The withMVar below is not dupable. It can lead to deadlock if it is @@ -479,8 +484,7 @@ FastStringTableSegment _ counter buckets# <- maybeResizeSegment segmentRef let idx# = hashToIndex# buckets# hash# bucket <- IO $ readArray# buckets# idx# - res <- bucket_match bucket sbs - case res of + case bucket_match bucket sbs of -- The FastString was added by another thread after previous read and -- before we acquired the write lock. Just found -> return found @@ -491,11 +495,12 @@ _ <- atomicFetchAddFastMut counter 1 return fs -bucket_match :: [FastString] -> ShortByteString -> IO (Maybe FastString) -bucket_match [] _ = return Nothing -bucket_match (fs@(FastString {fs_sbs=fs_sbs}) : ls) sbs - | fs_sbs == sbs = return (Just fs) - | otherwise = bucket_match ls sbs +bucket_match :: [FastString] -> ShortByteString -> Maybe FastString +bucket_match fs sbs = go fs + where go [] = Nothing + go (fs@(FastString {fs_sbs=fs_sbs}) : ls) + | fs_sbs == sbs = Just fs + | otherwise = go ls mkFastStringBytes :: Ptr Word8 -> Int -> FastString mkFastStringBytes !ptr !len = @@ -531,13 +536,13 @@ {-# NOINLINE[1] mkFastString #-} mkFastString str = inlinePerformIO $ do - sbs <- utf8EncodeShortByteString str + let !sbs = utf8EncodeShortByteString str mkFastStringWith (mkNewFastStringShortByteString sbs) sbs -- The following rule is used to avoid polluting the non-reclaimable FastString -- table with transient strings when we only want their encoding. {-# RULES -"bytesFS/mkFastString" forall x. bytesFS (mkFastString x) = utf8EncodeString x #-} +"bytesFS/mkFastString" forall x. bytesFS (mkFastString x) = utf8EncodeByteString x #-} -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ mkFastStringByteList :: [Word8] -> FastString @@ -554,7 +559,7 @@ -> FastMutInt -> IO FastString mkNewFastStringShortByteString sbs uid n_zencs = do let zstr = mkZFastString n_zencs sbs - chars <- countUTF8Chars sbs + chars = utf8CountCharsShortByteString sbs return (FastString uid chars sbs zstr) hashStr :: ShortByteString -> Int @@ -590,7 +595,7 @@ nullFS :: FastString -> Bool nullFS fs = SBS.null $ fs_sbs fs --- | Unpacks and decodes the FastString +-- | Lazily unpacks and decodes the FastString unpackFS :: FastString -> String unpackFS fs = utf8DecodeShortByteString $ fs_sbs fs @@ -609,11 +614,6 @@ concatFS :: [FastString] -> FastString concatFS = mkFastStringShortByteString . mconcat . map fs_sbs -headFS :: FastString -> Char -headFS fs - | SBS.null $ fs_sbs fs = panic "headFS: Empty FastString" -headFS fs = head $ unpackFS fs - consFS :: Char -> FastString -> FastString consFS c fs = mkFastString (c : unpackFS fs) @@ -629,9 +629,6 @@ nilFS :: FastString nilFS = mkFastString "" -isUnderscoreFS :: FastString -> Bool -isUnderscoreFS fs = fs == fsLit "_" - -- ----------------------------------------------------------------------------- -- Stats @@ -673,34 +670,18 @@ {-# INLINE mkPtrString# #-} mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#)) --- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1 --- encoding. The original string must not contain non-Latin-1 characters --- (above codepoint @0xff@). -{-# NOINLINE[0] mkPtrString #-} -- see rules below -mkPtrString :: String -> PtrString -mkPtrString s = - -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks - -- and because someone might be using `eqAddr#` to check for string equality. - unsafePerformIO (do - let len = length s - p <- mallocBytes len - let - loop :: Int -> String -> IO () - loop !_ [] = return () - loop n (c:cs) = do - pokeByteOff p n (fromIntegral (ord c) :: Word8) - loop (1+n) cs - loop 0 s - return (PtrString p len) - ) - -{-# RULES "mkPtrString" - forall x . mkPtrString (unpackCString# x) = mkPtrString# x #-} - -- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding. -- This does not free the memory associated with 'PtrString'. unpackPtrString :: PtrString -> String unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n# + +-- | @unpackPtrStringTakeN n = 'take' n . 'unpackPtrString'@ +-- but is performed in \(O(\min(n,l))\) rather than \(O(l)\), +-- where \(l\) is the length of the 'PtrString'. +unpackPtrStringTakeN :: Int -> PtrString -> String +unpackPtrStringTakeN n (PtrString (Ptr p#) len) = + case min n len of + I# n# -> unpackNBytes# p# n# -- | Return the length of a 'PtrString' lengthPS :: PtrString -> Int diff --git a/GHC/Data/Graph/Collapse.hs b/GHC/Data/Graph/Collapse.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Collapse.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module GHC.Data.Graph.Collapse + ( PureSupernode(..) + , Supernode(..) + , collapseInductiveGraph + , VizCollapseMonad(..) + , NullCollapseViz(..) + , runNullCollapse + , MonadUniqSM(..) + ) +where + +import GHC.Prelude + +import Control.Exception +import Control.Monad +import Data.List (delete, union, insert, intersect) +import Data.Semigroup + +import GHC.Cmm.Dataflow.Label +import GHC.Data.Graph.Inductive.Graph +import GHC.Types.Unique.Supply +import GHC.Utils.Panic + + +{-| +Module : GHC.Data.Graph.Collapse +Description : Implement the "collapsing" algorithm Hecht and Ullman + +A control-flow graph is reducible if and only if it is collapsible +according to the definition of Hecht and Ullman (1972). This module +implements the collapsing algorithm of Hecht and Ullman, and if it +encounters a graph that is not collapsible, it splits nodes until the +graph is fully collapsed. It then reports what nodes (if any) had to +be split in order to collapse the graph. The information is used +upstream to node-split Cmm graphs. + +The module uses the inductive graph representation cloned from the +Functional Graph Library (Hackage package `fgl`, modules +`GHC.Data.Graph.Inductive.*`.) + +-} + +-- Full reference to paper: Matthew S. Hecht and Jeffrey D. Ullman +-- (1972). Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202. +-- https://doi.org/10.1137/0201014 + + +------------------ Graph-splitting monad ----------------------- + +-- | If you want to visualize the graph-collapsing algorithm, create +-- an instance of monad `VizCollapseMonad`. Each step in the +-- algorithm is announced to the monad as a side effect. If you don't +-- 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 + 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) + +instance MonadUniqSM NullCollapseViz where + liftUniqSM = NullCollapseViz + +instance (Graph gr, Supernode s NullCollapseViz) => + VizCollapseMonad NullCollapseViz gr s where + consumeByInGraph _ _ _ = return () + splitGraphAt _ _ = return () + finalGraph _ = return () + +runNullCollapse :: NullCollapseViz a -> UniqSM a +runNullCollapse = unNCV + + +------------------ Utility functions on graphs ----------------------- + + +-- | Tell if a `Node` has a single predecessor. +singlePred :: Graph gr => gr a b -> Node -> Bool +singlePred gr n + | ([_], _, _, _) <- context gr n = True + | otherwise = False + +-- | Use this function to extract information about a `Node` that you +-- know is in a `Graph`. It's like `match` from `Graph`, but it must +-- succeed. +forceMatch :: (Graph gr) + => Node -> gr s b -> (Context s b, gr s b) +forceMatch node g = case match node g of (Just c, g') -> (c, g') + _ -> panicDump node g + where panicDump :: Graph gr => Node -> gr s b -> any + panicDump k _g = + panic $ "GHC.Data.Graph.Collapse failed to match node " ++ show k + +-- | Rewrite the label of a given node. +updateNode :: DynGraph gr => (s -> s) -> Node -> gr s b -> gr s b +updateNode relabel node g = (preds, n, relabel this, succs) & g' + where ((preds, n, this, succs), g') = forceMatch node g + + +-- | Test if a graph has but a single node. +singletonGraph :: Graph gr => gr a b -> Bool +singletonGraph g = case labNodes g of [_] -> True + _ -> False + + +---------------- Supernodes ------------------------------------ + +-- | A "supernode" stands for a collection of one or more nodes (basic +-- blocks) that have been coalesced by the Hecht-Ullman algorithm. +-- A collection in a supernode constitutes a /reducible/ subgraph of a +-- control-flow graph. (When an entire control-flow graph is collapsed +-- to a single supernode, the flow graph is reducible.) +-- +-- The idea of node splitting is to collapse a control-flow graph down +-- 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. +-- +-- During the Hecht-Ullman algorithm, every supernode has a unique +-- entry point, which is given by `superLabel`. But this invariant is +-- not guaranteed by the class methods and is not a law of the class. +-- The `mapLabels` function rewrites all labels that appear in a +-- supernode (both definitions and uses). The `freshen` function +-- replaces every appearance of a /defined/ label with a fresh label. +-- (Appearances include both definitions and uses.) +-- +-- Laws: +-- @ +-- superLabel (n <> n') == superLabel n +-- blocks (n <> n') == blocks n `union` blocks n' +-- mapLabels f (n <> n') = mapLabels f n <> mapLabels f n' +-- mapLabels id == id +-- mapLabels (f . g) == mapLabels f . mapLabels g +-- @ +-- +-- (We expect `freshen` to distribute over `<>`, but because of +-- the fresh names involved, formulating a precise law is a bit +-- challenging.) + +class (Semigroup node) => PureSupernode node where + superLabel :: node -> Label + mapLabels :: (Label -> Label) -> (node -> node) + +class (MonadUnique m, PureSupernode node) => Supernode node m where + freshen :: node -> m node + + -- ghost method + -- blocks :: node -> Set Block + +------------------ Functions specific to the algorithm ----------------------- + +-- | Merge two nodes, return new graph plus list of nodes that newly have a single +-- predecessor. This function implements transformation $T_2$ from +-- the Hecht and Ullman paper (merge the node into its unique +-- predecessor). It then also removes self-edges (transformation $T_1$ from +-- the Hecht and Ullman paper). There is no need for a separate +-- implementation of $T_1$. +-- +-- `consumeBy v u g` returns the graph that results when node v is +-- consumed by node u in graph g. Both v and u are replaced with a new node u' +-- with these properties: +-- +-- LABELS(u') = LABELS(u) `union` LABELS(v) +-- SUCC(u') = SUCC(u) `union` SUCC(v) - { u } +-- every node that previously points to u now points to u' +-- +-- It also returns a list of nodes in the result graph that +-- are *newly* single-predecessor nodes. + +consumeBy :: (DynGraph gr, PureSupernode s) + => Node -> Node -> gr s () -> (gr s (), [Node]) +consumeBy toNode fromNode g = + assert (toPreds == [((), fromNode)]) $ + (newGraph, newCandidates) + where ((toPreds, _, to, toSuccs), g') = forceMatch toNode g + ((fromPreds, _, from, fromSuccs), g'') = forceMatch fromNode g' + context = ( fromPreds -- by construction, can't have `toNode` + , fromNode + , from <> to + , delete ((), fromNode) toSuccs `union` fromSuccs + ) + newGraph = context & g'' + newCandidates = filter (singlePred newGraph) changedNodes + changedNodes = fromNode `insert` map snd (toSuccs `intersect` fromSuccs) + +-- | Split a given node. The node is replaced with a collection of replicas, +-- one for each predecessor. After the split, every predecessor +-- points to a unique replica. +split :: forall gr s b m . (DynGraph gr, Supernode s m) + => Node -> gr s b -> m (gr s b) +split node g = assert (isMultiple preds) $ foldM addReplica g' newNodes + where ((preds, _, this, succs), g') = forceMatch node g + newNodes :: [((b, Node), Node)] + newNodes = zip preds [maxNode+1..] + (_, maxNode) = nodeRange g + thisLabel = superLabel this + addReplica :: gr s b -> ((b, Node), Node) -> m (gr s b) + addReplica g ((b, pred), newNode) = do + newSuper <- freshen this + return $ add newSuper + where add newSuper = + updateNode (thisLabel `replacedWith` superLabel newSuper) pred $ + ([(b, pred)], newNode, newSuper, succs) & g + +replacedWith :: PureSupernode s => Label -> Label -> s -> s +replacedWith old new = mapLabels (\l -> if l == old then new else l) + + +-- | Does a list have more than one element? (in constant time). +isMultiple :: [a] -> Bool +isMultiple [] = False +isMultiple [_] = False +isMultiple (_:_:_) = True + +-- | Find a candidate for splitting by finding a node that has multiple predecessors. + +anySplittable :: forall gr a b . Graph gr => gr a b -> LNode a +anySplittable g = case splittable of + n : _ -> n + [] -> panic "anySplittable found no splittable nodes" + where splittable = filter (isMultiple . pre g . fst) $ labNodes g + splittable :: [LNode a] + + +------------------ The collapsing algorithm ----------------------- + +-- | Using the algorithm of Hecht and Ullman (1972), collapse a graph +-- into a single node, splitting nodes as needed. Record +-- visualization events in monad `m`. +collapseInductiveGraph :: (DynGraph gr, Supernode s m, VizCollapseMonad m gr s) + => gr s () -> m (gr s ()) +collapseInductiveGraph g = drain g worklist + where worklist :: [[Node]] -- nodes with exactly one predecessor + worklist = [filter (singlePred g) $ nodes g] + + drain g [] = if singletonGraph g then finalGraph g >> return g + else let (n, super) = anySplittable g + in do splitGraphAt g (n, super) + collapseInductiveGraph =<< split n g + drain g ([]:nss) = drain g nss + drain g ((n:ns):nss) = let (g', ns') = consumeBy n (theUniquePred n) g + in do consumeByInGraph n (theUniquePred n) g + drain g' (ns':ns:nss) + where theUniquePred n + | ([(_, p)], _, _, _) <- context g n = p + | otherwise = + panic "node claimed to have a unique predecessor; it doesn't" 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 @@ -95,7 +95,7 @@ -- try and color the problem nodes -- problem nodes are the ones that were left uncolored because they weren't triv. - -- theres a change we can color them here anyway. + -- there's a change we can color them here anyway. (graph_prob, ksNoColor) = assignColors colors graph_triv ksProblems @@ -328,8 +328,7 @@ -- See Note [Unique Determinism and code generation] colors_conflict = mkUniqSet - $ catMaybes - $ map nodeColor nsConflicts + $ mapMaybe nodeColor nsConflicts -- the prefs of our neighbors colors_neighbor_prefs 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 @@ -7,12 +7,13 @@ module GHC.Data.Graph.Directed ( Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, + graphFromVerticesAndAdjacency, - SCC(..), Node(..), flattenSCC, flattenSCCs, + SCC(..), Node(..), G.flattenSCC, G.flattenSCCs, stronglyConnCompG, topologicalSortG, verticesG, edgesG, hasVertexG, - reachableG, reachablesG, transposeG, allReachable, outgoingG, + reachableG, reachablesG, transposeG, allReachable, allReachableCyclic, outgoingG, emptyG, findCycle, @@ -57,7 +58,7 @@ import qualified Data.Set as Set import qualified Data.Graph as G -import Data.Graph hiding (Graph, Edge, transposeG, reachable) +import Data.Graph ( Vertex, Bounds, SCC(..) ) -- Used in the underlying representation import Data.Tree import GHC.Types.Unique import GHC.Types.Unique.FM @@ -290,19 +291,11 @@ -} stronglyConnCompG :: Graph node -> [SCC node] -stronglyConnCompG graph = decodeSccs graph forest - where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) - -decodeSccs :: Graph node -> Forest Vertex -> [SCC node] -decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest - = map decode forest - where - decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] - | otherwise = AcyclicSCC (vertex_fn v) - decode other = CyclicSCC (dec other []) - where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts - mentions_itself v = v `elem` (graph ! v) +stronglyConnCompG graph = decodeSccs graph $ scc (gr_int_graph graph) +decodeSccs :: Graph node -> [SCC Vertex] -> [SCC node] +decodeSccs Graph { gr_vertex_to_node = vertex_fn } + = map (fmap vertex_fn) -- The following two versions are provided for backwards compatibility: -- See Note [Deterministic SCC] @@ -333,7 +326,7 @@ => [Node key payload] -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesOrdR = - stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd + stronglyConnCompG . graphFromEdgedVerticesOrd -- The "R" interface is used when you expect to apply SCC to -- (some of) the result of SCC, so you don't want to lose the dependency info @@ -344,7 +337,7 @@ => [Node key payload] -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesUniqR = - stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq + stronglyConnCompG . graphFromEdgedVerticesUniq {- ************************************************************************ @@ -356,7 +349,7 @@ topologicalSortG :: Graph node -> [node] topologicalSortG graph = map (gr_vertex_to_node graph) result - where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph) + 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 @@ -376,22 +369,31 @@ 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. +-- dependencies. Only works on acyclic input. allReachable :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key) -allReachable (Graph g from _) conv = - M.fromList [(conv (from v), IS.foldr (\k vs -> conv (from k) `S.insert` vs) S.empty vs) - | (v, vs) <- IM.toList int_graph] +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 = reachableGraph g + 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) $ vertices (gr_int_graph graph) +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)) $ edges (gr_int_graph graph) +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 @@ -451,14 +453,64 @@ -- This generalizes reachable which was found in Data.Graph reachable :: IntGraph -> [Vertex] -> [Vertex] -reachable g vs = preorderF (dfs g vs) +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 <- vertices g] + 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) + {- ************************************************************************ * * @@ -547,3 +599,21 @@ ends'' = addToUFM ends' n time'' in (time'' + 1, starts'', ends'') + +graphFromVerticesAndAdjacency + :: Ord key + => [Node key payload] + -> [(key, key)] -- First component is source vertex key, + -- second is target vertex key (thing depended on) + -- Unlike the other interface I insist they correspond to + -- actual vertices because the alternative hides bugs. I can't + -- do the same thing for the other one for backcompat reasons. + -> Graph (Node key payload) +graphFromVerticesAndAdjacency [] _ = emptyGraph +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) + reduced_edges = map key_vertex_pair edges + graph = G.buildG bounds reduced_edges diff --git a/GHC/Data/Graph/Inductive/Graph.hs b/GHC/Data/Graph/Inductive/Graph.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Inductive/Graph.hs @@ -0,0 +1,643 @@ +-- (c) 1999-2005 by Martin Erwig (see copyright at bottom) +-- | Static and Dynamic Inductive Graphs +-- +-- Code is from Hackage `fgl` package version 5.7.0.3 +-- +module GHC.Data.Graph.Inductive.Graph ( + -- * General Type Defintions + -- ** Node and Edge Types + Node,LNode,UNode, + Edge,LEdge,UEdge, + -- ** Types Supporting Inductive Graph View + Adj,Context,MContext,Decomp,GDecomp,UContext,UDecomp, + Path,LPath(..),UPath, + -- * Graph Type Classes + -- | We define two graph classes: + -- + -- Graph: static, decomposable graphs. + -- Static means that a graph itself cannot be changed + -- + -- DynGraph: dynamic, extensible graphs. + -- Dynamic graphs inherit all operations from static graphs + -- but also offer operations to extend and change graphs. + -- + -- Each class contains in addition to its essential operations those + -- derived operations that might be overwritten by a more efficient + -- implementation in an instance definition. + -- + -- Note that labNodes is essentially needed because the default definition + -- for matchAny is based on it: we need some node from the graph to define + -- matchAny in terms of match. Alternatively, we could have made matchAny + -- essential and have labNodes defined in terms of ufold and matchAny. + -- However, in general, labNodes seems to be (at least) as easy to define + -- as matchAny. We have chosen labNodes instead of the function nodes since + -- nodes can be easily derived from labNodes, but not vice versa. + Graph(..), + DynGraph(..), + -- * Operations + order, + size, + -- ** Graph Folds and Maps + ufold,gmap,nmap,emap,nemap, + -- ** Graph Projection + nodes,edges,toEdge,edgeLabel,toLEdge,newNodes,gelem, + -- ** Graph Construction and Destruction + insNode,insEdge,delNode,delEdge,delLEdge,delAllLEdge, + insNodes,insEdges,delNodes,delEdges, + buildGr,mkUGraph, + -- ** Subgraphs + gfiltermap,nfilter,labnfilter,labfilter,subgraph, + -- ** Graph Inspection + context,lab,neighbors,lneighbors, + suc,pre,lsuc,lpre, + out,inn,outdeg,indeg,deg, + hasEdge,hasNeighbor,hasLEdge,hasNeighborAdj, + equal, + -- ** Context Inspection + node',lab',labNode',neighbors',lneighbors', + suc',pre',lpre',lsuc', + out',inn',outdeg',indeg',deg', + -- * Pretty-printing + prettify, + prettyPrint, + -- * Ordering of Graphs + OrdGr(..) +) where + +import GHC.Prelude + +import Control.Arrow (first) +import Data.Function (on) +import qualified Data.IntSet as IntSet +import Data.List (delete, groupBy, sort, sortBy, (\\)) +import Data.Maybe (fromMaybe, isJust) + +import GHC.Utils.Panic + +-- | Unlabeled node +type Node = Int +-- | Labeled node +type LNode a = (Node,a) +-- | Quasi-unlabeled node +type UNode = LNode () + +-- | Unlabeled edge +type Edge = (Node,Node) +-- | Labeled edge +type LEdge b = (Node,Node,b) +-- | Quasi-unlabeled edge +type UEdge = LEdge () + +-- | Unlabeled path +type Path = [Node] +-- | Labeled path +newtype LPath a = LP { unLPath :: [LNode a] } + +instance (Show a) => Show (LPath a) where + show (LP xs) = show xs + +instance (Eq a) => Eq (LPath a) where + (LP []) == (LP []) = True + (LP ((_,x):_)) == (LP ((_,y):_)) = x==y + (LP _) == (LP _) = False + +instance (Ord a) => Ord (LPath a) where + compare (LP []) (LP []) = EQ + compare (LP ((_,x):_)) (LP ((_,y):_)) = compare x y + compare _ _ = panic "LPath: cannot compare two empty paths" + +-- | Quasi-unlabeled path +type UPath = [UNode] + +-- | Labeled links to or from a 'Node'. +type Adj b = [(b,Node)] +-- | Links to the 'Node', the 'Node' itself, a label, links from the 'Node'. +-- +-- In other words, this captures all information regarding the +-- specified 'Node' within a graph. +type Context a b = (Adj b,Node,a,Adj b) -- Context a b "=" Context' a b "+" Node +type MContext a b = Maybe (Context a b) +-- | 'Graph' decomposition - the context removed from a 'Graph', and the rest +-- of the 'Graph'. +type Decomp g a b = (MContext a b,g a b) +-- | The same as 'Decomp', only more sure of itself. +type GDecomp g a b = (Context a b,g a b) + +-- | Unlabeled context. +type UContext = ([Node],Node,[Node]) +-- | Unlabeled decomposition. +type UDecomp g = (Maybe UContext,g) + +-- | Minimum implementation: 'empty', 'isEmpty', 'match', 'mkGraph', 'labNodes' +class Graph gr where + {-# MINIMAL empty, isEmpty, match, mkGraph, labNodes #-} + + -- | An empty 'Graph'. + empty :: gr a b + + -- | True if the given 'Graph' is empty. + isEmpty :: gr a b -> Bool + + -- | Decompose a 'Graph' into the 'MContext' found for the given node and the + -- remaining 'Graph'. + match :: Node -> gr a b -> Decomp gr a b + + -- | Create a 'Graph' from the list of 'LNode's and 'LEdge's. + -- + -- For graphs that are also instances of 'DynGraph', @mkGraph ns + -- es@ should be equivalent to @('insEdges' es . 'insNodes' ns) + -- 'empty'@. + mkGraph :: [LNode a] -> [LEdge b] -> gr a b + + -- | A list of all 'LNode's in the 'Graph'. + labNodes :: gr a b -> [LNode a] + + -- | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node' + -- and the remaining 'Graph'. + matchAny :: gr a b -> GDecomp gr a b + matchAny g = case labNodes g of + [] -> panic "Match Exception, Empty Graph" + (v,_):_ | (Just c,g') <- match v g -> (c,g') + _ -> panic "This can't happen: failed to match node in graph" + + + -- | The number of 'Node's in a 'Graph'. + noNodes :: gr a b -> Int + noNodes = length . labNodes + + -- | 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 + + -- | A list of all 'LEdge's in the 'Graph'. + labEdges :: gr a b -> [LEdge b] + labEdges = ufold (\(_,v,_,s)->(map (\(l,w)->(v,w,l)) s ++)) [] + +class (Graph gr) => DynGraph gr where + -- | Merge the 'Context' into the 'DynGraph'. + -- + -- Context adjacencies should only refer to either a Node already + -- in a graph or the node in the Context itself (for loops). + -- + -- Behaviour is undefined if the specified 'Node' already exists + -- in the graph. + (&) :: Context a b -> gr a b -> gr a b + + +-- | The number of nodes in the graph. An alias for 'noNodes'. +order :: (Graph gr) => gr a b -> Int +order = noNodes + +-- | The number of edges in the graph. +-- +-- Note that this counts every edge found, so if you are +-- representing an unordered graph by having each edge mirrored this +-- will be incorrect. +-- +-- If you created an unordered graph by either mirroring every edge +-- (including loops!) or using the @undir@ function in +-- "Data.Graph.Inductive.Basic" then you can safely halve the value +-- returned by this. +size :: (Graph gr) => gr a b -> Int +size = length . labEdges + +-- | Fold a function over the graph by recursively calling 'match'. +ufold :: (Graph gr) => (Context a b -> c -> c) -> c -> gr a b -> c +ufold f u g + | isEmpty g = u + | otherwise = f c (ufold f u g') + where + (c,g') = matchAny g + +-- | Map a function over the graph by recursively calling 'match'. +gmap :: (DynGraph gr) => (Context a b -> Context c d) -> gr a b -> gr c d +gmap f = ufold (\c->(f c&)) empty +{-# NOINLINE [0] gmap #-} + +-- | Map a function over the 'Node' labels in a graph. +nmap :: (DynGraph gr) => (a -> c) -> gr a b -> gr c b +nmap f = gmap (\(p,v,l,s)->(p,v,f l,s)) +{-# NOINLINE [0] nmap #-} + +-- | Map a function over the 'Edge' labels in a graph. +emap :: (DynGraph gr) => (b -> c) -> gr a b -> gr a c +emap f = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s)) + where + map1 g = map (first g) +{-# NOINLINE [0] emap #-} + +-- | Map functions over both the 'Node' and 'Edge' labels in a graph. +nemap :: (DynGraph gr) => (a -> c) -> (b -> d) -> gr a b -> gr c d +nemap fn fe = gmap (\(p,v,l,s) -> (fe' p,v,fn l,fe' s)) + where + fe' = map (first fe) +{-# NOINLINE [0] nemap #-} + +-- | List all 'Node's in the 'Graph'. +nodes :: (Graph gr) => gr a b -> [Node] +nodes = map fst . labNodes + +-- | List all 'Edge's in the 'Graph'. +edges :: (Graph gr) => gr a b -> [Edge] +edges = map toEdge . labEdges + +-- | Drop the label component of an edge. +toEdge :: LEdge b -> Edge +toEdge (v,w,_) = (v,w) + +-- | Add a label to an edge. +toLEdge :: Edge -> b -> LEdge b +toLEdge (v,w) l = (v,w,l) + +-- | The label in an edge. +edgeLabel :: LEdge b -> b +edgeLabel (_,_,l) = l + +-- | List N available 'Node's, i.e. 'Node's that are not used in the 'Graph'. +newNodes :: (Graph gr) => Int -> gr a b -> [Node] +newNodes i g + | isEmpty g = [0..i-1] + | otherwise = [n+1..n+i] + where + (_,n) = nodeRange g + +-- | 'True' if the 'Node' is present in the 'Graph'. +gelem :: (Graph gr) => Node -> gr a b -> Bool +gelem v = isJust . fst . match v + +-- | Insert a 'LNode' into the 'Graph'. +insNode :: (DynGraph gr) => LNode a -> gr a b -> gr a b +insNode (v,l) = (([],v,l,[])&) +{-# NOINLINE [0] insNode #-} + +-- | Insert a 'LEdge' into the 'Graph'. +insEdge :: (DynGraph gr) => LEdge b -> gr a b -> gr a b +insEdge (v,w,l) g = (pr,v,la,(l,w):su) & g' + where + (mcxt,g') = match v g + (pr,_,la,su) = fromMaybe + (panic ("insEdge: cannot add edge from non-existent vertex " ++ show v)) + mcxt +{-# NOINLINE [0] insEdge #-} + +-- | Remove a 'Node' from the 'Graph'. +delNode :: (Graph gr) => Node -> gr a b -> gr a b +delNode v = delNodes [v] + +-- | Remove an 'Edge' from the 'Graph'. +-- +-- NOTE: in the case of multiple edges, this will delete /all/ such +-- edges from the graph as there is no way to distinguish between +-- them. If you need to delete only a single such edge, please use +-- 'delLEdge'. +delEdge :: (DynGraph gr) => Edge -> gr a b -> gr a b +delEdge (v,w) g = case match v g of + (Nothing,_) -> g + (Just (p,v',l,s),g') -> (p,v',l,filter ((/=w).snd) s) & g' + +-- | Remove an 'LEdge' from the 'Graph'. +-- +-- NOTE: in the case of multiple edges with the same label, this +-- will only delete the /first/ such edge. To delete all such +-- edges, please use 'delAllLedge'. +delLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b +delLEdge = delLEdgeBy delete + +-- | Remove all edges equal to the one specified. +delAllLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b +delAllLEdge = delLEdgeBy (filter . (/=)) + +delLEdgeBy :: (DynGraph gr) => ((b,Node) -> Adj b -> Adj b) + -> LEdge b -> gr a b -> gr a b +delLEdgeBy f (v,w,b) g = case match v g of + (Nothing,_) -> g + (Just (p,v',l,s),g') -> (p,v',l,f (b,w) s) & g' + +-- | Insert multiple 'LNode's into the 'Graph'. +insNodes :: (DynGraph gr) => [LNode a] -> gr a b -> gr a b +insNodes vs g = foldl' (flip insNode) g vs +{-# INLINABLE insNodes #-} + +-- | Insert multiple 'LEdge's into the 'Graph'. +insEdges :: (DynGraph gr) => [LEdge b] -> gr a b -> gr a b +insEdges es g = foldl' (flip insEdge) g es +{-# INLINABLE insEdges #-} + +-- | Remove multiple 'Node's from the 'Graph'. +delNodes :: (Graph gr) => [Node] -> gr a b -> gr a b +delNodes vs g = foldl' (snd .: flip match) g vs + +-- | Remove multiple 'Edge's from the 'Graph'. +delEdges :: (DynGraph gr) => [Edge] -> gr a b -> gr a b +delEdges es g = foldl' (flip delEdge) g es + +-- | Build a 'Graph' from a list of 'Context's. +-- +-- The list should be in the order such that earlier 'Context's +-- depend upon later ones (i.e. as produced by @'ufold' (:) []@). +buildGr :: (DynGraph gr) => [Context a b] -> gr a b +buildGr = foldr (&) empty + +-- | Build a quasi-unlabeled 'Graph'. +mkUGraph :: (Graph gr) => [Node] -> [Edge] -> gr () () +mkUGraph vs es = mkGraph (labUNodes vs) (labUEdges es) + where + labUEdges = map (`toLEdge` ()) + labUNodes = map (flip (,) ()) + +-- | Build a graph out of the contexts for which the predicate is +-- satisfied by recursively calling 'match'. +gfiltermap :: DynGraph gr => (Context a b -> MContext c d) -> gr a b -> gr c d +gfiltermap f = ufold (maybe id (&) . f) empty + +-- | Returns the subgraph only containing the labelled nodes which +-- satisfy the given predicate. +labnfilter :: Graph gr => (LNode a -> Bool) -> gr a b -> gr a b +labnfilter p gr = delNodes (map fst . filter (not . p) $ labNodes gr) gr + +-- | Returns the subgraph only containing the nodes which satisfy the +-- given predicate. +nfilter :: DynGraph gr => (Node -> Bool) -> gr a b -> gr a b +nfilter f = labnfilter (f . fst) + +-- | Returns the subgraph only containing the nodes whose labels +-- satisfy the given predicate. +labfilter :: DynGraph gr => (a -> Bool) -> gr a b -> gr a b +labfilter f = labnfilter (f . snd) + +-- | Returns the subgraph induced by the supplied nodes. +subgraph :: DynGraph gr => [Node] -> gr a b -> gr a b +subgraph vs = let vs' = IntSet.fromList vs + in nfilter (`IntSet.member` vs') + +-- | Find the context for the given 'Node'. Causes an error if the 'Node' is +-- not present in the 'Graph'. +context :: (Graph gr) => gr a b -> Node -> Context a b +context g v = fromMaybe (panic ("Match Exception, Node: "++show v)) + (fst (match v g)) + +-- | Find the label for a 'Node'. +lab :: (Graph gr) => gr a b -> Node -> Maybe a +lab g v = fmap lab' . fst $ match v g + +-- | Find the neighbors for a 'Node'. +neighbors :: (Graph gr) => gr a b -> Node -> [Node] +neighbors = map snd .: lneighbors + +-- | Find the labelled links coming into or going from a 'Context'. +lneighbors :: (Graph gr) => gr a b -> Node -> Adj b +lneighbors = maybe [] lneighbors' .: mcontext + +-- | Find all 'Node's that have a link from the given 'Node'. +suc :: (Graph gr) => gr a b -> Node -> [Node] +suc = map snd .: context4l + +-- | Find all 'Node's that link to to the given 'Node'. +pre :: (Graph gr) => gr a b -> Node -> [Node] +pre = map snd .: context1l + +-- | Find all 'Node's that are linked from the given 'Node' and the label of +-- each link. +lsuc :: (Graph gr) => gr a b -> Node -> [(Node,b)] +lsuc = map flip2 .: context4l + +-- | Find all 'Node's that link to the given 'Node' and the label of each link. +lpre :: (Graph gr) => gr a b -> Node -> [(Node,b)] +lpre = map flip2 .: context1l + +-- | Find all outward-bound 'LEdge's for the given 'Node'. +out :: (Graph gr) => gr a b -> Node -> [LEdge b] +out g v = map (\(l,w)->(v,w,l)) (context4l g v) + +-- | Find all inward-bound 'LEdge's for the given 'Node'. +inn :: (Graph gr) => gr a b -> Node -> [LEdge b] +inn g v = map (\(l,w)->(w,v,l)) (context1l g v) + +-- | The outward-bound degree of the 'Node'. +outdeg :: (Graph gr) => gr a b -> Node -> Int +outdeg = length .: context4l + +-- | The inward-bound degree of the 'Node'. +indeg :: (Graph gr) => gr a b -> Node -> Int +indeg = length .: context1l + +-- | The degree of the 'Node'. +deg :: (Graph gr) => gr a b -> Node -> Int +deg = deg' .: context + +-- | The 'Node' in a 'Context'. +node' :: Context a b -> Node +node' (_,v,_,_) = v + +-- | The label in a 'Context'. +lab' :: Context a b -> a +lab' (_,_,l,_) = l + +-- | The 'LNode' from a 'Context'. +labNode' :: Context a b -> LNode a +labNode' (_,v,l,_) = (v,l) + +-- | All 'Node's linked to or from in a 'Context'. +neighbors' :: Context a b -> [Node] +neighbors' (p,_,_,s) = map snd p++map snd s + +-- | All labelled links coming into or going from a 'Context'. +lneighbors' :: Context a b -> Adj b +lneighbors' (p,_,_,s) = p ++ s + +-- | All 'Node's linked to in a 'Context'. +suc' :: Context a b -> [Node] +suc' = map snd . context4l' + +-- | All 'Node's linked from in a 'Context'. +pre' :: Context a b -> [Node] +pre' = map snd . context1l' + +-- | All 'Node's linked from in a 'Context', and the label of the links. +lsuc' :: Context a b -> [(Node,b)] +lsuc' = map flip2 . context4l' + +-- | All 'Node's linked from in a 'Context', and the label of the links. +lpre' :: Context a b -> [(Node,b)] +lpre' = map flip2 . context1l' + +-- | All outward-directed 'LEdge's in a 'Context'. +out' :: Context a b -> [LEdge b] +out' c@(_,v,_,_) = map (\(l,w)->(v,w,l)) (context4l' c) + +-- | All inward-directed 'LEdge's in a 'Context'. +inn' :: Context a b -> [LEdge b] +inn' c@(_,v,_,_) = map (\(l,w)->(w,v,l)) (context1l' c) + +-- | The outward degree of a 'Context'. +outdeg' :: Context a b -> Int +outdeg' = length . context4l' + +-- | The inward degree of a 'Context'. +indeg' :: Context a b -> Int +indeg' = length . context1l' + +-- | The degree of a 'Context'. +deg' :: Context a b -> Int +deg' (p,_,_,s) = length p+length s + +-- | Checks if there is a directed edge between two nodes. +hasEdge :: Graph gr => gr a b -> Edge -> Bool +hasEdge gr (v,w) = w `elem` suc gr v + +-- | Checks if there is an undirected edge between two nodes. +hasNeighbor :: Graph gr => gr a b -> Node -> Node -> Bool +hasNeighbor gr v w = w `elem` neighbors gr v + +-- | Checks if there is a labelled edge between two nodes. +hasLEdge :: (Graph gr, Eq b) => gr a b -> LEdge b -> Bool +hasLEdge gr (v,w,l) = (w,l) `elem` lsuc gr v + +-- | Checks if there is an undirected labelled edge between two nodes. +hasNeighborAdj :: (Graph gr, Eq b) => gr a b -> Node -> (b,Node) -> Bool +hasNeighborAdj gr v a = a `elem` lneighbors gr v + +---------------------------------------------------------------------- +-- GRAPH EQUALITY +---------------------------------------------------------------------- + +slabNodes :: (Graph gr) => gr a b -> [LNode a] +slabNodes = sortBy (compare `on` fst) . labNodes + +glabEdges :: (Graph gr) => gr a b -> [GroupEdges b] +glabEdges = map (GEs . groupLabels) + . groupBy ((==) `on` toEdge) + . sortBy (compare `on` toEdge) + . labEdges + where + groupLabels les = toLEdge (toEdge (head les)) (map edgeLabel les) + +equal :: (Eq a,Eq b,Graph gr) => gr a b -> gr a b -> Bool +equal g g' = slabNodes g == slabNodes g' && glabEdges g == glabEdges g' +-- This assumes that nodes aren't repeated (which shouldn't happen for +-- sane graph instances). If node IDs are repeated, then the usage of +-- slabNodes cannot guarantee stable ordering. + +-- Newtype wrapper just to test for equality of multiple edges. This +-- is needed because without an Ord constraint on `b' it is not +-- possible to guarantee a stable ordering on edge labels. +newtype GroupEdges b = GEs (LEdge [b]) + deriving (Show, Read) + +instance (Eq b) => Eq (GroupEdges b) where + (GEs (v1,w1,bs1)) == (GEs (v2,w2,bs2)) = v1 == v2 + && w1 == w2 + && eqLists bs1 bs2 + +eqLists :: (Eq a) => [a] -> [a] -> Bool +eqLists xs ys = null (xs \\ ys) && null (ys \\ xs) +-- OK to use \\ here as we want each value in xs to cancel a *single* +-- value in ys. + +---------------------------------------------------------------------- +-- UTILITIES +---------------------------------------------------------------------- + +-- auxiliary functions used in the implementation of the +-- derived class members +-- +(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d +-- f .: g = \x y->f (g x y) +-- f .: g = (f .) . g +-- (.:) f = ((f .) .) +-- (.:) = (.) (.) (.) +(.:) = (.) . (.) + +flip2 :: (a,b) -> (b,a) +flip2 (x,y) = (y,x) + +-- projecting on context elements +-- +context1l :: (Graph gr) => gr a b -> Node -> Adj b +context1l = maybe [] context1l' .: mcontext + +context4l :: (Graph gr) => gr a b -> Node -> Adj b +context4l = maybe [] context4l' .: mcontext + +mcontext :: (Graph gr) => gr a b -> Node -> MContext a b +mcontext = fst .: flip match + +context1l' :: Context a b -> Adj b +context1l' (p,v,_,s) = p++filter ((==v).snd) s + +context4l' :: Context a b -> Adj b +context4l' (p,v,_,s) = s++filter ((==v).snd) p + +---------------------------------------------------------------------- +-- PRETTY PRINTING +---------------------------------------------------------------------- + +-- | Pretty-print the graph. Note that this loses a lot of +-- information, such as edge inverses, etc. +prettify :: (DynGraph gr, Show a, Show b) => gr a b -> String +prettify g = foldr (showsContext . context g) id (nodes g) "" + where + showsContext (_,n,l,s) sg = shows n . (':':) . shows l + . showString "->" . shows s + . ('\n':) . sg + +-- | Pretty-print the graph to stdout. +prettyPrint :: (DynGraph gr, Show a, Show b) => gr a b -> IO () +prettyPrint = putStr . prettify + +---------------------------------------------------------------------- +-- Ordered Graph +---------------------------------------------------------------------- + +-- | OrdGr comes equipped with an Ord instance, so that graphs can be +-- used as e.g. Map keys. +newtype OrdGr gr a b = OrdGr { unOrdGr :: gr a b } + deriving (Read,Show) + +instance (Graph gr, Ord a, Ord b) => Eq (OrdGr gr a b) where + g1 == g2 = compare g1 g2 == EQ + +instance (Graph gr, Ord a, Ord b) => Ord (OrdGr gr a b) where + compare (OrdGr g1) (OrdGr g2) = + (compare `on` sort . labNodes) g1 g2 + `mappend` (compare `on` sort . labEdges) g1 g2 + + +{----------------------------------------------------------------- + +Copyright (c) 1999-2008, Martin Erwig + 2010, Ivan Lazar Miljenovic + 2022, Norman Ramsey +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +----------------------------------------------------------------} diff --git a/GHC/Data/Graph/Inductive/PatriciaTree.hs b/GHC/Data/Graph/Inductive/PatriciaTree.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Graph/Inductive/PatriciaTree.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} + +-- |An efficient implementation of 'Data.Graph.Inductive.Graph.Graph' +-- using big-endian patricia tree (i.e. "Data.IntMap"). +-- +-- This module provides the following specialised functions to gain +-- more performance, using GHC's RULES pragma: +-- +-- * 'Data.Graph.Inductive.Graph.insNode' +-- +-- * 'Data.Graph.Inductive.Graph.insEdge' +-- +-- * 'Data.Graph.Inductive.Graph.gmap' +-- +-- * 'Data.Graph.Inductive.Graph.nmap' +-- +-- * 'Data.Graph.Inductive.Graph.emap' +-- +-- Code is from Hackage `fgl` package version 5.7.0.3 + + +module GHC.Data.Graph.Inductive.PatriciaTree + ( Gr + , UGr + ) + where + +import GHC.Prelude + +import GHC.Data.Graph.Inductive.Graph + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.List (sort) +import Data.Maybe (fromMaybe) +import Data.Tuple (swap) + +import qualified Data.IntMap.Strict as IMS + +import GHC.Generics (Generic) + +import Data.Bifunctor + +---------------------------------------------------------------------- +-- GRAPH REPRESENTATION +---------------------------------------------------------------------- + +newtype Gr a b = Gr (GraphRep a b) + deriving (Generic) + +type GraphRep a b = IntMap (Context' a b) +type Context' a b = (IntMap [b], a, IntMap [b]) + +type UGr = Gr () () + +---------------------------------------------------------------------- +-- CLASS INSTANCES +---------------------------------------------------------------------- + +instance (Eq a, Ord b) => Eq (Gr a b) where + (Gr g1) == (Gr g2) = fmap sortAdj g1 == fmap sortAdj g2 + where + sortAdj (p,n,s) = (fmap sort p,n,fmap sort s) + +instance (Show a, Show b) => Show (Gr a b) where + showsPrec d g = showParen (d > 10) $ + showString "mkGraph " + . shows (labNodes g) + . showString " " + . shows (labEdges g) + +instance (Read a, Read b) => Read (Gr a b) where + readsPrec p = readParen (p > 10) $ \ r -> do + ("mkGraph", s) <- lex r + (ns,t) <- reads s + (es,u) <- reads t + return (mkGraph ns es, u) + +instance Graph Gr where + empty = Gr IM.empty + + isEmpty (Gr g) = IM.null g + + match = matchGr + + mkGraph vs es = insEdges es + . Gr + . IM.fromList + . map (second (\l -> (IM.empty,l,IM.empty))) + $ vs + + labNodes (Gr g) = [ (node, label) + | (node, (_, label, _)) <- IM.toList g ] + + noNodes (Gr g) = IM.size g + + nodeRange (Gr g) = fromMaybe (error "nodeRange of empty graph") + $ liftA2 (,) (ix (IM.minViewWithKey g)) + (ix (IM.maxViewWithKey g)) + where + ix = fmap (fst . fst) + + labEdges (Gr g) = do (node, (_, _, s)) <- IM.toList g + (next, labels) <- IM.toList s + label <- labels + return (node, next, label) + +instance DynGraph Gr where + (p, v, l, s) & (Gr g) + = let !g1 = IM.insert v (preds, l, succs) g + !(np, preds) = fromAdjCounting p + !(ns, succs) = fromAdjCounting s + !g2 = addSucc g1 v np preds + !g3 = addPred g2 v ns succs + in Gr g3 + + +instance Functor (Gr a) where + fmap = fastEMap + +instance Bifunctor Gr where + bimap = fastNEMap + + first = fastNMap + + second = fastEMap + + +matchGr :: Node -> Gr a b -> Decomp Gr a b +matchGr node (Gr g) + = case IM.lookup node g of + Nothing + -> (Nothing, Gr g) + + Just (p, label, s) + -> let !g1 = IM.delete node g + !p' = IM.delete node p + !s' = IM.delete node s + !g2 = clearPred g1 node s' + !g3 = clearSucc g2 node p' + in (Just (toAdj p', node, label, toAdj s), Gr g3) + +---------------------------------------------------------------------- +-- OVERRIDING FUNCTIONS +---------------------------------------------------------------------- + +{- + +{- RULES + "insNode/Data.Graph.Inductive.PatriciaTree" insNode = fastInsNode + -} +fastInsNode :: LNode a -> Gr a b -> Gr a b +fastInsNode (v, l) (Gr g) = g' `seq` Gr g' + where + g' = IM.insert v (IM.empty, l, IM.empty) g + +-} +{-# RULES + "insEdge/GHC.Data.Graph.Inductive.PatriciaTree" insEdge = fastInsEdge + #-} +fastInsEdge :: LEdge b -> Gr a b -> Gr a b +fastInsEdge (v, w, l) (Gr g) = g2 `seq` Gr g2 + where + g1 = IM.adjust addS' v g + g2 = IM.adjust addP' w g1 + + addS' (ps, l', ss) = (ps, l', IM.insertWith addLists w [l] ss) + addP' (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss) + +{- + +{- RULES + "gmap/Data.Graph.Inductive.PatriciaTree" gmap = fastGMap + -} +fastGMap :: forall a b c d. (Context a b -> Context c d) -> Gr a b -> Gr c d +fastGMap f (Gr g) = Gr (IM.mapWithKey f' g) + where + f' :: Node -> Context' a b -> Context' c d + f' = ((fromContext . f) .) . toContext + +{- RULES + "nmap/Data.Graph.Inductive.PatriciaTree" nmap = fastNMap + -} +-} +fastNMap :: forall a b c. (a -> c) -> Gr a b -> Gr c b +fastNMap f (Gr g) = Gr (IM.map f' g) + where + f' :: Context' a b -> Context' c b + f' (ps, a, ss) = (ps, f a, ss) +{- + +{- RULES + "emap/GHC.Data.Graph.Inductive.PatriciaTree" emap = fastEMap + -} +-} +fastEMap :: forall a b c. (b -> c) -> Gr a b -> Gr a c +fastEMap f (Gr g) = Gr (IM.map f' g) + where + f' :: Context' a b -> Context' a c + f' (ps, a, ss) = (IM.map (map f) ps, a, IM.map (map f) ss) + +{- RULES + "nemap/GHC.Data.Graph.Inductive.PatriciaTree" nemap = fastNEMap + -} + +fastNEMap :: forall a b c d. (a -> c) -> (b -> d) -> Gr a b -> Gr c d +fastNEMap fn fe (Gr g) = Gr (IM.map f g) + where + f :: Context' a b -> Context' c d + f (ps, a, ss) = (IM.map (map fe) ps, fn a, IM.map (map fe) ss) + + + +---------------------------------------------------------------------- +-- UTILITIES +---------------------------------------------------------------------- + +toAdj :: IntMap [b] -> Adj b +toAdj = concatMap expand . IM.toList + where + expand (n,ls) = map (flip (,) n) ls + +--fromAdj :: Adj b -> IntMap [b] +--fromAdj = IM.fromListWith addLists . map (second (:[]) . swap) + +data FromListCounting a = FromListCounting !Int !(IntMap a) + deriving (Eq, Show, Read) + +getFromListCounting :: FromListCounting a -> (Int, IntMap a) +getFromListCounting (FromListCounting i m) = (i, m) +{-# INLINE getFromListCounting #-} + +fromListWithKeyCounting :: (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a) +fromListWithKeyCounting f = getFromListCounting . foldl' ins (FromListCounting 0 IM.empty) + where + ins (FromListCounting i t) (k,x) = FromListCounting (i + 1) (IM.insertWithKey f k x t) +{-# INLINE fromListWithKeyCounting #-} + +fromListWithCounting :: (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a) +fromListWithCounting f = fromListWithKeyCounting (\_ x y -> f x y) +{-# INLINE fromListWithCounting #-} + +fromAdjCounting :: Adj b -> (Int, IntMap [b]) +fromAdjCounting = fromListWithCounting addLists . map (second (:[]) . swap) + +-- We use differenceWith to modify a graph more than bulkThreshold times, +-- and repeated insertWith otherwise. +bulkThreshold :: Int +bulkThreshold = 5 + +--toContext :: Node -> Context' a b -> Context a b +--toContext v (ps, a, ss) = (toAdj ps, v, a, toAdj ss) + +--fromContext :: Context a b -> Context' a b +--fromContext (ps, _, a, ss) = (fromAdj ps, a, fromAdj ss) + +-- A version of @++@ where order isn't important, so @xs ++ [x]@ +-- becomes @x:xs@. Used when we have to have a function of type @[a] +-- -> [a] -> [a]@ but one of the lists is just going to be a single +-- element (and it isn't possible to tell which). +addLists :: [a] -> [a] -> [a] +addLists [a] as = a : as +addLists as [a] = a : as +addLists xs ys = xs ++ ys + +addSucc :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b +addSucc g0 v numAdd xs + | numAdd < bulkThreshold = foldlWithKey' go g0 xs + where + go :: GraphRep a b -> Node -> [b] -> GraphRep a b + go g p l = IMS.adjust f p g + where f (ps, l', ss) = let !ss' = IM.insertWith addLists v l ss + in (ps, l', ss') +addSucc g v _ xs = IMS.differenceWith go g xs + where + go :: Context' a b -> [b] -> Maybe (Context' a b) + go (ps, l', ss) l = let !ss' = IM.insertWith addLists v l ss + in Just (ps, l', ss') + +foldlWithKey' :: (a -> IM.Key -> b -> a) -> a -> IntMap b -> a +foldlWithKey' = + IM.foldlWithKey' + +addPred :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b +addPred g0 v numAdd xs + | numAdd < bulkThreshold = foldlWithKey' go g0 xs + where + go :: GraphRep a b -> Node -> [b] -> GraphRep a b + go g p l = IMS.adjust f p g + where f (ps, l', ss) = let !ps' = IM.insertWith addLists v l ps + in (ps', l', ss) +addPred g v _ xs = IMS.differenceWith go g xs + where + go :: Context' a b -> [b] -> Maybe (Context' a b) + go (ps, l', ss) l = let !ps' = IM.insertWith addLists v l ps + in Just (ps', l', ss) + +clearSucc :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b +clearSucc g v = IMS.differenceWith go g + where + go :: Context' a b -> x -> Maybe (Context' a b) + go (ps, l, ss) _ = let !ss' = IM.delete v ss + in Just (ps, l, ss') + +clearPred :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b +clearPred g v = IMS.differenceWith go g + where + go :: Context' a b -> x -> Maybe (Context' a b) + go (ps, l, ss) _ = let !ps' = IM.delete v ps + in Just (ps', l, ss) + +{----------------------------------------------------------------- + +Copyright (c) 1999-2008, Martin Erwig + 2010, Ivan Lazar Miljenovic + 2022, Norman Ramsey +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +----------------------------------------------------------------} diff --git a/GHC/Data/Graph/Ops.hs b/GHC/Data/Graph/Ops.hs --- a/GHC/Data/Graph/Ops.hs +++ b/GHC/Data/Graph/Ops.hs @@ -253,7 +253,7 @@ -- | Add a coalescence edge to the graph, creating nodes if required. --- It is considered adventageous to assign the same color to nodes in a coalesence. +-- It is considered advantageous to assign the same color to nodes in a coalescence. addCoalesce :: Uniquable k => (k, cls) -> (k, cls) @@ -491,7 +491,7 @@ = if elementOfUniqSet k (nodeCoalesce node) then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k } else node -- panic "GHC.Data.Graph.Ops.freezeNode: edge to freeze wasn't in the coalesce set" - -- If the edge isn't actually in the coelesce set then just ignore it. + -- If the edge isn't actually in the coalesce set then just ignore it. fm2 = nonDetStrictFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1 -- It's OK to use a non-deterministic fold here because the @@ -609,7 +609,7 @@ $ nonDetEltsUFM $ graphMap graph , not $ null badNodes = pprPanic "GHC.Data.Graph.Ops.validateGraph" - ( text "Supposably colored graph has uncolored nodes." + ( text "Supposedly colored graph has uncolored nodes." $$ text " uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes) $$ doc ) @@ -633,7 +633,7 @@ $ nonDetEltsUniqSet $ nodeConflicts node -- See Note [Unique Determinism and code generation] - , neighbourColors <- catMaybes $ map nodeColor neighbors + , neighbourColors <- mapMaybe nodeColor neighbors , elem color neighbourColors = False diff --git a/GHC/Data/Graph/UnVar.hs b/GHC/Data/Graph/UnVar.hs --- a/GHC/Data/Graph/UnVar.hs +++ b/GHC/Data/Graph/UnVar.hs @@ -16,7 +16,7 @@ -} module GHC.Data.Graph.UnVar ( UnVarSet - , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets + , emptyUnVarSet, mkUnVarSet, unionUnVarSet, unionUnVarSets , extendUnVarSet, extendUnVarSetList, delUnVarSet, delUnVarSetList , elemUnVarSet, isEmptyUnVarSet , UnVarGraph @@ -26,13 +26,13 @@ , neighbors , hasLoopAt , delNode + , domUFMUnVarSet ) where import GHC.Prelude -import GHC.Types.Id -import GHC.Types.Var.Env -import GHC.Types.Unique.FM +import GHC.Types.Unique.FM( UniqFM, ufmToSet_Directly ) +import GHC.Types.Var import GHC.Utils.Outputable import GHC.Types.Unique @@ -43,13 +43,16 @@ -- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet. -- Therefore, use a IntSet directly (which is likely also a bit more efficient). --- Set of uniques, i.e. for adjancet nodes +-- Set of uniques, i.e. for adjacent nodes newtype UnVarSet = UnVarSet (S.IntSet) deriving Eq k :: Var -> Int k v = getKey (getUnique v) +domUFMUnVarSet :: UniqFM key elt -> UnVarSet +domUFMUnVarSet ae = UnVarSet $ ufmToSet_Directly ae + emptyUnVarSet :: UnVarSet emptyUnVarSet = UnVarSet S.empty @@ -74,9 +77,6 @@ mkUnVarSet :: [Var] -> UnVarSet mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs - -varEnvDom :: VarEnv a -> UnVarSet -varEnvDom ae = UnVarSet $ ufmToSet_Directly ae extendUnVarSet :: Var -> UnVarSet -> UnVarSet extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s diff --git a/GHC/Data/List/Infinite.hs b/GHC/Data/List/Infinite.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/List/Infinite.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE RankNTypes #-} + +module GHC.Data.List.Infinite + ( Infinite (..) + , head, tail + , filter + , (++) + , unfoldr + , (!!) + , groupBy + , dropList + , iterate + , concatMap + , allListsOf + , toList + , repeat + ) where + +import Prelude ((-), Applicative (..), Bool (..), Foldable, Functor (..), Int, Maybe (..), 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) + +data Infinite a = Inf a (Infinite a) + deriving (Foldable, Functor, Traversable) + +head :: Infinite a -> a +head (Inf a _) = a +{-# NOINLINE [1] head #-} + +tail :: Infinite a -> Infinite a +tail (Inf _ as) = as +{-# NOINLINE [1] tail #-} + +{-# RULES +"head/build" forall (g :: forall b . (a -> b -> b) -> b) . head (build g) = g \ x _ -> x + #-} + +instance Applicative Infinite where + pure = repeat + Inf f fs <*> Inf a as = Inf (f a) (fs <*> as) + +mapMaybe :: (a -> Maybe b) -> Infinite a -> Infinite b +mapMaybe f = go + where + go (Inf a as) = let bs = go as in case f a of + Nothing -> bs + Just b -> Inf b bs +{-# NOINLINE [1] mapMaybe #-} + +{-# RULES +"mapMaybe" [~1] forall f as . mapMaybe f as = build \ c -> foldr (mapMaybeFB c f) as +"mapMaybeList" [1] forall f . foldr (mapMaybeFB Inf f) = mapMaybe f + #-} + +{-# INLINE [0] mapMaybeFB #-} +mapMaybeFB :: (b -> r -> r) -> (a -> Maybe b) -> a -> r -> r +mapMaybeFB cons f a bs = case f a of + Nothing -> bs + Just r -> cons r bs + +filter :: (a -> Bool) -> Infinite a -> Infinite a +filter f = mapMaybe (\ a -> a <$ guard (f a)) +{-# INLINE filter #-} + +infixr 5 ++ +(++) :: Foldable f => f a -> Infinite a -> Infinite a +(++) = flip (F.foldr Inf) + +unfoldr :: (b -> (a, b)) -> b -> Infinite a +unfoldr f b = build \ c -> let go b = case f b of (a, b') -> a `c` go b' in go b +{-# INLINE unfoldr #-} + +(!!) :: Infinite a -> Int -> a +Inf a _ !! 0 = a +Inf _ as !! n = as !! (n-1) + +groupBy :: (a -> a -> Bool) -> Infinite a -> Infinite (NonEmpty a) +groupBy eq = go + where + go (Inf a as) = Inf (a:|bs) (go cs) + where (bs, cs) = span (eq a) as + +span :: (a -> Bool) -> Infinite a -> ([a], Infinite a) +span p = spanJust (\ a -> a <$ guard (p a)) +{-# INLINE span #-} + +spanJust :: (a -> Maybe b) -> Infinite a -> ([b], Infinite a) +spanJust p = go + where + go as@(Inf a as') + | Just b <- p a = let (bs, cs) = go as' in (b:bs, cs) + | otherwise = ([], as) + +iterate :: (a -> a) -> a -> Infinite a +iterate f = go where go a = Inf a (go (f a)) +{-# NOINLINE [1] iterate #-} + +{-# RULES +"iterate" [~1] forall f a . iterate f a = build (\ c -> iterateFB c f a) +"iterateFB" [1] iterateFB Inf = iterate + #-} + +iterateFB :: (a -> b -> b) -> (a -> a) -> a -> b +iterateFB c f a = go a + where go a = a `c` go (f a) +{-# INLINE [0] iterateFB #-} + +concatMap :: Foldable f => (a -> f b) -> Infinite a -> Infinite b +concatMap f = go where go (Inf a as) = f a ++ go as +{-# NOINLINE [1] concatMap #-} + +{-# RULES "concatMap" forall f as . concatMap f as = build \ c -> foldr (\ x b -> F.foldr c b (f x)) as #-} + +{-# SPECIALIZE concatMap :: (a -> [b]) -> Infinite a -> Infinite b #-} + +foldr :: (a -> b -> b) -> Infinite a -> b +foldr f = go where go (Inf a as) = f a (go as) +{-# INLINE [0] foldr #-} + +build :: (forall b . (a -> b -> b) -> b) -> Infinite a +build g = g Inf +{-# INLINE [1] build #-} + +-- Analogous to 'foldr'/'build' fusion for '[]' +{-# RULES +"foldr/build" forall f (g :: forall b . (a -> b -> b) -> b) . foldr f (build g) = g f +"foldr/id" foldr Inf = id + +"foldr/cons/build" forall f a (g :: forall b . (a -> b -> b) -> b) . foldr f (Inf a (build g)) = f a (g f) + #-} + +{-# RULES +"map" [~1] forall f (as :: Infinite a) . fmap f as = build \ c -> foldr (mapFB c f) as +"mapFB" forall c f g . mapFB (mapFB c f) g = mapFB c (f . g) +"mapFB/id" forall c . mapFB c (\ x -> x) = c + #-} + +mapFB :: (b -> c -> c) -> (a -> b) -> a -> c -> c +mapFB c f = \ x ys -> c (f x) ys +{-# INLINE [0] mapFB #-} + +dropList :: [a] -> Infinite b -> Infinite b +dropList [] bs = bs +dropList (_:as) (Inf _ bs) = dropList as bs + +-- | Compute all lists of the given alphabet. +-- For example: @'allListsOf' "ab" = ["a", "b", "aa", "ba", "ab", "bb", "aaa", "baa", "aba", ...]@ +allListsOf :: [a] -> Infinite [a] +allListsOf as = concatMap (\ bs -> [a:bs | a <- as]) ([] `Inf` allListsOf as) + +-- See Note [Fusion for `Infinite` lists]. +toList :: Infinite a -> [a] +toList = \ as -> List.build (\ c _ -> foldr c as) +{-# INLINE toList #-} + +repeat :: a -> Infinite a +repeat a = as where as = Inf a as +{-# INLINE [0] repeat #-} + +repeatFB :: (a -> b -> b) -> a -> b +repeatFB c x = xs where xs = c x xs +{-# INLINE [0] repeatFB #-} + +{-# RULES +"repeat" [~1] forall a . repeat a = build \ c -> repeatFB c a +"repeatFB" [1] repeatFB Inf = repeat + #-} + +{- +Note [Fusion for `Infinite` lists] +~~~~~~~~~~~~~~~~~~~~ +We use RULES to support foldr/build fusion for Infinite lists, analogously to the RULES in +GHC.Base to support fusion for regular lists. In particular, we define the following: +• `build :: (forall b . (a -> b -> b) -> b) -> Infinite a` +• `foldr :: (a -> b -> b) -> Infinite a -> b` +• A RULE `foldr f (build g) = g f` +• `Infinite`-producing functions in terms of `build`, and `Infinite`-consuming functions in + terms of `foldr` + +This can work across data types. For example, consider `toList :: Infinite a -> [a]`. +We want 'toList' to be both a good consumer (of 'Infinite' lists) and a good producer (of '[]'). +Ergo, we define it in terms of 'Infinite.foldr' and `List.build`. + +For a bigger example, consider `List.map f (toList (Infinite.map g as))` + +We want to fuse away the intermediate `Infinite` structure between `Infnite.map` and `toList`, +and the list structure between `toList` and `List.map`. And indeed we do: see test +"InfiniteListFusion". +-} 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 @@ -12,7 +12,7 @@ -- -- Avoid using them as much as possible module GHC.Data.List.SetOps ( - unionLists, minusList, + unionLists, unionListsOrd, minusList, -- Association lists Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, @@ -33,7 +33,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Utils.Trace import qualified Data.List as L import qualified Data.List.NonEmpty as NE @@ -54,6 +53,19 @@ -} + +-- | Combines the two lists while keeping their order, placing the first argument +-- first in the result. +-- +-- Uses a set internally to record duplicates. This makes it slightly slower for +-- very small lists but avoids quadratic behaviour for large lists. +unionListsOrd :: (HasDebugCallStack, Outputable a, Ord a) => [a] -> [a] -> [a] +unionListsOrd xs ys + -- Since both arguments don't have internal duplicates we can just take all of xs + -- and every element of ys that's not already in xs. + = let set_ys = S.fromList ys + in (filter (\e -> not $ S.member e set_ys) xs) ++ ys + -- | Assumes that the arguments contain no duplicates unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a] -- We special case some reasonable common patterns. @@ -161,7 +173,7 @@ eq a b = case cmp a b of { EQ -> True; _ -> False } -- | Remove the duplicates from a list using the provided --- comparison function. +-- comparison function. Might change the order of elements. -- -- Returns the list without duplicates, and accumulates -- all the duplicates in the second component of its result. diff --git a/GHC/Data/Maybe.hs b/GHC/Data/Maybe.hs --- a/GHC/Data/Maybe.hs +++ b/GHC/Data/Maybe.hs @@ -32,7 +32,7 @@ import Control.Monad.Trans.Maybe import Control.Exception (SomeException(..)) import Data.Maybe -import Data.Foldable ( foldlM ) +import Data.Foldable ( foldlM, for_ ) import GHC.Utils.Misc (HasCallStack) import Data.List.NonEmpty ( NonEmpty ) @@ -71,8 +71,7 @@ expectJust err Nothing = error ("expectJust " ++ err) whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenIsJust (Just x) f = f x -whenIsJust Nothing _ = return () +whenIsJust = for_ -- | Flipped version of @fromMaybe@, useful for chaining. orElse :: Maybe a -> a -> a diff --git a/GHC/Data/OrdList.hs b/GHC/Data/OrdList.hs --- a/GHC/Data/OrdList.hs +++ b/GHC/Data/OrdList.hs @@ -8,7 +8,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE UnboxedSums #-} {-# LANGUAGE UnboxedTuples #-} -- | Provide trees (of instructions), so that lists of instructions can be @@ -28,6 +27,8 @@ import GHC.Utils.Outputable import GHC.Utils.Panic +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup as Semigroup infixl 5 `appOL` @@ -37,7 +38,7 @@ data OrdList a = None | One a - | Many [a] -- Invariant: non-empty + | Many (NonEmpty a) | Cons a (OrdList a) | Snoc (OrdList a) a | Two (OrdList a) -- Invariant: non-empty @@ -100,8 +101,12 @@ pattern ConsOL x xs <- (viewCons -> VJust x xs) where ConsOL x xs = consOL x xs {-# COMPLETE NilOL, ConsOL #-} + viewCons :: OrdList a -> VMaybe a (OrdList a) -viewCons (One a) = VJust a NilOL +viewCons None = VNothing +viewCons (One a) = VJust a NilOL +viewCons (Many (a :| [])) = VJust a NilOL +viewCons (Many (a :| b : bs)) = VJust a (Many (b :| bs)) viewCons (Cons a as) = VJust a as viewCons (Snoc as a) = case viewCons as of VJust a' as' -> VJust a' (Snoc as' a) @@ -109,15 +114,18 @@ viewCons (Two as1 as2) = case viewCons as1 of VJust a' as1' -> VJust a' (Two as1' as2) VNothing -> viewCons as2 -viewCons _ = VNothing pattern SnocOL :: OrdList a -> a -> OrdList a pattern SnocOL xs x <- (viewSnoc -> VJust xs x) where SnocOL xs x = snocOL xs x {-# COMPLETE NilOL, SnocOL #-} + viewSnoc :: OrdList a -> VMaybe (OrdList a) a -viewSnoc (One a) = VJust NilOL a -viewSnoc (Many (reverse -> a:as)) = VJust (Many (reverse as)) a +viewSnoc None = VNothing +viewSnoc (One a) = VJust NilOL a +viewSnoc (Many as) = (`VJust` NE.last as) $ case NE.init as of + [] -> NilOL + b : bs -> Many (b :| bs) viewSnoc (Snoc as a) = VJust as a viewSnoc (Cons a as) = case viewSnoc as of VJust as' a' -> VJust (Cons a as') a' @@ -125,18 +133,17 @@ viewSnoc (Two as1 as2) = case viewSnoc as2 of VJust as2' a' -> VJust (Two as1 as2') a' VNothing -> viewSnoc as1 -viewSnoc _ = VNothing headOL None = panic "headOL" headOL (One a) = a -headOL (Many as) = head as +headOL (Many as) = NE.head as headOL (Cons a _) = a headOL (Snoc as _) = headOL as headOL (Two as _) = headOL as lastOL None = panic "lastOL" lastOL (One a) = a -lastOL (Many as) = last as +lastOL (Many as) = NE.last as lastOL (Cons _ as) = lastOL as lastOL (Snoc _ a) = a lastOL (Two _ as) = lastOL as @@ -164,7 +171,7 @@ go (Cons a b) acc = a : go b acc go (Snoc a b) acc = go a (b:acc) go (Two a b) acc = go a (go b acc) - go (Many xs) acc = xs ++ acc + go (Many xs) acc = NE.toList xs ++ acc fromOLReverse :: OrdList a -> [a] fromOLReverse a = go a [] @@ -175,7 +182,7 @@ go (Cons a b) acc = go b (a : acc) go (Snoc a b) acc = b : go a acc go (Two a b) acc = go b (go a acc) - go (Many xs) acc = reverse xs ++ acc + go (Many xs) acc = reverse (NE.toList xs) ++ acc mapOL :: (a -> b) -> OrdList a -> OrdList b mapOL = fmap @@ -192,7 +199,9 @@ mapOL' f (Two b1 b2) = let !b1' = mapOL' f b1 !b2' = mapOL' f b2 in Two b1' b2' -mapOL' f (Many xs) = Many $! strictMap f xs +mapOL' f (Many (x :| xs)) = let !x1 = f x + !xs1 = strictMap f xs + in Many (x1 :| xs1) foldrOL :: (a->b->b) -> b -> OrdList a -> b foldrOL _ z None = z @@ -214,7 +223,7 @@ toOL :: [a] -> OrdList a toOL [] = None toOL [x] = One x -toOL xs = Many xs +toOL (x : xs) = Many (x :| xs) reverseOL :: OrdList a -> OrdList a reverseOL None = None @@ -222,7 +231,7 @@ reverseOL (Cons a b) = Snoc (reverseOL b) a reverseOL (Snoc a b) = Cons b (reverseOL a) reverseOL (Two a b) = Two (reverseOL b) (reverseOL a) -reverseOL (Many xs) = Many (reverse xs) +reverseOL (Many xs) = Many (NE.reverse xs) -- | Compare not only the values but also the structure of two lists strictlyEqOL :: Eq a => OrdList a -> OrdList a -> Bool diff --git a/GHC/Data/Pair.hs b/GHC/Data/Pair.hs --- a/GHC/Data/Pair.hs +++ b/GHC/Data/Pair.hs @@ -4,7 +4,7 @@ -} -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} module GHC.Data.Pair ( Pair(..) @@ -22,7 +22,7 @@ import qualified Data.Semigroup as Semi data Pair a = Pair { pFst :: a, pSnd :: a } - deriving (Functor) + deriving (Foldable, Functor, Traversable) -- Note that Pair is a *unary* type constructor -- whereas (,) is binary @@ -33,12 +33,6 @@ instance Applicative Pair where pure x = Pair x x (Pair f g) <*> (Pair x y) = Pair (f x) (g y) - -instance Foldable Pair where - foldMap f (Pair x y) = f x `mappend` f y - -instance Traversable Pair where - traverse f (Pair x y) = Pair <$> f x <*> f y instance Semi.Semigroup a => Semi.Semigroup (Pair a) where Pair a1 b1 <> Pair a2 b2 = Pair (a1 Semi.<> a2) (b1 Semi.<> b2) diff --git a/GHC/Data/Stream.hs b/GHC/Data/Stream.hs --- a/GHC/Data/Stream.hs +++ b/GHC/Data/Stream.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} -- ----------------------------------------------------------------------------- @@ -66,9 +67,7 @@ data StreamS m a b = Yield a (StreamS m a b) | Done b | Effect (m (StreamS m a b)) - -instance Monad m => Functor (StreamS m a) where - fmap = liftM + deriving (Functor) instance Monad m => Applicative (StreamS m a) where pure = Done @@ -126,7 +125,7 @@ -- | Note this is not very efficient because it traverses the whole stream -- before rebuilding it, avoid using it if you can. mapAccumL used to -- implemented but it wasn't used anywhere in the compiler and has similar --- effiency problems. +-- efficiency problems. mapAccumL_ :: forall m a b c r . Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r -> Stream m b (c, r) mapAccumL_ f c str = Stream $ \f h -> go c f h (runStream str) diff --git a/GHC/Data/StringBuffer.hs b/GHC/Data/StringBuffer.hs --- a/GHC/Data/StringBuffer.hs +++ b/GHC/Data/StringBuffer.hs @@ -199,7 +199,7 @@ let size = utf8EncodedLength str buf <- mallocForeignPtrArray (size+3) unsafeWithForeignPtr buf $ \ptr -> do - utf8EncodeStringPtr ptr str + utf8EncodePtr ptr str pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] -- sentinels for UTF-8 decoding return (StringBuffer buf size 0) @@ -297,7 +297,7 @@ inlinePerformIO $ unsafeWithForeignPtr buf $ \p -> do p' <- utf8PrevChar (p `plusPtr` cur) - return (fst (utf8DecodeChar p')) + return (fst (utf8DecodeCharPtr p')) -- ----------------------------------------------------------------------------- -- Moving @@ -383,7 +383,7 @@ -> String lexemeToString _ 0 = "" lexemeToString (StringBuffer buf _ cur) bytes = - utf8DecodeStringLazy buf cur bytes + utf8DecodeForeignPtr buf cur bytes lexemeToFastString :: StringBuffer -> Int -- ^ @n@, the number of bytes @@ -405,7 +405,7 @@ go buf0 n acc p | n == 0 || buf0 >= p = return acc go buf0 n acc p = do p' <- utf8PrevChar p - let (c,_) = utf8DecodeChar p' + let (c,_) = utf8DecodeCharPtr p' go buf0 (n - 1) (c:acc) p' -- ----------------------------------------------------------------------------- @@ -414,7 +414,7 @@ parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let go i x | i == len = x - | otherwise = case fst (utf8DecodeChar (ptr `plusPtr` (cur + i))) of + | otherwise = case fst (utf8DecodeCharPtr (ptr `plusPtr` (cur + i))) of '_' -> go (i + 1) x -- skip "_" (#14473) char -> go (i + 1) (x * radix + toInteger (char_to_int char)) in go 0 0 diff --git a/GHC/Data/TrieMap.hs b/GHC/Data/TrieMap.hs --- a/GHC/Data/TrieMap.hs +++ b/GHC/Data/TrieMap.hs @@ -66,12 +66,11 @@ type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) -- or an existing elt (Just) -class TrieMap m where +class Functor m => TrieMap m where type Key m :: Type emptyTM :: m a lookupTM :: forall b. Key m -> m b -> Maybe b alterTM :: forall b. Key m -> XT b -> m b -> m b - mapTM :: (a->b) -> m a -> m b filterTM :: (a -> Bool) -> m a -> m a foldTM :: (a -> b -> b) -> m a -> b -> b @@ -117,6 +116,25 @@ deMaybe (Just m) = m {- +Note [Every TrieMap is a Functor] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every TrieMap T admits + fmap :: (a->b) -> T a -> T b +where (fmap f t) applies `f` to every element of the range of `t`. +Ergo, we make `Functor` a superclass of `TrieMap`. + +Moreover it is almost invariably possible to /derive/ Functor for each +particular instance. E.g. in the list instance we have + data ListMap m a + = LM { lm_nil :: Maybe a + , lm_cons :: m (ListMap m a) } + deriving (Functor) + instance TrieMap m => TrieMap (ListMap m) where { .. } + +Alas, we not yet derive `Functor` for reasons of performance; see #22292. +-} + +{- ************************************************************************ * * IntMaps @@ -130,7 +148,6 @@ lookupTM k m = IntMap.lookup k m alterTM = xtInt foldTM k m z = IntMap.foldr k z m - mapTM f m = IntMap.map f m filterTM f m = IntMap.filter f m xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a @@ -142,7 +159,6 @@ lookupTM = Map.lookup alterTM k f m = Map.alter f k m foldTM k m z = Map.foldr k z m - mapTM f m = Map.map f m filterTM f m = Map.filter f m @@ -219,7 +235,6 @@ lookupTM k m = lookupUDFM m k alterTM k f m = alterUDFM f m k foldTM k m z = foldUDFM k z m - mapTM f m = mapUDFM f m filterTM f m = filterUDFM f m {- @@ -235,22 +250,22 @@ data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } +-- TODO(22292): derive +instance Functor m => Functor (MaybeMap m) where + fmap f MM { mm_nothing = mn, mm_just = mj } = MM + { mm_nothing = fmap f mn, mm_just = fmap f mj } + instance TrieMap m => TrieMap (MaybeMap m) where type Key (MaybeMap m) = Maybe (Key m) emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } lookupTM = lkMaybe lookupTM alterTM = xtMaybe alterTM foldTM = fdMaybe - mapTM = mapMb filterTM = ftMaybe instance TrieMap m => Foldable (MaybeMap m) where foldMap = foldMapTM -mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b -mapMb f (MM { mm_nothing = mn, mm_just = mj }) - = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj } - lkMaybe :: (forall b. k -> m b -> Maybe b) -> Maybe k -> MaybeMap m a -> Maybe a lkMaybe _ Nothing = mm_nothing @@ -290,13 +305,17 @@ = LM { lm_nil :: Maybe a , lm_cons :: m (ListMap m a) } +-- TODO(22292): derive +instance Functor m => Functor (ListMap m) where + fmap f LM { lm_nil = mnil, lm_cons = mcons } = LM + { lm_nil = fmap f mnil, lm_cons = fmap (fmap f) mcons } + instance TrieMap m => TrieMap (ListMap m) where type Key (ListMap m) = [Key m] emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } lookupTM = lkList lookupTM alterTM = xtList alterTM foldTM = fdList - mapTM = mapList filterTM = ftList instance TrieMap m => Foldable (ListMap m) where @@ -305,10 +324,6 @@ instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where ppr m = text "List elts" <+> ppr (foldTM (:) m []) -mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b -mapList f (LM { lm_nil = mnil, lm_cons = mcons }) - = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons } - lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) -> [k] -> ListMap m a -> Maybe a lkList _ [] = lm_nil @@ -326,7 +341,7 @@ ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a ftList f (LM { lm_nil = mnil, lm_cons = mcons }) - = LM { lm_nil = filterMaybe f mnil, lm_cons = mapTM (filterTM f) mcons } + = LM { lm_nil = filterMaybe f mnil, lm_cons = fmap (filterTM f) mcons } {- ************************************************************************ @@ -380,6 +395,11 @@ ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v ppr (MultiMap m) = ppr m +-- TODO(22292): derive +instance Functor m => Functor (GenMap m) where + fmap = mapG + {-# INLINE fmap #-} + -- TODO undecidable instance instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where type Key (GenMap m) = Key m @@ -387,7 +407,6 @@ lookupTM = lkG alterTM = xtG foldTM = fdG - mapTM = mapG filterTM = ftG instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where @@ -431,10 +450,10 @@ xtG k f (MultiMap m) = MultiMap (alterTM k f m) {-# INLINEABLE mapG #-} -mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b +mapG :: Functor m => (a -> b) -> GenMap m a -> GenMap m b mapG _ EmptyMap = EmptyMap mapG f (SingletonMap k v) = SingletonMap k (f v) -mapG f (MultiMap m) = MultiMap (mapTM f m) +mapG f (MultiMap m) = MultiMap (fmap f m) {-# INLINEABLE fdG #-} fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b diff --git a/GHC/Data/Unboxed.hs b/GHC/Data/Unboxed.hs new file mode 100644 --- /dev/null +++ b/GHC/Data/Unboxed.hs @@ -0,0 +1,49 @@ +-- Unboxed counterparts to data structures + +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UnliftedNewtypes #-} + +module GHC.Data.Unboxed ( + MaybeUB(JustUB, NothingUB), + fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB + ) where + +import GHC.Prelude hiding (Maybe(..), Either(..)) + +-- | Like Maybe, but using unboxed sums. +-- +-- Use with care. Using a unboxed maybe is not always a win +-- in execution *time* even when allocations go down. So make +-- sure to benchmark for execution time as well. If the difference +-- in *runtime* for the compiler is too small to measure it's likely +-- better to use a regular Maybe instead. +-- +-- This is since it causes more function arguments to be passed, and +-- potentially more variables to be captured by closures increasing +-- closure size. +newtype MaybeUB a = MaybeUB (# (# #) | a #) + +pattern JustUB :: a -> MaybeUB a +pattern JustUB x = MaybeUB (# | x #) + +pattern NothingUB :: MaybeUB a +pattern NothingUB = MaybeUB (# (# #) | #) + +{-# COMPLETE NothingUB, JustUB #-} + +fromMaybeUB :: a -> MaybeUB a -> a +fromMaybeUB d NothingUB = d +fromMaybeUB _ (JustUB x) = x + +apMaybeUB :: MaybeUB (a -> b) -> MaybeUB a -> MaybeUB b +apMaybeUB (JustUB f) (JustUB x) = JustUB (f x) +apMaybeUB _ _ = NothingUB + +fmapMaybeUB :: (a -> b) -> MaybeUB a -> MaybeUB b +fmapMaybeUB _f NothingUB = NothingUB +fmapMaybeUB f (JustUB x) = JustUB $ f x + +maybeUB :: b -> (a -> b) -> MaybeUB a -> b +maybeUB _def f (JustUB x) = f x +maybeUB def _f NothingUB = def diff --git a/GHC/Driver/Backend.hs b/GHC/Driver/Backend.hs --- a/GHC/Driver/Backend.hs +++ b/GHC/Driver/Backend.hs @@ -1,131 +1,990 @@ {-# LANGUAGE MultiWayIf #-} --- | Code generation backends -module GHC.Driver.Backend - ( Backend (..) - , platformDefaultBackend - , platformNcgSupported - , backendProducesObject - , backendRetainsAllBindings - ) -where - -import GHC.Prelude -import GHC.Platform - --- | Code generation backends. --- --- GHC supports several code generation backends serving different purposes --- (producing machine code, producing ByteCode for the interpreter) and --- supporting different platforms. --- -data Backend - = NCG -- ^ Native code generator backend. - -- - -- Compiles Cmm code into textual assembler, then relies on - -- an external assembler toolchain to produce machine code. - -- - -- Only supports a few platforms (X86, PowerPC, SPARC). - -- - -- See "GHC.CmmToAsm". - - - | LLVM -- ^ LLVM backend. - -- - -- Compiles Cmm code into LLVM textual IR, then relies on - -- LLVM toolchain to produce machine code. - -- - -- It relies on LLVM support for the calling convention used - -- by the NCG backend to produce code objects ABI compatible - -- with it (see "cc 10" or "ghccc" calling convention in - -- https://llvm.org/docs/LangRef.html#calling-conventions). - -- - -- Support a few platforms (X86, AArch64, s390x, ARM). - -- - -- See "GHC.CmmToLlvm" - - - | ViaC -- ^ Via-C backend. - -- - -- Compiles Cmm code into C code, then relies on a C compiler - -- to produce machine code. - -- - -- It produces code objects that are *not* ABI compatible - -- with those produced by NCG and LLVM backends. - -- - -- Produced code is expected to be less efficient than the - -- one produced by NCG and LLVM backends because STG - -- registers are not pinned into real registers. On the - -- other hand, it supports more target platforms (those - -- having a valid C toolchain). - -- - -- See "GHC.CmmToC" - - - | Interpreter -- ^ ByteCode interpreter. - -- - -- Produce ByteCode objects (BCO, see "GHC.ByteCode") that - -- can be interpreted. It is used by GHCi. - -- - -- Currently some extensions are not supported - -- (foreign primops). - -- - -- See "GHC.StgToByteCode" - - - | NoBackend -- ^ No code generated. - -- - -- Use this to disable code generation. It is particularly - -- useful when GHC is used as a library for other purpose - -- than generating code (e.g. to generate documentation with - -- Haddock) or when the user requested it (via -fno-code) for - -- some reason. - - deriving (Eq,Ord,Show,Read) - --- | Default backend to use for the given platform. -platformDefaultBackend :: Platform -> Backend -platformDefaultBackend platform = if - | platformUnregisterised platform -> ViaC - | platformNcgSupported platform -> NCG - | otherwise -> LLVM - - --- | Is the platform supported by the Native Code Generator? -platformNcgSupported :: Platform -> Bool -platformNcgSupported platform = if - | platformUnregisterised platform -> False -- NCG doesn't support unregisterised ABI - | ncgValidArch -> True - | otherwise -> False - where - ncgValidArch = case platformArch platform of - ArchX86 -> True - ArchX86_64 -> True - ArchPPC -> True - ArchPPC_64 {} -> True - ArchAArch64 -> True - _ -> False - --- | Will this backend produce an object file on the disk? -backendProducesObject :: Backend -> Bool -backendProducesObject ViaC = True -backendProducesObject NCG = True -backendProducesObject LLVM = True -backendProducesObject Interpreter = False -backendProducesObject NoBackend = False - --- | Does this backend retain *all* top-level bindings for a module, --- rather than just the exported bindings, in the TypeEnv and compiled --- code (if any)? --- --- Interpreter backend does this, so that GHCi can call functions inside a --- module. --- --- When no backend is used we also do it, so that Haddock can get access to the --- GlobalRdrEnv for a module after typechecking it. -backendRetainsAllBindings :: Backend -> Bool -backendRetainsAllBindings Interpreter = True -backendRetainsAllBindings NoBackend = True -backendRetainsAllBindings ViaC = False -backendRetainsAllBindings NCG = False -backendRetainsAllBindings LLVM = False +{-| +Module : GHC.Driver.Backend +Description : Back ends for code generation + +This module exports the `Backend` type and all the available values +of that type. The type is abstract, and GHC assumes a "closed world": +all the back ends are known and are known here. The compiler driver +chooses a `Backend` value based on how it is asked to generate code. + +A `Backend` value encapsulates the knowledge needed to take Cmm, STG, +or Core and write assembly language to a file. A back end also +provides a function that enables the compiler driver to run an +assembler on the code that is written, if any (the "post-backend +pipeline"). Finally, a back end has myriad /properties/. Properties +mediate interactions between a back end and the rest of the compiler, +especially the driver. Examples include the following: + + * Property `backendValidityOfCImport` says whether the back end can + import foreign C functions. + + * Property `backendForcesOptimization0` says whether the back end can + be used with optimization levels higher than `-O0`. + + * Property `backendCDefs` tells the compiler driver, "if you're using + this back end, then these are the command-line flags you should add + to any invocation of the C compiler." + +These properties are used elsewhere in GHC, primarily in the driver, to +fine-tune operations according to the capabilities of the chosen back +end. You might use a property to make GHC aware of a potential +limitation of certain back ends, or a special feature available only +in certain back ends. If your client code needs to know a fact that +is not exposed in an existing property, you would define and export a +new property. Conditioning client code on the /identity/ or /name/ of +a back end is Not Done. + +For full details, see the documentation of each property. +-} + +module GHC.Driver.Backend + ( -- * The @Backend@ type + Backend -- note: type is abstract + -- * Available back ends + , ncgBackend + , llvmBackend + , jsBackend + , viaCBackend + , interpreterBackend + , noBackend + , allBackends + + -- * Types used to specify properties of back ends + , PrimitiveImplementation(..) + -- ** Properties that stand for functions + -- *** Back-end function for code generation + , 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) + , BackendName + + + + -- * Properties of back ends + , backendDescription + , backendWritesFiles + , backendPipelineOutput + , backendCanReuseLoadedCode + , backendGeneratesCode + , backendGeneratesCodeForHsBoot + , backendSupportsInterfaceWriting + , backendRespectsSpecialise + , backendWantsGlobalBindings + , backendHasNativeSwitch + , backendPrimitiveImplementation + , backendSimdValidity + , backendSupportsEmbeddedBlobs + , backendNeedsPlatformNcgSupport + , backendSupportsUnsplitProcPoints + , backendSwappableWithViaC + , backendUnregisterisedAbiOnly + , backendGeneratesHc + , backendSptIsDynamic + , backendWantsBreakpointTicks + , backendForcesOptimization0 + , backendNeedsFullWays + , backendSpecialModuleSource + , backendSupportsHpc + , backendSupportsCImport + , backendSupportsCExport + , backendAssemblerProg + , backendAssemblerInfoGetter + , backendCDefs + , backendCodeOutput + , backendUseJSLinker + , backendPostHscPipeline + , backendNormalSuccessorPhase + , backendName + , backendValidityOfCImport + , backendValidityOfCExport + + -- * Other functions of back ends + , platformDefaultBackend + , platformNcgSupported + ) + +where + + +import GHC.Prelude + +import GHC.Driver.Backend.Internal (BackendName(..)) +import GHC.Driver.Phases + + +import GHC.Utils.Error +import GHC.Utils.Panic + +import GHC.Driver.Pipeline.Monad +import GHC.Platform + + +--------------------------------------------------------------------------------- +-- +-- DESIGN CONSIDERATIONS +-- +-- +-- +-- The `Backend` type is made abstract in order to make it possible to +-- add new back ends without having to inspect or modify much code +-- elsewhere in GHC. Adding a new back end would be /easiest/ if +-- `Backend` were represented as a record type, but in peer review, +-- the clear will of the majority was to use a sum type. As a result, +-- when adding a new back end it is necessary to modify /every/ +-- function in this module that expects `Backend` as its first argument. +-- **By design, these functions have no default/wildcard cases.** This +-- design forces the author of a new back end to consider the semantics +-- in every case, rather than relying on a default that may be wrong. +-- The names and documentation of the functions defined in the `Backend` +-- record are sufficiently descriptive that the author of a new back +-- end will be able to identify correct result values without having to go +-- spelunking throughout the compiler. +-- +-- While the design localizes /most/ back-end logic in this module, +-- the author of a new back end will still have to make changes +-- elsewhere in the compiler: +-- +-- * For reasons described in Note [Backend Defunctionalization], +-- code-generation and post-backend pipeline functions, among other +-- functions, cannot be placed in the `Backend` record itself. +-- Instead, the /names/ of those functions are placed. Each name is +-- a value constructor in one of the algebraic data types defined in +-- this module. The named function is then defined near its point +-- of use. +-- +-- The author of a new back end will have to consider whether an +-- existing function will do or whether a new function needs to be +-- defined. When a new function needs to be defined, the author +-- must take two steps: +-- +-- - Add a value constructor to the relevant data type here +-- in the `Backend` module +-- +-- - Add a case to the location in the compiler (there should be +-- exactly one) where the value constructors of the relevant +-- data type are used +-- +-- * When a new back end is defined, it's quite possible that the +-- compiler driver will have to be changed in some way. Just because +-- the driver supports five back ends doesn't mean it will support a sixth +-- without changes. +-- +-- The collection of functions exported from this module hasn't +-- really been "designed"; it's what emerged from a refactoring of +-- older code. The real design criterion was "make it crystal clear +-- what has to be done to add a new back end." +-- +-- One issue remains unresolved: some of the error messages and +-- warning messages used in the driver assume a "closed world": they +-- think they know all the back ends that exist, and they are not shy +-- about enumerating them. Just one set of error messages has been +-- ported to have an open-world assumption: these are the error +-- messages associated with type checking of foreign imports and +-- exports. To allow other errors to be issued with an open-world +-- assumption, use functions `backendValidityOfCImport` and +-- `backendValidityOfCExport` as models, and have a look at how the +-- 'expected back ends' are used in modules "GHC.Tc.Gen.Foreign" and +-- "GHC.Tc.Errors.Ppr" +-- +--------------------------------------------------------------------------------- + + +platformDefaultBackend :: Platform -> Backend +platformDefaultBackend platform = if + | platformUnregisterised platform -> viaCBackend + | platformNcgSupported platform -> ncgBackend + | platformJSSupported platform -> jsBackend + | otherwise -> llvmBackend + +-- | Is the platform supported by the Native Code Generator? +platformNcgSupported :: Platform -> Bool +platformNcgSupported platform = if + | platformUnregisterised platform -> False -- NCG doesn't support unregisterised ABI + | ncgValidArch -> True + | otherwise -> False + where + ncgValidArch = case platformArch platform of + ArchX86 -> True + ArchX86_64 -> True + ArchPPC -> True + ArchPPC_64 {} -> True + ArchAArch64 -> True + ArchWasm32 -> True + _ -> False + +-- | Is the platform supported by the JS backend? +platformJSSupported :: Platform -> Bool +platformJSSupported platform + | platformArch platform == ArchJavaScript = True + | otherwise = False + + +-- | A value of type @Backend@ represents one of GHC's back ends. +-- The set of back ends cannot be extended except by modifying the +-- definition of @Backend@ in this module. +-- +-- The @Backend@ type is abstract; that is, its value constructors are +-- not exported. It's crucial that they not be exported, because a +-- value of type @Backend@ carries only the back end's /name/, not its +-- behavior or properties. If @Backend@ were not abstract, then code +-- elsewhere in the compiler could depend directly on the name, not on +-- the semantics, which would make it challenging to create a new back end. +-- Because @Backend@ /is/ abstract, all the obligations of a new back +-- end are enumerated in this module, in the form of functions that +-- take @Backend@ as an argument. +-- +-- The issue of abstraction is discussed at great length in #20927 and !7442. + + +newtype Backend = Named BackendName + -- Must be a newtype so that it has no `Eq` instance and + -- a different `Show` instance. + +-- | The Show instance is for messages /only/. If code depends on +-- what's in the string, you deserve what happens to you. + +instance Show Backend where + show = backendDescription + + +ncgBackend, llvmBackend, viaCBackend, interpreterBackend, jsBackend, noBackend + :: Backend + +-- | The native code generator. +-- Compiles Cmm code into textual assembler, then relies on +-- an external assembler toolchain to produce machine code. +-- +-- Only supports a few platforms (X86, PowerPC, SPARC). +-- +-- See "GHC.CmmToAsm". +ncgBackend = Named NCG + +-- | The LLVM backend. +-- +-- Compiles Cmm code into LLVM textual IR, then relies on +-- LLVM toolchain to produce machine code. +-- +-- It relies on LLVM support for the calling convention used +-- by the NCG backend to produce code objects ABI compatible +-- with it (see "cc 10" or "ghccc" calling convention in +-- https://llvm.org/docs/LangRef.html#calling-conventions). +-- +-- Supports a few platforms (X86, AArch64, s390x, ARM). +-- +-- See "GHC.CmmToLlvm" +llvmBackend = Named LLVM + +-- | The JavaScript Backend +-- +-- See documentation in GHC.StgToJS +jsBackend = Named JavaScript + +-- | Via-C ("unregisterised") backend. +-- +-- Compiles Cmm code into C code, then relies on a C compiler +-- to produce machine code. +-- +-- It produces code objects that are /not/ ABI compatible +-- with those produced by NCG and LLVM backends. +-- +-- Produced code is expected to be less efficient than the +-- one produced by NCG and LLVM backends because STG +-- registers are not pinned into real registers. On the +-- other hand, it supports more target platforms (those +-- having a valid C toolchain). +-- +-- See "GHC.CmmToC" +viaCBackend = Named ViaC + +-- | The ByteCode interpreter. +-- +-- Produce ByteCode objects (BCO, see "GHC.ByteCode") that +-- can be interpreted. It is used by GHCi. +-- +-- Currently some extensions are not supported +-- (foreign primops). +-- +-- See "GHC.StgToByteCode" +interpreterBackend = Named Interpreter + +-- | A dummy back end that generates no code. +-- +-- Use this back end to disable code generation. It is particularly +-- useful when GHC is used as a library for other purpose than +-- generating code (e.g. to generate documentation with Haddock) or +-- when the user requested it (via `-fno-code`) for some reason. +noBackend = Named NoBackend + +--------------------------------------------------------------------------------- + + + + +-- | This enumeration type specifies how the back end wishes GHC's +-- primitives to be implemented. (Module "GHC.StgToCmm.Prim" provides +-- a generic implementation of every primitive, but some primitives, +-- like `IntQuotRemOp`, can be implemented more efficiently by +-- certain back ends on certain platforms. For example, by using a +-- machine instruction that simultaneously computes quotient and remainder.) +-- +-- For the meaning of each alternative, consult +-- "GHC.StgToCmm.Config". (In a perfect world, type +-- `PrimitiveImplementation` would be defined there, in the module +-- that determines its meaning. But I could not figure out how to do +-- it without mutual recursion across module boundaries.) + +data PrimitiveImplementation + = LlvmPrimitives -- ^ Primitives supported by LLVM + | NcgPrimitives -- ^ Primitives supported by the native code generator + | JSPrimitives -- ^ Primitives supported by JS backend + | GenericPrimitives -- ^ Primitives supported by all back ends + 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: +-- +-- > Logger +-- > -> DynFlags +-- > -> Module -- ^ module being compiled +-- > -> ModLocation +-- > -> FilePath -- ^ Where to write output +-- > -> Set UnitId -- ^ dependencies +-- > -> Stream IO RawCmmGroup a -- results from `StgToCmm` +-- > -> IO a +-- +-- The functions so named are defined in "GHC.Driver.CodeOutput". +-- +-- We expect one function per back end—or more precisely, one function +-- for each back end that writes code to a file. (The interpreter +-- does not write to files; its output lives only in memory.) + +data DefunctionalizedCodeOutput + = NcgCodeOutput + | ViaCCodeOutput + | LlvmCodeOutput + | JSCodeOutput + + +-- | Names a function that tells the driver what should happen after +-- assembly code is written. This might include running a C compiler, +-- running LLVM, running an assembler, or various similar activities. +-- The function named normally has this type: +-- +-- > TPipelineClass TPhase m +-- > => PipeEnv +-- > -> HscEnv +-- > -> Maybe ModLocation +-- > -> FilePath +-- > -> m (Maybe FilePath) +-- +-- The functions so named are defined in "GHC.Driver.Pipeline". + +data DefunctionalizedPostHscPipeline + = NcgPostHscPipeline + | ViaCPostHscPipeline + | LlvmPostHscPipeline + | JSPostHscPipeline + | NoPostHscPipeline -- ^ After code generation, nothing else need happen. + +-- | Names a function that tells the driver what command-line options +-- to include when invoking a C compiler. It's meant for @-D@ options that +-- define symbols for the C preprocessor. Because the exact symbols +-- defined might depend on versions of tools located in the file +-- system (/cough/ LLVM /cough/), the function requires an `IO` action. +-- The function named has this type: +-- +-- > Logger -> DynFlags -> IO [String] + +data DefunctionalizedCDefs + = NoCDefs -- ^ No additional command-line options are needed + + | LlvmCDefs -- ^ Return command-line options that tell GHC about the + -- LLVM version. + +--------------------------------------------------------------------------------- + + + +-- | An informal description of the back end, for use in +-- issuing warning messages /only/. If code depends on +-- what's in the string, you deserve what happens to you. +backendDescription :: Backend -> String +backendDescription (Named NCG) = "native code generator" +backendDescription (Named LLVM) = "LLVM" +backendDescription (Named ViaC) = "compiling via C" +backendDescription (Named JavaScript) = "compiling to JavaScript" +backendDescription (Named Interpreter) = "byte-code interpreter" +backendDescription (Named NoBackend) = "no code generated" + +-- | This flag tells the compiler driver whether the back +-- end will write files: interface files and object files. +-- It is typically true for "real" back ends that generate +-- code into the filesystem. (That means, not the interpreter.) +backendWritesFiles :: Backend -> Bool +backendWritesFiles (Named NCG) = True +backendWritesFiles (Named LLVM) = True +backendWritesFiles (Named ViaC) = True +backendWritesFiles (Named JavaScript) = True +backendWritesFiles (Named Interpreter) = False +backendWritesFiles (Named NoBackend) = False + +-- | When the back end does write files, this value tells +-- the compiler in what manner of file the output should go: +-- temporary, persistent, or specific. +backendPipelineOutput :: Backend -> PipelineOutput +backendPipelineOutput (Named NCG) = Persistent +backendPipelineOutput (Named LLVM) = Persistent +backendPipelineOutput (Named ViaC) = Persistent +backendPipelineOutput (Named JavaScript) = Persistent +backendPipelineOutput (Named Interpreter) = NoOutputFile +backendPipelineOutput (Named NoBackend) = NoOutputFile + +-- | This flag tells the driver whether the back end can +-- reuse code (bytecode or object code) that has been +-- loaded dynamically. Likely true only of the interpreter. +backendCanReuseLoadedCode :: Backend -> Bool +backendCanReuseLoadedCode (Named NCG) = False +backendCanReuseLoadedCode (Named LLVM) = False +backendCanReuseLoadedCode (Named ViaC) = False +backendCanReuseLoadedCode (Named JavaScript) = False +backendCanReuseLoadedCode (Named Interpreter) = True +backendCanReuseLoadedCode (Named NoBackend) = False + +-- | It is is true of every back end except @-fno-code@ +-- that it "generates code." Surprisingly, this property +-- influences the driver in a ton of ways. Some examples: +-- +-- * If the back end does not generate code, then the +-- driver needs to turn on code generation for +-- Template Haskell (because that code needs to be +-- generated and run at compile time). +-- +-- * If the back end does not generate code, then the +-- driver does not need to deal with an output file. +-- +-- * If the back end /does/ generated code, then the +-- driver supports `HscRecomp`. If not, recompilation +-- does not need a linkable (and is automatically up +-- to date). +-- +backendGeneratesCode :: Backend -> Bool +backendGeneratesCode (Named NCG) = True +backendGeneratesCode (Named LLVM) = True +backendGeneratesCode (Named ViaC) = True +backendGeneratesCode (Named JavaScript) = True +backendGeneratesCode (Named Interpreter) = True +backendGeneratesCode (Named NoBackend) = False + +backendGeneratesCodeForHsBoot :: Backend -> Bool +backendGeneratesCodeForHsBoot (Named NCG) = True +backendGeneratesCodeForHsBoot (Named LLVM) = True +backendGeneratesCodeForHsBoot (Named ViaC) = True +backendGeneratesCodeForHsBoot (Named JavaScript) = True +backendGeneratesCodeForHsBoot (Named Interpreter) = False +backendGeneratesCodeForHsBoot (Named NoBackend) = False + +-- | When set, this flag turns on interface writing for +-- Backpack. It should probably be the same as +-- `backendGeneratesCode`, but it is kept distinct for +-- reasons described in Note [-fno-code mode]. +backendSupportsInterfaceWriting :: Backend -> Bool +backendSupportsInterfaceWriting (Named NCG) = True +backendSupportsInterfaceWriting (Named LLVM) = True +backendSupportsInterfaceWriting (Named ViaC) = True +backendSupportsInterfaceWriting (Named JavaScript) = True +backendSupportsInterfaceWriting (Named Interpreter) = True +backendSupportsInterfaceWriting (Named NoBackend) = False + +-- | When preparing code for this back end, the type +-- checker should pay attention to SPECIALISE pragmas. If +-- this flag is `False`, then the type checker ignores +-- SPECIALISE pragmas (for imported things?). +backendRespectsSpecialise :: Backend -> Bool +backendRespectsSpecialise (Named NCG) = True +backendRespectsSpecialise (Named LLVM) = True +backendRespectsSpecialise (Named ViaC) = True +backendRespectsSpecialise (Named JavaScript) = True +backendRespectsSpecialise (Named Interpreter) = False +backendRespectsSpecialise (Named NoBackend) = False + +-- | This back end wants the `mi_globals` 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`.) +backendWantsGlobalBindings :: Backend -> Bool +backendWantsGlobalBindings (Named NCG) = False +backendWantsGlobalBindings (Named LLVM) = False +backendWantsGlobalBindings (Named ViaC) = False +backendWantsGlobalBindings (Named JavaScript) = 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 +-- it is not necessary for GHC to ccompile a Cmm `Switch` +-- form into a decision tree with jump tables at the +-- leaves. +backendHasNativeSwitch :: Backend -> Bool +backendHasNativeSwitch (Named NCG) = False +backendHasNativeSwitch (Named LLVM) = True +backendHasNativeSwitch (Named ViaC) = True +backendHasNativeSwitch (Named JavaScript) = True +backendHasNativeSwitch (Named Interpreter) = False +backendHasNativeSwitch (Named NoBackend) = False + +-- | As noted in the documentation for +-- `PrimitiveImplementation`, certain primitives have +-- multiple implementations, depending on the capabilities +-- of the back end. This field signals to module +-- "GHC.StgToCmm.Prim" what implementations to use with +-- this back end. +backendPrimitiveImplementation :: Backend -> PrimitiveImplementation +backendPrimitiveImplementation (Named NCG) = NcgPrimitives +backendPrimitiveImplementation (Named LLVM) = LlvmPrimitives +backendPrimitiveImplementation (Named JavaScript) = JSPrimitives +backendPrimitiveImplementation (Named ViaC) = GenericPrimitives +backendPrimitiveImplementation (Named Interpreter) = GenericPrimitives +backendPrimitiveImplementation (Named NoBackend) = GenericPrimitives + +-- | When this value is `IsValid`, the back end is +-- compatible with vector instructions. When it is +-- `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 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."] + +-- | This flag says whether the back end supports large +-- binary blobs. See Note [Embedding large binary blobs] +-- in "GHC.CmmToAsm.Ppr". +backendSupportsEmbeddedBlobs :: Backend -> Bool +backendSupportsEmbeddedBlobs (Named NCG) = True +backendSupportsEmbeddedBlobs (Named LLVM) = False +backendSupportsEmbeddedBlobs (Named ViaC) = False +backendSupportsEmbeddedBlobs (Named JavaScript) = False +backendSupportsEmbeddedBlobs (Named Interpreter) = False +backendSupportsEmbeddedBlobs (Named NoBackend) = False + +-- | This flag tells the compiler driver that the back end +-- does not support every target platform; it supports +-- only platforms that claim NCG support. (It's set only +-- for the native code generator.) Crufty. If the driver +-- tries to use the native code generator /without/ +-- platform support, the driver fails over to the LLVM +-- back end. +backendNeedsPlatformNcgSupport :: Backend -> Bool +backendNeedsPlatformNcgSupport (Named NCG) = True +backendNeedsPlatformNcgSupport (Named LLVM) = False +backendNeedsPlatformNcgSupport (Named ViaC) = False +backendNeedsPlatformNcgSupport (Named JavaScript) = False +backendNeedsPlatformNcgSupport (Named Interpreter) = False +backendNeedsPlatformNcgSupport (Named NoBackend) = False + +-- | This flag is set if the back end can generate code +-- for proc points. If the flag is not set, then a Cmm +-- pass needs to split proc points (that is, turn each +-- proc point into a standalone procedure). +backendSupportsUnsplitProcPoints :: Backend -> Bool +backendSupportsUnsplitProcPoints (Named NCG) = True +backendSupportsUnsplitProcPoints (Named LLVM) = False +backendSupportsUnsplitProcPoints (Named ViaC) = False +backendSupportsUnsplitProcPoints (Named JavaScript) = False +backendSupportsUnsplitProcPoints (Named Interpreter) = False +backendSupportsUnsplitProcPoints (Named NoBackend) = False + +-- | This flag guides the driver in resolving issues about +-- API support on the target platform. If the flag is set, +-- then these things are true: +-- +-- * When the target platform supports /only/ an unregisterised API, +-- this backend can be replaced with compilation via C. +-- +-- * When the target does /not/ support an unregisterised API, +-- this back end can replace compilation via C. +-- +backendSwappableWithViaC :: Backend -> Bool +backendSwappableWithViaC (Named NCG) = True +backendSwappableWithViaC (Named LLVM) = True +backendSwappableWithViaC (Named ViaC) = False +backendSwappableWithViaC (Named JavaScript) = False +backendSwappableWithViaC (Named Interpreter) = False +backendSwappableWithViaC (Named NoBackend) = False + +-- | This flag is true if the back end works *only* with +-- the unregisterised ABI. +backendUnregisterisedAbiOnly :: Backend -> Bool +backendUnregisterisedAbiOnly (Named NCG) = False +backendUnregisterisedAbiOnly (Named LLVM) = False +backendUnregisterisedAbiOnly (Named ViaC) = True +backendUnregisterisedAbiOnly (Named JavaScript) = False +backendUnregisterisedAbiOnly (Named Interpreter) = False +backendUnregisterisedAbiOnly (Named NoBackend) = False + +-- | This flag is set if the back end generates C code in +-- a @.hc@ file. The flag lets the compiler driver know +-- if the command-line flag @-C@ is meaningful. +backendGeneratesHc :: Backend -> Bool +backendGeneratesHc (Named NCG) = False +backendGeneratesHc (Named LLVM) = False +backendGeneratesHc (Named ViaC) = True +backendGeneratesHc (Named JavaScript) = False +backendGeneratesHc (Named Interpreter) = False +backendGeneratesHc (Named NoBackend) = False + +-- | This flag says whether SPT (static pointer table) +-- entries will be inserted dynamically if needed. If +-- this flag is `False`, then "GHC.Iface.Tidy" should emit C +-- stubs that initialize the SPT entries. +backendSptIsDynamic :: Backend -> Bool +backendSptIsDynamic (Named NCG) = False +backendSptIsDynamic (Named LLVM) = False +backendSptIsDynamic (Named ViaC) = False +backendSptIsDynamic (Named JavaScript) = False +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 set, then the driver forces the +-- optimization level to 0, issuing a warning message if +-- the command line requested a higher optimization level. +backendForcesOptimization0 :: Backend -> Bool +backendForcesOptimization0 (Named NCG) = False +backendForcesOptimization0 (Named LLVM) = False +backendForcesOptimization0 (Named ViaC) = False +backendForcesOptimization0 (Named JavaScript) = False +backendForcesOptimization0 (Named Interpreter) = True +backendForcesOptimization0 (Named NoBackend) = False + +-- | I don't understand exactly how this works. But if +-- this flag is set *and* another condition is met, then +-- @ghc/Main.hs@ will alter the `DynFlags` so that all the +-- `hostFullWays` are asked for. It is set only for the interpreter. +backendNeedsFullWays :: Backend -> Bool +backendNeedsFullWays (Named NCG) = False +backendNeedsFullWays (Named LLVM) = False +backendNeedsFullWays (Named ViaC) = False +backendNeedsFullWays (Named JavaScript) = False +backendNeedsFullWays (Named Interpreter) = True +backendNeedsFullWays (Named NoBackend) = False + +-- | This flag is also special for the interpreter: if a +-- message about a module needs to be shown, do we know +-- anything special about where the module came from? The +-- Boolean argument is a `recomp` flag. +backendSpecialModuleSource :: Backend -> Bool -> Maybe String +backendSpecialModuleSource (Named NCG) = const Nothing +backendSpecialModuleSource (Named LLVM) = const Nothing +backendSpecialModuleSource (Named ViaC) = const Nothing +backendSpecialModuleSource (Named JavaScript) = const Nothing +backendSpecialModuleSource (Named Interpreter) = \b -> if b then Just "interpreted" else Nothing +backendSpecialModuleSource (Named NoBackend) = const (Just "nothing") + +-- | This flag says whether the back end supports Haskell +-- Program Coverage (HPC). If not, the compiler driver +-- will ignore the `-fhpc` option (and will issue a +-- warning message if it is used). +backendSupportsHpc :: Backend -> Bool +backendSupportsHpc (Named NCG) = True +backendSupportsHpc (Named LLVM) = True +backendSupportsHpc (Named ViaC) = True +backendSupportsHpc (Named JavaScript) = False +backendSupportsHpc (Named Interpreter) = False +backendSupportsHpc (Named NoBackend) = True + +-- | This flag says whether the back end supports foreign +-- import of C functions. ("Supports" means "does not +-- barf on," so @-fno-code@ supports foreign C imports.) +backendSupportsCImport :: Backend -> Bool +backendSupportsCImport (Named NCG) = True +backendSupportsCImport (Named LLVM) = True +backendSupportsCImport (Named ViaC) = True +backendSupportsCImport (Named JavaScript) = True +backendSupportsCImport (Named Interpreter) = True +backendSupportsCImport (Named NoBackend) = True + +-- | This flag says whether the back end supports foreign +-- export of Haskell functions to C. +backendSupportsCExport :: Backend -> Bool +backendSupportsCExport (Named NCG) = True +backendSupportsCExport (Named LLVM) = True +backendSupportsCExport (Named ViaC) = True +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. +-- This (defunctionalized) function produces those +-- options, if any. An IO action may be necessary in +-- order to interrogate external tools about what version +-- they are, for example. +-- +-- The function's type is +-- @ +-- Logger -> DynFlags -> IO [String] +-- @ +-- +-- This field is usually defaulted. +backendCDefs :: Backend -> DefunctionalizedCDefs +backendCDefs (Named NCG) = NoCDefs +backendCDefs (Named LLVM) = LlvmCDefs +backendCDefs (Named ViaC) = NoCDefs +backendCDefs (Named JavaScript) = NoCDefs +backendCDefs (Named Interpreter) = NoCDefs +backendCDefs (Named NoBackend) = NoCDefs + +-- | This (defunctionalized) function generates code and +-- writes it to a file. The type of the function is +-- +-- > Logger +-- > -> DynFlags +-- > -> Module -- ^ module being compiled +-- > -> ModLocation +-- > -> FilePath -- ^ Where to write output +-- > -> Set UnitId -- ^ dependencies +-- > -> Stream IO RawCmmGroup a -- results from `StgToCmm` +-- > -> IO a +backendCodeOutput :: Backend -> DefunctionalizedCodeOutput +backendCodeOutput (Named NCG) = NcgCodeOutput +backendCodeOutput (Named LLVM) = LlvmCodeOutput +backendCodeOutput (Named ViaC) = ViaCCodeOutput +backendCodeOutput (Named JavaScript) = JSCodeOutput +backendCodeOutput (Named Interpreter) = panic "backendCodeOutput: interpreterBackend" +backendCodeOutput (Named NoBackend) = panic "backendCodeOutput: noBackend" + +backendUseJSLinker :: Backend -> Bool +backendUseJSLinker (Named NCG) = False +backendUseJSLinker (Named LLVM) = False +backendUseJSLinker (Named ViaC) = False +backendUseJSLinker (Named JavaScript) = True +backendUseJSLinker (Named Interpreter) = False +backendUseJSLinker (Named NoBackend) = False + +-- | This (defunctionalized) function tells the compiler +-- driver what else has to be run after code output. +-- The type of the function is +-- +-- > +-- > TPipelineClass TPhase m +-- > => PipeEnv +-- > -> HscEnv +-- > -> Maybe ModLocation +-- > -> FilePath +-- > -> m (Maybe FilePath) +backendPostHscPipeline :: Backend -> DefunctionalizedPostHscPipeline +backendPostHscPipeline (Named NCG) = NcgPostHscPipeline +backendPostHscPipeline (Named LLVM) = LlvmPostHscPipeline +backendPostHscPipeline (Named ViaC) = ViaCPostHscPipeline +backendPostHscPipeline (Named JavaScript) = JSPostHscPipeline +backendPostHscPipeline (Named Interpreter) = NoPostHscPipeline +backendPostHscPipeline (Named NoBackend) = NoPostHscPipeline + +-- | Somewhere in the compiler driver, when compiling +-- Haskell source (as opposed to a boot file or a sig +-- file), it needs to know what to do with the code that +-- the `backendCodeOutput` writes to a file. This `Phase` +-- value gives instructions like "run the C compiler", +-- "run the assembler," or "run the LLVM Optimizer." +backendNormalSuccessorPhase :: Backend -> Phase +backendNormalSuccessorPhase (Named NCG) = As False +backendNormalSuccessorPhase (Named LLVM) = LlvmOpt +backendNormalSuccessorPhase (Named ViaC) = HCc +backendNormalSuccessorPhase (Named JavaScript) = StopLn +backendNormalSuccessorPhase (Named Interpreter) = StopLn +backendNormalSuccessorPhase (Named NoBackend) = StopLn + +-- | Name of the back end, if any. Used to migrate legacy +-- clients of the GHC API. Code within the GHC source +-- tree should not refer to a back end's name. +backendName :: Backend -> BackendName +backendName (Named NCG) = NCG +backendName (Named LLVM) = LLVM +backendName (Named ViaC) = ViaC +backendName (Named JavaScript) = JavaScript +backendName (Named Interpreter) = Interpreter +backendName (Named NoBackend) = NoBackend + + + +-- | A list of all back ends. They are ordered as we wish them to +-- appear when they are enumerated in error messages. + +allBackends :: [Backend] +allBackends = [ ncgBackend + , llvmBackend + , viaCBackend + , jsBackend + , interpreterBackend + , noBackend + ] + +-- | When foreign C import or export is invalid, the carried value +-- enumerates the /valid/ back ends. + +backendValidityOfCImport, backendValidityOfCExport :: Backend -> Validity' [Backend] + +backendValidityOfCImport backend = + if backendSupportsCImport backend then + IsValid + else + NotValid $ filter backendSupportsCImport allBackends + +backendValidityOfCExport backend = + if backendSupportsCExport backend then + IsValid + else + NotValid $ filter backendSupportsCExport allBackends + + + + +{- +Note [Backend Defunctionalization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I had hoped to include code-output and post-hsc-pipeline functions +directly in the `Backend` record itself. But this agenda was derailed +by mutual recursion in the types: + + - A `DynFlags` record contains a back end of type `Backend`. + - A `Backend` contains a code-output function. + - A code-output function takes Cmm as input. + - Cmm can include a `CLabel`. + - A `CLabel` can have elements that are defined in + `GHC.Driver.Session`, where `DynFlags` is defined. + +There is also a nasty issue in the values: a typical post-backend +pipeline function both depends on and is depended upon by functions in +"GHC.Driver.Pipeline". + +I'm cut the Gordian not by removing the function types from the +`Backend` record. Instead, a function is represented by its /name/. +This representation is an example of an old trick called +/defunctionalization/, which has been used in both compilers and +interpreters for languages with first-class, nested functions. Here, +a function's name is a value of an algebraic data type. For example, +a code-output function is represented by a value of this type: + + data DefunctionalizedCodeOutput + = NcgCodeOutput + | ViaCCodeOutput + | LlvmCodeOutput + +Such a function may be applied in one of two ways: + + - In this particular example, a `case` expression in module + "GHC.Driver.CodeOutput" discriminates on the value and calls the + designated function. + + - In another example, a function of type `DefunctionalizedCDefs` is + applied by calling function `applyCDefs`, which has this type: + + @ + applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String] + @ + + Function `applyCDefs` is defined in module "GHC.SysTools.Cpp". + +I don't love this solution, but defunctionalization is a standard +thing, and it makes the meanings of the enumeration values clear. + +Anyone defining a new back end will need to extend both the +`DefunctionalizedCodeOutput` type and the corresponding apply +function. +-} diff --git a/GHC/Driver/Backend/Internal.hs b/GHC/Driver/Backend/Internal.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Backend/Internal.hs @@ -0,0 +1,33 @@ +{-| +Module : GHC.Driver.Backend.Internal +Description : Interface for migrating legacy clients of the GHC API + +In versions of GHC up through 9.2, a `Backend` was represented only by +its name. This module is meant to aid clients written against the GHC +API, versions 9.2 and older. The module provides an alternative way +to name any back end found in GHC 9.2. /Code within the GHC source +tree should not import this module./ (#20927). + +Only back ends found in version 9.2 have names. + +-} + +module GHC.Driver.Backend.Internal + ( -- * Name of a back end + BackendName(..) + ) + +where + + + +import GHC.Prelude + +data BackendName + = NCG -- ^ Names the native code generator backend. + | LLVM -- ^ Names the LLVM backend. + | ViaC -- ^ Names the Via-C backend. + | JavaScript -- ^ Names the JS backend. + | Interpreter -- ^ Names the ByteCode interpreter. + | NoBackend -- ^ Names the `-fno-code` backend. + deriving (Eq, Show) diff --git a/GHC/Driver/Backpack.hs b/GHC/Driver/Backpack.hs --- a/GHC/Driver/Backpack.hs +++ b/GHC/Driver/Backpack.hs @@ -20,6 +20,7 @@ import GHC.Prelude +import GHC.Driver.Backend -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax import GHC.Driver.Config.Finder (initFinderOpts) @@ -105,8 +106,9 @@ -- Not doing so caused #20396. -- Cribbed from: preprocessFile / GHC.Driver.Pipeline liftIO $ checkProcessArgsResult unhandled_flags - liftIO $ printOrThrowDiagnostics logger (initDiagOpts dflags) (GhcPsMessage <$> p_warns) - liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns + let print_config = initPrintConfig dflags + liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcPsMessage <$> p_warns) + liftIO $ handleFlagWarnings logger print_config (initDiagOpts dflags) warns -- TODO: Preprocessing not implemented buf <- liftIO $ hGetStringBuffer src_filename @@ -188,7 +190,7 @@ hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env mk_temp_dflags unit_state dflags = dflags { backend = case session_type of - TcSession -> NoBackend + TcSession -> noBackend _ -> backend dflags , ghcLink = case session_type of TcSession -> NoLink @@ -214,7 +216,7 @@ -- Make sure to write interfaces when we are type-checking -- indefinite packages. TcSession - | backend dflags /= NoBackend + | backendSupportsInterfaceWriting $ backend dflags -> EnumSet.insert Opt_WriteInterface (generalFlags dflags) _ -> generalFlags dflags @@ -339,7 +341,7 @@ -- Compile relevant only hsc_env <- getSession let home_mod_infos = eltsUDFM (hsc_HPT hsc_env) - linkables = map (expectJust "bkp link" . hm_linkable) + 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) @@ -595,7 +597,9 @@ mkUserStyle (QueryQualify neverQualifyNames alwaysQualifyModules - neverQualifyPackages) AllTheWay + neverQualifyPackages + alwaysPrintPromTick) + AllTheWay -- | Message when we initially process a Backpack unit. msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () @@ -794,14 +798,16 @@ ms_ghc_prim_import = False, ms_parsed_mod = Just (HsParsedModule { hpm_module = L loc (HsModule { - hsmodAnn = noAnn, - hsmodLayout = NoLayoutInfo, + hsmodExt = XModulePs { + hsmodAnn = noAnn, + hsmodLayout = NoLayoutInfo, + hsmodDeprecMessage = Nothing, + hsmodHaddockModHeader = Nothing + }, hsmodName = Just (L (noAnnSrcSpan loc) mod_name), hsmodExports = Nothing, hsmodImports = [], - hsmodDecls = [], - hsmodDeprecMessage = Nothing, - hsmodHaddockModHeader = Nothing + hsmodDecls = [] }), hpm_src_files = [] }), @@ -815,7 +821,7 @@ summariseDecl :: PackageName -> HscSource -> Located ModuleName - -> Located HsModule + -> Located (HsModule GhcPs) -> [NodeKey] -> BkpM ModuleGraphNode summariseDecl pn hsc_src (L _ modname) hsmod home_keys = hsModuleToModSummary home_keys pn hsc_src modname hsmod @@ -829,7 +835,7 @@ -> PackageName -> HscSource -> ModuleName - -> Located HsModule + -> Located (HsModule GhcPs) -> BkpM ModuleGraphNode hsModuleToModSummary home_keys pn hsc_src modname hsmod = do @@ -935,4 +941,4 @@ newUnitId :: UnitId -> Maybe FastString -> UnitId newUnitId uid mhash = case mhash of Nothing -> uid - Just hash -> UnitId (unitIdFS uid `appendFS` mkFastString "+" `appendFS` hash) + Just hash -> UnitId (concatFS [unitIdFS uid, fsLit "+", hash]) diff --git a/GHC/Driver/Backpack/Syntax.hs b/GHC/Driver/Backpack/Syntax.hs --- a/GHC/Driver/Backpack/Syntax.hs +++ b/GHC/Driver/Backpack/Syntax.hs @@ -23,7 +23,6 @@ import GHC.Types.SrcLoc import GHC.Types.SourceFile -import GHC.Unit.Module.Name import GHC.Unit.Types import GHC.Unit.Info @@ -65,7 +64,7 @@ -- | A declaration in a package, e.g. a module or signature definition, -- or an include. data HsUnitDecl n - = DeclD HscSource (Located ModuleName) (Located HsModule) + = DeclD HscSource (Located ModuleName) (Located (HsModule GhcPs)) | IncludeD (IncludeDecl n) type LHsUnitDecl n = Located (HsUnitDecl n) diff --git a/GHC/Driver/CmdLine.hs b/GHC/Driver/CmdLine.hs --- a/GHC/Driver/CmdLine.hs +++ b/GHC/Driver/CmdLine.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------- @@ -38,7 +39,7 @@ import GHC.ResponseFile import Control.Exception (IOException, catch) -import Control.Monad (liftM, ap) +import Control.Monad (ap) import Control.Monad.IO.Class -------------------------------------------------------- @@ -138,9 +139,7 @@ newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg -> Errs -> Warns -> m (Errs, Warns, a) } - -instance Monad m => Functor (EwM m) where - fmap = liftM + deriving (Functor) instance Monad m => Applicative (EwM m) where pure v = EwM (\_ e w -> return (e, w, v)) diff --git a/GHC/Driver/CodeOutput.hs b/GHC/Driver/CodeOutput.hs --- a/GHC/Driver/CodeOutput.hs +++ b/GHC/Driver/CodeOutput.hs @@ -17,6 +17,7 @@ import GHC.Prelude import GHC.Platform import GHC.ForeignSrcLang +import GHC.Data.FastString import GHC.CmmToAsm ( nativeCodeGen ) import GHC.CmmToLlvm ( llvmCodeGen ) @@ -27,9 +28,10 @@ import GHC.Cmm.CLabel import GHC.Driver.Session -import GHC.Driver.Config.Finder (initFinderOpts) -import GHC.Driver.Config.CmmToAsm (initNCGConfig) -import GHC.Driver.Config.CmmToLlvm (initLlvmCgConfig) +import GHC.Driver.Config.Finder ( initFinderOpts ) +import GHC.Driver.Config.CmmToAsm ( initNCGConfig ) +import GHC.Driver.Config.CmmToLlvm ( initLlvmCgConfig ) +import GHC.Driver.LlvmConfigCache (LlvmConfigCache) import GHC.Driver.Ppr import GHC.Driver.Backend @@ -42,10 +44,10 @@ import GHC.Utils.Error import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Utils.Logger -import GHC.Utils.Exception (bracket) +import GHC.Utils.Exception ( bracket ) import GHC.Utils.Ppr (Mode(..)) +import GHC.Utils.Panic.Plain ( pgmError ) import GHC.Unit import GHC.Unit.Finder ( mkStubPaths ) @@ -73,6 +75,7 @@ :: forall a. Logger -> TmpFs + -> LlvmConfigCache -> DynFlags -> UnitState -> Module @@ -87,7 +90,7 @@ (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}), [(ForeignSrcLang, FilePath)]{-foreign_fps-}, a) -codeOutput logger tmpfs 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 cmm_stream = do { @@ -118,13 +121,12 @@ ; emitInitializerDecls this_mod stubs ; return (stubs, a) } - ; (stubs, a) <- case backend dflags of - NCG -> outputAsm logger dflags this_mod location filenm - final_stream - ViaC -> outputC logger dflags filenm final_stream pkg_deps - LLVM -> outputLlvm logger dflags filenm final_stream - Interpreter -> panic "codeOutput: Interpreter" - NoBackend -> panic "codeOutput: NoBackend" + ; (stubs, a) <- case backendCodeOutput (backend dflags) of + NcgCodeOutput -> outputAsm logger dflags this_mod location filenm + final_stream + ViaCCodeOutput -> outputC logger dflags filenm final_stream pkg_deps + LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm 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) } @@ -174,7 +176,7 @@ "C backend output" FormatC doc - let ctx = initSDocContext dflags (PprCode CStyle) + let ctx = initSDocContext dflags PprCode printSDocLn ctx LeftMode h doc Stream.consume cmm_stream id writeC @@ -199,7 +201,7 @@ let ncg_config = initNCGConfig dflags this_mod {-# SCC "OutputAsm" #-} doOutput filenm $ \h -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen logger ncg_config location h ncg_uniqs cmm_stream + nativeCodeGen logger (toolSettings dflags) ncg_config location h ncg_uniqs cmm_stream {- ************************************************************************ @@ -209,9 +211,9 @@ ************************************************************************ -} -outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a -outputLlvm logger dflags filenm cmm_stream = do - lcg_config <- initLlvmCgConfig logger dflags +outputLlvm :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a +outputLlvm logger llvm_config dflags filenm 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 @@ -219,6 +221,18 @@ {- ************************************************************************ * * +\subsection{JavaScript} +* * +************************************************************************ +-} +outputJS :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO 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!" + +{- +************************************************************************ +* * \subsection{Foreign import/export} * * ************************************************************************ @@ -254,11 +268,11 @@ ForeignStubs (CHeader h_code) (CStub c_code _ _) -> do let - stub_c_output_d = pprCode CStyle c_code + stub_c_output_d = pprCode c_code stub_c_output_w = showSDoc dflags stub_c_output_d -- Header file protos for "foreign export"ed functions. - stub_h_output_d = pprCode CStyle h_code + stub_h_output_d = pprCode h_code stub_h_output_w = showSDoc dflags stub_h_output_d createDirectoryIfMissing True (takeDirectory stub_h) @@ -281,7 +295,7 @@ -- wrapper code mentions the ffi_arg type, which comes from ffi.h ffi_includes - | platformMisc_libFFI $ platformMisc dflags = "#include \"rts/ghc_ffi.h\"\n" + | platformMisc_libFFI $ platformMisc dflags = "#include \n" | otherwise = "" stub_h_file_exists @@ -311,8 +325,7 @@ cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n" --- Don't use doOutput for dumping the f. export stubs --- since it is more than likely that the stubs file will +-- It is more than likely that the stubs file will -- turn out to be empty, in which case no file should be created. outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool outputForeignStubs_help _fname "" _header _footer = return False @@ -332,7 +345,8 @@ = {-# SCC profilingInitCode #-} initializerCStub platform fn_name decls body where - fn_name = mkInitializerStubLabel this_mod "prof_init" + pdocC = pprCLabel platform + fn_name = mkInitializerStubLabel this_mod (fsLit "prof_init") decls = vcat $ map emit_cc_decl local_CCs ++ map emit_ccs_decl singleton_CCSs @@ -344,22 +358,22 @@ ] emit_cc_decl cc = text "extern CostCentre" <+> cc_lbl <> text "[];" - where cc_lbl = pdoc platform (mkCCLabel cc) + where cc_lbl = pdocC (mkCCLabel cc) local_cc_list_label = text "local_cc_" <> ppr this_mod emit_cc_list ccs = text "static CostCentre *" <> local_cc_list_label <> text "[] =" - <+> braces (vcat $ [ pdoc platform (mkCCLabel cc) <> comma + <+> braces (vcat $ [ pdocC (mkCCLabel cc) <> comma | cc <- ccs ] ++ [text "NULL"]) <> semi emit_ccs_decl ccs = text "extern CostCentreStack" <+> ccs_lbl <> text "[];" - where ccs_lbl = pdoc platform (mkCCSLabel ccs) + where ccs_lbl = pdocC (mkCCSLabel ccs) singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod emit_ccs_list ccs = text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] =" - <+> braces (vcat $ [ pdoc platform (mkCCSLabel cc) <> comma + <+> braces (vcat $ [ pdocC (mkCCSLabel cc) <> comma | cc <- ccs ] ++ [text "NULL"]) <> semi @@ -375,12 +389,11 @@ | not do_info_table = mempty | otherwise = initializerCStub platform fn_nm ipe_buffer_decl body where - fn_nm = mkInitializerStubLabel this_mod "ip_init" + fn_nm = mkInitializerStubLabel this_mod (fsLit "ip_init") body = text "registerInfoProvList" <> parens (text "&" <> ipe_buffer_label) <> semi - ipe_buffer_label = pprCLabel platform CStyle (mkIPELabel this_mod) + ipe_buffer_label = pprCLabel platform (mkIPELabel this_mod) ipe_buffer_decl = text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";" - diff --git a/GHC/Driver/Config.hs b/GHC/Driver/Config.hs --- a/GHC/Driver/Config.hs +++ b/GHC/Driver/Config.hs @@ -29,6 +29,7 @@ initSimpleOpts dflags = SimpleOpts { so_uf_opts = unfoldingOpts dflags , so_co_opts = initOptCoercionOpts dflags + , so_eta_red = gopt Opt_DoEtaReduction dflags } -- | Extract BCO options from DynFlags 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 @@ -3,7 +3,6 @@ ) where import GHC.Cmm.Config -import GHC.Cmm.Switch (backendSupportsSwitch) import GHC.Driver.Session import GHC.Driver.Backend @@ -19,10 +18,12 @@ , cmmDoLinting = gopt Opt_DoCmmLinting dflags , cmmOptElimCommonBlks = gopt Opt_CmmElimCommonBlocks dflags , cmmOptSink = gopt Opt_CmmSink dflags + , cmmOptThreadSanitizer = gopt Opt_CmmThreadSanitizer dflags , cmmGenStackUnwindInstr = debugLevel dflags > 0 , cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags - , cmmDoCmmSwitchPlans = not . backendSupportsSwitch . backend $ dflags - , cmmSplitProcPoints = (backend dflags /= NCG) + , cmmDoCmmSwitchPlans = not (backendHasNativeSwitch (backend dflags)) + || platformArch platform == ArchWasm32 + , cmmSplitProcPoints = not (backendSupportsUnsplitProcPoints (backend dflags)) || not (platformTablesNextToCode platform) || usingInconsistentPicReg } diff --git a/GHC/Driver/Config/Cmm/Parser.hs b/GHC/Driver/Config/Cmm/Parser.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Cmm/Parser.hs @@ -0,0 +1,25 @@ +module GHC.Driver.Config.Cmm.Parser + ( initCmmParserConfig + ) where + +import GHC.Cmm.Parser.Config + +import GHC.Driver.Config.Parser +import GHC.Driver.Config.StgToCmm +import GHC.Driver.Session + +import GHC.Utils.Panic + +initPDConfig :: DynFlags -> PDConfig +initPDConfig dflags = PDConfig + { pdProfile = targetProfile dflags + , pdSanitizeAlignment = gopt Opt_AlignmentSanitisation dflags + } + +initCmmParserConfig :: DynFlags -> CmmParserConfig +initCmmParserConfig dflags = CmmParserConfig + { cmmpParserOpts = initParserOpts dflags + , cmmpPDConfig = initPDConfig dflags + , cmmpStgToCmmConfig = initStgToCmmConfig dflags (panic "initCmmParserConfig: no module") + } + 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 @@ -18,7 +18,7 @@ initNCGConfig dflags this_mod = NCGConfig { ncgPlatform = targetPlatform dflags , ncgThisModule = this_mod - , ncgAsmContext = initSDocContext dflags (PprCode AsmStyle) + , ncgAsmContext = initSDocContext dflags PprCode , ncgProcAlignment = cmmProcAlignment dflags , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags , ncgPIC = positionIndependent dflags 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 @@ -1,22 +1,26 @@ module GHC.Driver.Config.CmmToLlvm ( initLlvmCgConfig - ) where + ) +where import GHC.Prelude import GHC.Driver.Session +import GHC.Driver.LlvmConfigCache import GHC.Platform import GHC.CmmToLlvm.Config import GHC.SysTools.Tasks + import GHC.Utils.Outputable import GHC.Utils.Logger -- | Initialize the Llvm code generator configuration from DynFlags -initLlvmCgConfig :: Logger -> DynFlags -> IO LlvmCgConfig -initLlvmCgConfig logger dflags = do +initLlvmCgConfig :: Logger -> LlvmConfigCache -> DynFlags -> IO LlvmCgConfig +initLlvmCgConfig logger config_cache dflags = do version <- figureLlvmVersion logger dflags + llvm_config <- readLlvmConfigCache config_cache pure $! LlvmCgConfig { llvmCgPlatform = targetPlatform dflags - , llvmCgContext = initSDocContext dflags (PprCode CStyle) + , llvmCgContext = initSDocContext dflags PprCode , llvmCgFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags , llvmCgSplitSection = gopt Opt_SplitSections dflags , llvmCgBmiVersion = case platformArch (targetPlatform dflags) of @@ -26,5 +30,5 @@ , llvmCgLlvmVersion = version , llvmCgDoWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags , llvmCgLlvmTarget = platformMisc_llvmTarget $! platformMisc dflags - , llvmCgLlvmConfig = llvmConfig dflags + , llvmCgLlvmConfig = llvm_config } diff --git a/GHC/Driver/Config/Core/Lint.hs b/GHC/Driver/Config/Core/Lint.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Lint.hs @@ -0,0 +1,182 @@ +module GHC.Driver.Config.Core.Lint + ( endPass + , endPassHscEnvIO + , lintCoreBindings + , initEndPassConfig + , initLintPassResultConfig + , initLintConfig + ) where + +import GHC.Prelude + +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Config.Diagnostic + +import GHC.Core +import GHC.Core.Lint +import GHC.Core.Lint.Interactive +import GHC.Core.Opt.Pipeline.Types +import GHC.Core.Opt.Simplify ( SimplifyOpts(..) ) +import GHC.Core.Opt.Simplify.Env ( SimplMode(..) ) +import GHC.Core.Opt.Monad +import GHC.Core.Coercion + +import GHC.Types.Basic ( CompilerPhase(..) ) + +import GHC.Utils.Outputable as Outputable + +{- +These functions are not CoreM monad stuff, but they probably ought to +be, and it makes a convenient place for them. They print out stuff +before and after core passes, and do Core Lint when necessary. +-} + +endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () +endPass pass binds rules + = do { hsc_env <- getHscEnv + ; name_ppr_ctx <- getNamePprCtx + ; liftIO $ endPassHscEnvIO hsc_env + name_ppr_ctx pass binds rules + } + +endPassHscEnvIO :: HscEnv -> NamePprCtx + -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () +endPassHscEnvIO hsc_env name_ppr_ctx pass binds rules + = do { let dflags = hsc_dflags hsc_env + ; endPassIO + (hsc_logger hsc_env) + (initEndPassConfig dflags (interactiveInScope $ hsc_IC hsc_env) name_ppr_ctx pass) + binds rules + } + +-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. +lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs +lintCoreBindings dflags coreToDo vars -- binds + = lintCoreBindings' $ LintConfig + { l_diagOpts = initDiagOpts dflags + , l_platform = targetPlatform dflags + , l_flags = perPassFlags dflags coreToDo + , l_vars = vars + } + +initEndPassConfig :: DynFlags -> [Var] -> NamePprCtx -> CoreToDo -> EndPassConfig +initEndPassConfig dflags extra_vars name_ppr_ctx pass = EndPassConfig + { ep_dumpCoreSizes = not (gopt Opt_SuppressCoreSizes dflags) + , ep_lintPassResult = if gopt Opt_DoCoreLinting dflags + then Just $ initLintPassResultConfig dflags extra_vars pass + else Nothing + , ep_namePprCtx = name_ppr_ctx + , ep_dumpFlag = coreDumpFlag pass + , ep_prettyPass = ppr pass + , ep_passDetails = pprPassDetails pass + } + +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 CoreDoCallArity = Just Opt_D_dump_call_arity +coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify +coreDumpFlag (CoreDoDemand {}) = Just Opt_D_dump_stranal +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 CoreCSE = Just Opt_D_dump_cse +coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt +coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds +coreDumpFlag CoreTidy = Just Opt_D_dump_simpl +coreDumpFlag CorePrep = Just Opt_D_dump_prep + +coreDumpFlag CoreAddCallerCcs = Nothing +coreDumpFlag CoreAddLateCcs = Nothing +coreDumpFlag CoreDoPrintCore = Nothing +coreDumpFlag (CoreDoRuleCheck {}) = Nothing +coreDumpFlag CoreDoNothing = Nothing +coreDumpFlag (CoreDoPasses {}) = Nothing + +initLintPassResultConfig :: DynFlags -> [Var] -> CoreToDo -> LintPassResultConfig +initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig + { lpr_diagOpts = initDiagOpts dflags + , lpr_platform = targetPlatform dflags + , lpr_makeLintFlags = perPassFlags dflags pass + , lpr_showLintWarnings = showLintWarnings pass + , lpr_passPpr = ppr pass + , lpr_localsInScope = extra_vars + } + +showLintWarnings :: CoreToDo -> Bool +-- Disable Lint warnings on the first simplifier pass, because +-- there may be some INLINE knots still tied, which is tiresomely noisy +showLintWarnings (CoreDoSimplify cfg) = case sm_phase (so_mode cfg) of + InitialPhase -> False + _ -> True +showLintWarnings _ = True + +perPassFlags :: DynFlags -> CoreToDo -> LintFlags +perPassFlags dflags pass + = (defaultLintFlags dflags) + { lf_check_global_ids = check_globals + , lf_check_inline_loop_breakers = check_lbs + , lf_check_static_ptrs = check_static_ptrs + , lf_check_linearity = check_linearity + , lf_check_fixed_rep = check_fixed_rep } + where + -- In the output of the desugarer, before optimisation, + -- 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. + check_fixed_rep = case pass of + CoreDesugar -> False + _ -> True + + -- See Note [Checking for global Ids] + check_globals = case pass of + CoreTidy -> False + CorePrep -> False + _ -> True + + -- See Note [Checking for INLINE loop breakers] + check_lbs = case pass of + CoreDesugar -> False + CoreDesugarOpt -> False + _ -> True + + -- See Note [Checking StaticPtrs] + check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere + | otherwise = case pass of + CoreDoFloatOutwards _ -> AllowAtTopLevel + CoreTidy -> RejectEverywhere + CorePrep -> AllowAtTopLevel + _ -> AllowAnywhere + + -- See Note [Linting linearity] + check_linearity = gopt Opt_DoLinearCoreLinting dflags || ( + case pass of + CoreDesugar -> True + _ -> False) + +initLintConfig :: DynFlags -> [Var] -> LintConfig +initLintConfig dflags vars =LintConfig + { l_diagOpts = initDiagOpts dflags + , l_platform = targetPlatform dflags + , l_flags = defaultLintFlags dflags + , l_vars = vars + } + +defaultLintFlags :: DynFlags -> LintFlags +defaultLintFlags dflags = LF { lf_check_global_ids = False + , lf_check_inline_loop_breakers = True + , lf_check_static_ptrs = AllowAnywhere + , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags + , lf_report_unsat_syns = True + , lf_check_fixed_rep = True + } diff --git a/GHC/Driver/Config/Core/Lint/Interactive.hs b/GHC/Driver/Config/Core/Lint/Interactive.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Lint/Interactive.hs @@ -0,0 +1,35 @@ +module GHC.Driver.Config.Core.Lint.Interactive + ( lintInteractiveExpr + ) where + +import GHC.Prelude + +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Config.Core.Lint + +import GHC.Core +import GHC.Core.Ppr + +import GHC.Core.Lint +import GHC.Core.Lint.Interactive + +--import GHC.Runtime.Context + +import GHC.Data.Bag + +import GHC.Utils.Outputable as Outputable + +lintInteractiveExpr :: SDoc -- ^ The source of the linted expression + -> HscEnv + -> CoreExpr -> IO () +lintInteractiveExpr what hsc_env expr + | not (gopt Opt_DoCoreLinting dflags) + = return () + | Just err <- lintExpr (initLintConfig dflags $ interactiveInScope $ hsc_IC hsc_env) expr + = displayLintResults logger False what (pprCoreExpr expr) (emptyBag, err) + | otherwise + = return () + where + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env diff --git a/GHC/Driver/Config/Core/Opt/Arity.hs b/GHC/Driver/Config/Core/Opt/Arity.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Opt/Arity.hs @@ -0,0 +1,15 @@ +module GHC.Driver.Config.Core.Opt.Arity + ( initArityOpts + ) where + +import GHC.Prelude () + +import GHC.Driver.Session + +import GHC.Core.Opt.Arity + +initArityOpts :: DynFlags -> ArityOpts +initArityOpts dflags = ArityOpts + { ao_ped_bot = gopt Opt_PedanticBottoms dflags + , ao_dicts_cheap = gopt Opt_DictsCheap dflags + } diff --git a/GHC/Driver/Config/Core/Opt/LiberateCase.hs b/GHC/Driver/Config/Core/Opt/LiberateCase.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Opt/LiberateCase.hs @@ -0,0 +1,15 @@ +module GHC.Driver.Config.Core.Opt.LiberateCase + ( initLiberateCaseOpts + ) where + +import GHC.Driver.Session + +import GHC.Core.Opt.LiberateCase ( LibCaseOpts(..) ) + +-- | Initialize configuration for the liberate case Core optomization +-- pass. +initLiberateCaseOpts :: DynFlags -> LibCaseOpts +initLiberateCaseOpts dflags = LibCaseOpts + { lco_threshold = liberateCaseThreshold dflags + , lco_unfolding_opts = unfoldingOpts dflags + } diff --git a/GHC/Driver/Config/Core/Opt/Simplify.hs b/GHC/Driver/Config/Core/Opt/Simplify.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Opt/Simplify.hs @@ -0,0 +1,91 @@ +module GHC.Driver.Config.Core.Opt.Simplify + ( initSimplifyExprOpts + , initSimplifyOpts + , initSimplMode + , initGentleSimplMode + ) where + +import GHC.Prelude + +import GHC.Core.Rules ( RuleBase ) +import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) +import GHC.Core.Opt.Simplify ( SimplifyExprOpts(..), SimplifyOpts(..) ) +import GHC.Core.Opt.Simplify.Env ( FloatEnable(..), SimplMode(..) ) +import GHC.Core.Opt.Simplify.Monad ( TopEnvConfig(..) ) + +import GHC.Driver.Config ( initOptCoercionOpts ) +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.Runtime.Context ( InteractiveContext(..) ) + +import GHC.Types.Basic ( CompilerPhase(..) ) +import GHC.Types.Var ( Var ) + +initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts +initSimplifyExprOpts dflags ic = SimplifyExprOpts + { se_fam_inst = snd $ ic_instances ic + , se_mode = (initSimplMode dflags InitialPhase "GHCi") + { sm_inline = False + -- Do not do any inlining, in case we expose some + -- unboxed tuple stuff that confuses the bytecode + -- interpreter + } + , se_top_env_cfg = TopEnvConfig + { te_history_size = historySize dflags + , te_tick_factor = simplTickFactor dflags + } + } + +initSimplifyOpts :: DynFlags -> [Var] -> Int -> SimplMode -> RuleBase -> SimplifyOpts +initSimplifyOpts dflags extra_vars iterations mode hpt_rule_base = let + -- This is a particularly ugly construction, but we will get rid of it in !8341. + opts = SimplifyOpts + { so_dump_core_sizes = not $ gopt Opt_SuppressCoreSizes dflags + , so_iterations = iterations + , so_mode = mode + , so_pass_result_cfg = if gopt Opt_DoCoreLinting dflags + then Just $ initLintPassResultConfig dflags extra_vars + (CoreDoSimplify opts) + else Nothing + , so_hpt_rules = hpt_rule_base + , so_top_env_cfg = TopEnvConfig { te_history_size = historySize dflags + , te_tick_factor = simplTickFactor dflags } + } + in opts + +initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode +initSimplMode dflags phase name = SimplMode + { sm_names = [name] + , sm_phase = phase + , sm_rules = gopt Opt_EnableRewriteRules dflags + , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags + , sm_cast_swizzle = True + , sm_inline = True + , sm_uf_opts = unfoldingOpts dflags + , sm_case_case = True + , sm_pre_inline = gopt Opt_SimplPreInlining dflags + , sm_float_enable = floatEnable dflags + , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags + , sm_arity_opts = initArityOpts dflags + , sm_rule_opts = initRuleOpts dflags + , sm_case_folding = gopt Opt_CaseFolding dflags + , sm_case_merge = gopt Opt_CaseMerge dflags + , sm_co_opt_opts = initOptCoercionOpts dflags + } + +initGentleSimplMode :: DynFlags -> SimplMode +initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle") + { -- Don't do case-of-case transformations. + -- This makes full laziness work better + sm_case_case = False + } + +floatEnable :: DynFlags -> FloatEnable +floatEnable dflags = + case (gopt Opt_LocalFloatOut dflags, gopt Opt_LocalFloatOutTopLevel dflags) of + (True, True) -> FloatEnabled + (True, False)-> FloatNestedOnly + (False, _) -> FloatDisabled diff --git a/GHC/Driver/Config/Core/Opt/WorkWrap.hs b/GHC/Driver/Config/Core/Opt/WorkWrap.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Opt/WorkWrap.hs @@ -0,0 +1,21 @@ +module GHC.Driver.Config.Core.Opt.WorkWrap + ( initWorkWrapOpts + ) where + +import GHC.Prelude () + +import GHC.Driver.Config (initSimpleOpts) +import GHC.Driver.Session + +import GHC.Core.FamInstEnv +import GHC.Core.Opt.WorkWrap +import GHC.Unit.Types + +initWorkWrapOpts :: Module -> DynFlags -> FamInstEnvs -> WwOpts +initWorkWrapOpts this_mod dflags fam_envs = MkWwOpts + { wo_fam_envs = fam_envs + , wo_simple_opts = initSimpleOpts dflags + , wo_cpr_anal = gopt Opt_CprAnal dflags + , wo_module = this_mod + , wo_unlift_strict = gopt Opt_WorkerWrapperUnlift dflags + } diff --git a/GHC/Driver/Config/Core/Rules.hs b/GHC/Driver/Config/Core/Rules.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Core/Rules.hs @@ -0,0 +1,23 @@ +module GHC.Driver.Config.Core.Rules + ( initRuleOpts + ) where + +import GHC.Prelude + +import GHC.Driver.Flags +import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ ) + +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 + } diff --git a/GHC/Driver/Config/CoreToStg.hs b/GHC/Driver/Config/CoreToStg.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/CoreToStg.hs @@ -0,0 +1,16 @@ +module GHC.Driver.Config.CoreToStg where + +import GHC.Driver.Config.Stg.Debug +import GHC.Driver.Session + +import GHC.CoreToStg + +initCoreToStgOpts :: DynFlags -> CoreToStgOpts +initCoreToStgOpts dflags = CoreToStgOpts + { coreToStg_platform = targetPlatform dflags + , coreToStg_ways = ways dflags + , coreToStg_AutoSccsOnIndividualCafs = gopt Opt_AutoSccsOnIndividualCafs dflags + , coreToStg_InfoTableMap = gopt Opt_InfoTableMap dflags + , coreToStg_ExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags + , coreToStg_stgDebugOpts = initStgDebugOpts dflags + } diff --git a/GHC/Driver/Config/CoreToStg/Prep.hs b/GHC/Driver/Config/CoreToStg/Prep.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/CoreToStg/Prep.hs @@ -0,0 +1,34 @@ +module GHC.Driver.Config.CoreToStg.Prep + ( initCorePrepConfig + , initCorePrepPgmConfig + ) where + +import GHC.Prelude + +import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Config.Core.Lint +import GHC.Tc.Utils.Env +import GHC.Types.Var +import GHC.Utils.Outputable ( alwaysQualify ) + +import GHC.CoreToStg.Prep + +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 + return $ CorePrepConfig + { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases $ hsc_dflags hsc_env + , cp_convertNumLit = convertNumLit + } + +initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig +initCorePrepPgmConfig dflags extra_vars = CorePrepPgmConfig + { cpPgm_endPassConfig = initEndPassConfig dflags extra_vars alwaysQualify CorePrep + , cpPgm_generateDebugInfo = needSourceNotes dflags + } 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 @@ -1,5 +1,13 @@ + +-- | Functions for initialising error message printing configuration from the +-- GHC session flags. module GHC.Driver.Config.Diagnostic ( initDiagOpts + , initPrintConfig + , initPsMessageOpts + , initDsMessageOpts + , initTcMessageOpts + , initDriverMessageOpts ) where @@ -8,7 +16,16 @@ 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.Tc.Errors.Types +import GHC.HsToCore.Errors.Types +import GHC.Types.Error +import GHC.Tc.Errors.Ppr +-- | Initialise the general configuration for printing diagnostic messages +-- For example, this configuration controls things like whether warnings are +-- treated like errors. initDiagOpts :: DynFlags -> DiagOpts initDiagOpts dflags = DiagOpts { diag_warning_flags = warningFlags dflags @@ -18,4 +35,24 @@ , diag_max_errors = maxErrors dflags , diag_ppr_ctx = initSDocContext dflags defaultErrStyle } + +-- | Initialise the configuration for printing specific diagnostic messages +initPrintConfig :: DynFlags -> DiagnosticOpts GhcMessage +initPrintConfig dflags = + GhcMessageOpts { psMessageOpts = initPsMessageOpts dflags + , tcMessageOpts = initTcMessageOpts dflags + , dsMessageOpts = initDsMessageOpts dflags + , driverMessageOpts= initDriverMessageOpts dflags } + +initPsMessageOpts :: DynFlags -> DiagnosticOpts PsMessage +initPsMessageOpts _ = NoDiagnosticOpts + +initTcMessageOpts :: DynFlags -> DiagnosticOpts TcRnMessage +initTcMessageOpts dflags = TcRnMessageOpts { tcOptsShowContext = gopt Opt_ShowErrorContext dflags } + +initDsMessageOpts :: DynFlags -> DiagnosticOpts DsMessage +initDsMessageOpts _ = NoDiagnosticOpts + +initDriverMessageOpts :: DynFlags -> DiagnosticOpts DriverMessage +initDriverMessageOpts dflags = DriverMessageOpts (initPsMessageOpts dflags) diff --git a/GHC/Driver/Config/HsToCore/Ticks.hs b/GHC/Driver/Config/HsToCore/Ticks.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/HsToCore/Ticks.hs @@ -0,0 +1,28 @@ +module GHC.Driver.Config.HsToCore.Ticks + ( initTicksConfig + ) +where + +import GHC.Prelude + +import Data.Maybe (catMaybes) + +import GHC.Driver.Backend +import GHC.Driver.Session +import GHC.HsToCore.Ticks + +initTicksConfig :: DynFlags -> TicksConfig +initTicksConfig dflags = TicksConfig + { ticks_passes = coveragePasses dflags + , ticks_profAuto = profAuto dflags + , ticks_countEntries = gopt Opt_ProfCountEntries dflags + } + +coveragePasses :: DynFlags -> [TickishType] +coveragePasses dflags = catMaybes + [ ifA Breakpoints $ backendWantsBreakpointTicks $ backend dflags + , ifA HpcTicks $ gopt Opt_Hpc dflags + , ifA ProfNotes $ sccProfilingEnabled dflags && profAuto dflags /= NoProfAuto + , ifA SourceNotes $ needSourceNotes dflags + ] + where ifA x cond = if cond then Just x else Nothing diff --git a/GHC/Driver/Config/HsToCore/Usage.hs b/GHC/Driver/Config/HsToCore/Usage.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/HsToCore/Usage.hs @@ -0,0 +1,14 @@ +module GHC.Driver.Config.HsToCore.Usage + ( initUsageConfig + ) +where + +import GHC.Driver.Env.Types +import GHC.Driver.Session + +import GHC.HsToCore.Usage + +initUsageConfig :: HscEnv -> UsageConfig +initUsageConfig hsc_env = UsageConfig + { uc_safe_implicit_imps_req = safeImplicitImpsReq (hsc_dflags hsc_env) + } diff --git a/GHC/Driver/Config/Linker.hs b/GHC/Driver/Config/Linker.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/Linker.hs @@ -0,0 +1,13 @@ +module GHC.Driver.Config.Linker + ( initFrameworkOpts + ) where + +import GHC.Linker.Config + +import GHC.Driver.Session + +initFrameworkOpts :: DynFlags -> FrameworkOpts +initFrameworkOpts dflags = FrameworkOpts + { foFrameworkPaths = frameworkPaths dflags + , foCmdlineFrameworks = cmdlineFrameworks dflags + } 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 @@ -23,7 +23,9 @@ , log_dump_dir = dumpDir dflags , log_dump_prefix = dumpPrefix dflags , log_dump_prefix_override = dumpPrefixForce dflags + , log_with_ways = gopt Opt_DumpWithWays dflags , log_enable_debug = not (hasNoDebugOutput dflags) , log_verbosity = verbosity dflags + , log_ways = Just $ ways dflags } 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 @@ -2,18 +2,18 @@ ( initStgToCmmConfig ) where +import GHC.Prelude.Basic + import GHC.StgToCmm.Config import GHC.Driver.Backend import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile +import GHC.Utils.Error import GHC.Unit.Module import GHC.Utils.Outputable -import Data.Maybe -import Prelude - initStgToCmmConfig :: DynFlags -> Module -> StgToCmmConfig initStgToCmmConfig dflags mod = StgToCmmConfig -- settings @@ -21,7 +21,7 @@ , stgToCmmThisModule = mod , stgToCmmTmpDir = tmpDir dflags , stgToCmmContext = initSDocContext dflags defaultDumpStyle - , stgToCmmDebugLevel = debugLevel dflags + , stgToCmmEmitDebugInfo = debugLevel dflags > 0 , stgToCmmBinBlobThresh = b_blob , stgToCmmMaxInlAllocSize = maxInlineAllocSize dflags -- ticky options @@ -46,12 +46,11 @@ , stgToCmmDoBoundsCheck = gopt Opt_DoBoundsChecking dflags , stgToCmmDoTagCheck = gopt Opt_DoTagInferenceChecks dflags -- backend flags - , stgToCmmAllowBigArith = not ncg + , stgToCmmAllowBigArith = not ncg || platformArch platform == ArchWasm32 , stgToCmmAllowQuotRemInstr = ncg && (x86ish || ppc) , stgToCmmAllowQuotRem2 = (ncg && (x86ish || ppc)) || llvm , stgToCmmAllowExtendedAddSubInstrs = (ncg && (x86ish || ppc)) || llvm , stgToCmmAllowIntMul2Instr = (ncg && x86ish) || llvm - , stgToCmmAllowFabsInstrs = (ncg && (x86ish || ppc || aarch64)) || llvm -- SIMD flags , stgToCmmVecInstrsErr = vec_err , stgToCmmAvx = isAvxEnabled dflags @@ -61,9 +60,12 @@ } where profile = targetProfile dflags platform = profilePlatform profile bk_end = backend dflags - ncg = bk_end == NCG - llvm = bk_end == LLVM 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) x86ish = case platformArch platform of ArchX86 -> True ArchX86_64 -> True @@ -72,7 +74,6 @@ ArchPPC -> True ArchPPC_64 _ -> True _ -> False - aarch64 = platformArch platform == ArchAArch64 - vec_err = case backend dflags of - LLVM -> Nothing - _ -> Just (unlines ["SIMD vector instructions require the LLVM back-end.", "Please use -fllvm."]) + vec_err = case backendSimdValidity (backend dflags) of + IsValid -> Nothing + NotValid msg -> Just msg diff --git a/GHC/Driver/Config/StgToJS.hs b/GHC/Driver/Config/StgToJS.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Config/StgToJS.hs @@ -0,0 +1,32 @@ +module GHC.Driver.Config.StgToJS + ( initStgToJSConfig + ) +where + +import GHC.StgToJS.Types + +import GHC.Driver.Session +import GHC.Platform.Ways +import GHC.Utils.Outputable + +import GHC.Prelude + +-- | Initialize StgToJS settings from DynFlags +initStgToJSConfig :: DynFlags -> StgToJSConfig +initStgToJSConfig dflags = StgToJSConfig + -- flags + { csInlinePush = False + , csInlineBlackhole = False + , csInlineLoadRegs = False + , csInlineEnter = False + , csInlineAlloc = False + , csTraceRts = False + , csAssertRts = False + , csBoundsCheck = gopt Opt_DoBoundsChecking dflags + , csDebugAlloc = False + , csTraceForeign = False + , csProf = ways dflags `hasWay` WayProf + , csRuntimeAssert = False + -- settings + , csContext = initSDocContext dflags defaultDumpStyle + } 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 @@ -62,12 +62,8 @@ -- If we are compiling for the interpreter we will insert any necessary -- SPT entries dynamically, otherwise we add a C stub to do so - , opt_gen_cstub = case backend dflags of - Interpreter -> False - _ -> True - + , opt_gen_cstub = backendWritesFiles (backend dflags) , opt_mk_string = mk_string , opt_static_ptr_info_datacon = static_ptr_info_datacon , opt_static_ptr_datacon = static_ptr_datacon } - diff --git a/GHC/Driver/Env.hs b/GHC/Driver/Env.hs --- a/GHC/Driver/Env.hs +++ b/GHC/Driver/Env.hs @@ -14,6 +14,7 @@ , hsc_all_home_unit_ids , hscUpdateLoggerFlags , hscUpdateHUG + , hscUpdateHPT_lazy , hscUpdateHPT , hscSetActiveHomeUnit , hscSetActiveUnitId @@ -45,7 +46,7 @@ import GHC.Driver.Errors ( printOrThrowDiagnostics ) import GHC.Driver.Errors.Types ( GhcMessage ) import GHC.Driver.Config.Logger (initLogFlags) -import GHC.Driver.Config.Diagnostic (initDiagOpts) +import GHC.Driver.Config.Diagnostic (initDiagOpts, initPrintConfig) import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) ) import GHC.Runtime.Context @@ -80,7 +81,6 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Logger -import GHC.Utils.Trace import Data.IORef import qualified Data.Set as Set @@ -94,7 +94,8 @@ (a, w) <- hsc hsc_env emptyMessages let dflags = hsc_dflags hsc_env let !diag_opts = initDiagOpts dflags - printOrThrowDiagnostics (hsc_logger hsc_env) diag_opts w + !print_config = initPrintConfig dflags + printOrThrowDiagnostics (hsc_logger hsc_env) print_config diag_opts w return a runHsc' :: HscEnv -> Hsc a -> IO (a, Messages GhcMessage) @@ -133,8 +134,15 @@ hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId hsc_all_home_unit_ids = unitEnv_keys . hsc_HUG +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 } + hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv -hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHpt f (hsc_unit_env hsc_env) } +hscUpdateHPT f hsc_env = + let !res = updateHpt f (hsc_unit_env hsc_env) + in hsc_env { hsc_unit_env = res } hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) } diff --git a/GHC/Driver/Env/KnotVars.hs b/GHC/Driver/Env/KnotVars.hs --- a/GHC/Driver/Env/KnotVars.hs +++ b/GHC/Driver/Env/KnotVars.hs @@ -57,7 +57,7 @@ the data structure in 'mkDsEnvs' which required this generalised structure. In interactive mode the TypeEnvs from all the previous statements are merged -togethed into one big TypeEnv. 'dsLookupVar' relies on `tcIfaceVar'. The normal +together into one big TypeEnv. 'dsLookupVar' relies on `tcIfaceVar'. The normal lookup functions either look in the HPT or EPS but there is no entry for the `Ghci` modules in either, so the whole merged TypeEnv for all previous Ghci* is stored in the `if_rec_types` variable and then lookup checks there in the case of any interactive module. @@ -71,7 +71,7 @@ Normally there's a 'Module' at hand to tell us which 'TypeEnv' we want to interrogate at a particular time, apart from one case, when constructing the in-scope set -when linting an unfolding. In this case the whole environemnt is needed to tell us +when linting an unfolding. In this case the whole environment is needed to tell us everything that's in-scope at top-level in the loop because whilst we are linting unfoldings the top-level identifiers from modules in the cycle might not be globalised properly yet. @@ -89,7 +89,7 @@ This invariant is difficult to test but easy to check using ghc-debug. The usage of NoKnotVars is intended to make this invariant easier to check. -The most common situation where a KnotVars is retained accidently is if a HscEnv +The most common situation where a KnotVars is retained accidentally is if a HscEnv which contains reference to a KnotVars is used during interface file loading. The thunks created during this process will retain a reference to the KnotVars. In theory, all these references should be removed by 'maybeRehydrateAfter' as that rehydrates all 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 @@ -8,6 +8,8 @@ import GHC.Driver.Errors.Types ( GhcMessage ) import {-# SOURCE #-} GHC.Driver.Hooks import GHC.Driver.Session ( ContainsDynFlags(..), HasDynFlags(..), DynFlags ) +import GHC.Driver.LlvmConfigCache (LlvmConfigCache) + import GHC.Prelude import GHC.Runtime.Context import GHC.Runtime.Interpreter.Types ( Interp ) @@ -106,4 +108,7 @@ , hsc_tmpfs :: !TmpFs -- ^ Temporary files + + , 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module GHC.Driver.Errors ( printOrThrowDiagnostics , printMessages @@ -16,47 +17,48 @@ import GHC.Utils.Logger import qualified GHC.Driver.CmdLine as CmdLine -printMessages :: Diagnostic a => Logger -> DiagOpts -> Messages a -> IO () -printMessages logger opts msgs - = sequence_ [ let style = mkErrStyle unqual +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) s $ + in logMsg logger (MCDiagnostic sev (diagnosticReason dia) (diagnosticCode dia)) s $ withPprStyle style (messageWithHints ctx dia) - | MsgEnvelope { errMsgSpan = s, + | MsgEnvelope { errMsgSpan = s, errMsgDiagnostic = dia, - errMsgSeverity = sev, - errMsgContext = unqual } <- sortMsgBag (Just opts) - (getMessages msgs) ] + errMsgSeverity = sev, + 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 e + let main_msg = formatBulleted ctx $ 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 -> DiagOpts -> [CmdLine.Warn] -> IO () -handleFlagWarnings logger opts warns = do +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 opts (mkMessages bag) + printOrThrowDiagnostics logger print_config opts (mkMessages bag) -- | Given a bag of diagnostics, turn them into an exception if -- any has 'SevError', or print them out otherwise. -printOrThrowDiagnostics :: Logger -> DiagOpts -> Messages GhcMessage -> IO () -printOrThrowDiagnostics logger opts msgs +printOrThrowDiagnostics :: Logger -> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO () +printOrThrowDiagnostics logger print_config opts msgs | errorsOrFatalWarningsFound msgs = throwErrors msgs | otherwise - = printMessages logger opts msgs + = printMessages logger print_config opts msgs -- | Convert a 'PsError' into a wrapped 'DriverMessage'; use it -- for dealing with parse errors when the driver is doing dependency analysis. 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 @@ -1,8 +1,13 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage} -module GHC.Driver.Errors.Ppr where +module GHC.Driver.Errors.Ppr ( + -- This module only exports Diagnostic instances. + ) where import GHC.Prelude @@ -13,6 +18,7 @@ import GHC.Parser.Errors.Ppr () import GHC.Tc.Errors.Ppr () import GHC.Types.Error +import GHC.Types.Error.Codes ( constructorCode ) import GHC.Unit.Types import GHC.Utils.Outputable import GHC.Unit.Module @@ -22,6 +28,8 @@ import Data.Version import Language.Haskell.Syntax.Decls (RuleDecl(..)) +import GHC.Tc.Errors.Types (TcRnMessage) +import GHC.HsToCore.Errors.Types (DsMessage) -- -- Suggestions @@ -32,19 +40,23 @@ suggestInstantiatedWith pi_mod_name insts = [ InstantiationSuggestion k v | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : insts) ] - instance Diagnostic GhcMessage where - diagnosticMessage = \case + type DiagnosticOpts GhcMessage = GhcMessageOpts + defaultDiagnosticOpts = GhcMessageOpts (defaultDiagnosticOpts @PsMessage) + (defaultDiagnosticOpts @TcRnMessage) + (defaultDiagnosticOpts @DsMessage) + (defaultDiagnosticOpts @DriverMessage) + diagnosticMessage opts = \case GhcPsMessage m - -> diagnosticMessage m + -> diagnosticMessage (psMessageOpts opts) m GhcTcRnMessage m - -> diagnosticMessage m + -> diagnosticMessage (tcMessageOpts opts) m GhcDsMessage m - -> diagnosticMessage m + -> diagnosticMessage (dsMessageOpts opts) m GhcDriverMessage m - -> diagnosticMessage m - GhcUnknownMessage m - -> diagnosticMessage m + -> diagnosticMessage (driverMessageOpts opts) m + GhcUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m diagnosticReason = \case GhcPsMessage m @@ -70,12 +82,16 @@ GhcUnknownMessage m -> diagnosticHints m + diagnosticCode = constructorCode + instance Diagnostic DriverMessage where - diagnosticMessage = \case - DriverUnknownMessage m - -> diagnosticMessage m + type DiagnosticOpts DriverMessage = DriverMessageOpts + defaultDiagnosticOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) + diagnosticMessage opts = \case + DriverUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m DriverPsHeaderMessage m - -> diagnosticMessage m + -> diagnosticMessage (psDiagnosticOpts opts) m DriverMissingHomeModules uid missing buildingCabalPackage -> let msg | buildingCabalPackage == YesBuildingCabalPackage = hang @@ -148,8 +164,8 @@ -> mkSimpleDecorated (text "module" <+> ppr modname <+> text "was not found") DriverUserDefinedRuleIgnored (HsRule { rd_name = n }) -> mkSimpleDecorated $ - text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ - text "User defined rules are disabled under Safe Haskell" + text "Rule \"" <> ftext (unLoc n) <> text "\" ignored" $+$ + text "Defining user rules is disabled under Safe Haskell" DriverMixedSafetyImport modName -> mkSimpleDecorated $ text "Module" <+> ppr modName <+> text ("is imported both as a safe and unsafe import!") @@ -312,3 +328,5 @@ -> noHints DriverHomePackagesNotClosed {} -> noHints + + diagnosticCode = constructorCode 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 @@ -1,8 +1,13 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} module GHC.Driver.Errors.Types ( GhcMessage(..) - , DriverMessage(..), DriverMessages, PsMessage(PsHeaderMessage) + , GhcMessageOpts(..) + , DriverMessage(..) + , DriverMessageOpts(..) + , DriverMessages, PsMessage(PsHeaderMessage) , BuildingCabalPackage(..) , WarningMessages , ErrorMessages @@ -32,6 +37,8 @@ import Language.Haskell.Syntax.Decls (RuleDecl) +import GHC.Generics ( Generic ) + -- | A collection of warning messages. -- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevWarning' severity. type WarningMessages = Messages GhcMessage @@ -83,16 +90,25 @@ -- 'Diagnostic' constraint ensures that worst case scenario we can still -- render this into something which can be eventually converted into a -- 'DecoratedSDoc'. - GhcUnknownMessage :: forall a. (Diagnostic a, Typeable a) => a -> GhcMessage + GhcUnknownMessage :: UnknownDiagnostic -> GhcMessage + deriving Generic + + +data GhcMessageOpts = GhcMessageOpts { psMessageOpts :: DiagnosticOpts PsMessage + , tcMessageOpts :: DiagnosticOpts TcRnMessage + , dsMessageOpts :: DiagnosticOpts DsMessage + , driverMessageOpts :: DiagnosticOpts DriverMessage + } + -- | Creates a new 'GhcMessage' out of any diagnostic. This function is also -- provided to ease the integration of #18516 by allowing diagnostics to be -- wrapped into the general (but structured) 'GhcMessage' type, so that the -- 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 :: (Diagnostic a, Typeable a) => a -> GhcMessage -ghcUnknownMessage = GhcUnknownMessage +ghcUnknownMessage :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) => a -> GhcMessage +ghcUnknownMessage = GhcUnknownMessage . UnknownDiagnostic -- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on -- the result of 'IO (Messages TcRnMessage, a)'. @@ -110,7 +126,8 @@ -- | A message from the driver. data DriverMessage where -- | Simply wraps a generic 'Diagnostic' message @a@. - DriverUnknownMessage :: (Diagnostic a, Typeable a) => a -> DriverMessage + DriverUnknownMessage :: UnknownDiagnostic -> DriverMessage + -- | A parse error in parsing a Haskell file header during dependency -- analysis DriverPsHeaderMessage :: !PsMessage -> DriverMessage @@ -350,6 +367,11 @@ DriverRedirectedNoMain :: !ModuleName -> DriverMessage DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage + +deriving instance Generic DriverMessage + +data DriverMessageOpts = + DriverMessageOpts { psDiagnosticOpts :: DiagnosticOpts PsMessage } -- | Pass to a 'DriverMessage' the information whether or not the -- '-fbuilding-cabal-package' flag is set. diff --git a/GHC/Driver/Flags.hs b/GHC/Driver/Flags.hs --- a/GHC/Driver/Flags.hs +++ b/GHC/Driver/Flags.hs @@ -1,5 +1,7 @@ module GHC.Driver.Flags ( DumpFlag(..) + , getDumpFlagFrom + , enabledIfVerbose , GeneralFlag(..) , Language(..) , optimisationFlags @@ -24,6 +26,7 @@ import GHC.Utils.Binary import GHC.Data.EnumSet as EnumSet +import Control.DeepSeq import Control.Monad (guard) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromMaybe,mapMaybe) @@ -38,6 +41,9 @@ put_ bh = put_ bh . fromEnum get bh = toEnum <$> get bh +instance NFData Language where + rnf x = x `seq` () + -- | Debugging flags data DumpFlag -- See Note [Updating flag description in the User's Guide] @@ -64,6 +70,7 @@ | Opt_D_dump_cmm_split | Opt_D_dump_cmm_info | Opt_D_dump_cmm_cps + | Opt_D_dump_cmm_thread_sanitizer -- end cmm subflags | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout. | Opt_D_dump_asm @@ -75,6 +82,7 @@ | Opt_D_dump_asm_stats | Opt_D_dump_c_backend | Opt_D_dump_llvm + | Opt_D_dump_js | Opt_D_dump_core_stats | Opt_D_dump_deriv | Opt_D_dump_ds @@ -143,11 +151,52 @@ | Opt_D_faststring_stats deriving (Eq, Show, Enum) +-- | Helper function to query whether a given `DumpFlag` is enabled or not. +getDumpFlagFrom + :: (a -> Int) -- ^ Getter for verbosity setting + -> (a -> EnumSet DumpFlag) -- ^ Getter for the set of enabled dump flags + -> DumpFlag -> a -> Bool +getDumpFlagFrom getVerbosity getFlags f x + = (f `EnumSet.member` getFlags x) + || (getVerbosity x >= 4 && enabledIfVerbose f) + +-- | Is the flag implicitly enabled when the verbosity is high enough? +enabledIfVerbose :: DumpFlag -> Bool +enabledIfVerbose Opt_D_dump_tc_trace = False +enabledIfVerbose Opt_D_dump_rn_trace = False +enabledIfVerbose Opt_D_dump_cs_trace = False +enabledIfVerbose Opt_D_dump_if_trace = False +enabledIfVerbose Opt_D_dump_tc = False +enabledIfVerbose Opt_D_dump_rn = False +enabledIfVerbose Opt_D_dump_rn_stats = False +enabledIfVerbose Opt_D_dump_hi_diffs = False +enabledIfVerbose Opt_D_verbose_core2core = False +enabledIfVerbose Opt_D_verbose_stg2stg = False +enabledIfVerbose Opt_D_dump_splices = False +enabledIfVerbose Opt_D_th_dec_file = False +enabledIfVerbose Opt_D_dump_rule_firings = False +enabledIfVerbose Opt_D_dump_rule_rewrites = False +enabledIfVerbose Opt_D_dump_simpl_trace = False +enabledIfVerbose Opt_D_dump_rtti = False +enabledIfVerbose Opt_D_dump_inlinings = False +enabledIfVerbose Opt_D_dump_verbose_inlinings = False +enabledIfVerbose Opt_D_dump_core_stats = False +enabledIfVerbose Opt_D_dump_asm_stats = False +enabledIfVerbose Opt_D_dump_types = False +enabledIfVerbose Opt_D_dump_simpl_iterations = False +enabledIfVerbose Opt_D_dump_ticked = False +enabledIfVerbose Opt_D_dump_view_pattern_commoning = False +enabledIfVerbose Opt_D_dump_mod_cycles = False +enabledIfVerbose Opt_D_dump_mod_map = False +enabledIfVerbose Opt_D_dump_ec_trace = False +enabledIfVerbose _ = True + -- | Enumerates the simple on-or-off dynamic flags data GeneralFlag -- See Note [Updating flag description in the User's Guide] = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. + | Opt_DumpWithWays -- ^ Use foo.ways. instead of foo. | Opt_D_dump_minimal_imports | Opt_DoCoreLinting | Opt_DoLinearCoreLinting @@ -176,6 +225,7 @@ | Opt_PrintUnicodeSyntax | Opt_PrintExpandedSynonyms | Opt_PrintPotentialInstances + | Opt_PrintRedundantPromotionTicks | Opt_PrintTypecheckerElaboration -- optimisation opts @@ -187,6 +237,11 @@ | Opt_KillOneShot | Opt_FullLaziness | Opt_FloatIn + | Opt_LocalFloatOut -- ^ Enable floating out of let-bindings in the + -- simplifier + | Opt_LocalFloatOutTopLevel -- ^ Enable floating out of let-bindings at the + -- top level in the simplifier + -- N.B. See Note [RHS Floating] | Opt_LateSpecialise | Opt_Specialise | Opt_SpecialiseAggressively @@ -304,6 +359,7 @@ | Opt_Ticky_Dyn_Thunk | Opt_Ticky_Tag | Opt_Ticky_AP -- ^ Use regular thunks even when we could use std ap thunks in order to get entry counts + | Opt_CmmThreadSanitizer | Opt_RPath | Opt_RelativeDynlibPaths | Opt_CompactUnwind -- ^ @-fcompact-unwind@ @@ -314,7 +370,7 @@ | Opt_VersionMacros | Opt_WholeArchiveHsLibs -- copy all libs into a single folder prior to linking binaries - -- this should elivate the excessive command line limit restrictions + -- this should alleviate the excessive command line limit restrictions -- on windows, by only requiring a single -L argument instead of -- one for each dependency. At the time of this writing, gcc -- forwards all -L flags to the collect2 command without using a @@ -324,6 +380,7 @@ | Opt_KeepCAFs | Opt_KeepGoing | Opt_ByteCode + | Opt_ByteCodeAndObjectCode | Opt_LinkRts -- output style opts @@ -379,6 +436,9 @@ | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps | Opt_SuppressCoreSizes -- ^ Suppress per binding Core size stats in dumps + -- Error message suppression + | Opt_ShowErrorContext + -- temporary flags | Opt_AutoLinkPackages | Opt_ImplicitImportQualified @@ -395,6 +455,8 @@ | Opt_KeepOFiles | Opt_BuildDynamicToo + | Opt_WriteIfSimplifiedCore + | Opt_UseBytecodeRatherThanObjects -- safe haskell flags | Opt_DistrustAllPackages @@ -566,6 +628,7 @@ | Opt_WarnGADTMonoLocalBinds -- Since 9.4 | Opt_WarnTypeEqualityOutOfScope -- Since 9.4 | Opt_WarnTypeEqualityRequiresOperators -- Since 9.4 + | Opt_WarnLoopySuperclassSolve -- Since 9.6 deriving (Eq, Ord, Show, Enum) -- | Return the names of a WarningFlag @@ -670,6 +733,7 @@ Opt_WarnUnicodeBidirectionalFormatCharacters -> "unicode-bidirectional-format-characters" :| [] Opt_WarnGADTMonoLocalBinds -> "gadt-mono-local-binds" :| [] Opt_WarnTypeEqualityOutOfScope -> "type-equality-out-of-scope" :| [] + Opt_WarnLoopySuperclassSolve -> "loopy-superclass-solve" :| [] Opt_WarnTypeEqualityRequiresOperators -> "type-equality-requires-operators" :| [] -- ----------------------------------------------------------------------------- @@ -758,6 +822,7 @@ Opt_WarnUnrecognisedWarningFlags, Opt_WarnSimplifiableClassConstraints, Opt_WarnStarBinder, + Opt_WarnStarIsType, Opt_WarnInaccessibleCode, Opt_WarnSpaceAfterBang, Opt_WarnNonCanonicalMonadInstances, @@ -766,6 +831,7 @@ Opt_WarnForallIdentifier, Opt_WarnUnicodeBidirectionalFormatCharacters, Opt_WarnGADTMonoLocalBinds, + Opt_WarnLoopySuperclassSolve, Opt_WarnTypeEqualityRequiresOperators ] @@ -799,7 +865,6 @@ Opt_WarnMissingPatternSynonymSignatures, Opt_WarnUnusedRecordWildcards, Opt_WarnRedundantRecordWildcards, - Opt_WarnStarIsType, Opt_WarnIncompleteUniPatterns, Opt_WarnIncompletePatternsRecUpd ] @@ -817,7 +882,6 @@ minusWcompatOpts = [ Opt_WarnSemigroup , Opt_WarnNonCanonicalMonoidInstances - , Opt_WarnStarIsType , Opt_WarnCompatUnqualifiedImports , Opt_WarnTypeEqualityOutOfScope ] diff --git a/GHC/Driver/GenerateCgIPEStub.hs b/GHC/Driver/GenerateCgIPEStub.hs --- a/GHC/Driver/GenerateCgIPEStub.hs +++ b/GHC/Driver/GenerateCgIPEStub.hs @@ -3,7 +3,7 @@ module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) where import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, listToMaybe) +import Data.Maybe (mapMaybe, listToMaybe) import GHC.Cmm import GHC.Cmm.CLabel (CLabel) import GHC.Cmm.Dataflow (Block, C, O) @@ -12,18 +12,18 @@ import GHC.Cmm.Dataflow.Label (Label) import GHC.Cmm.Info.Build (emptySRT) import GHC.Cmm.Pipeline (cmmPipeline) -import GHC.Cmm.Utils (toBlockList) import GHC.Data.Maybe (firstJusts) import GHC.Data.Stream (Stream, liftIO) import qualified GHC.Data.Stream as Stream -import GHC.Driver.Env (hsc_dflags) +import GHC.Driver.Env (hsc_dflags, hsc_logger) import GHC.Driver.Env.Types (HscEnv) import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap)) import GHC.Driver.Session (gopt, targetPlatform) import GHC.Driver.Config.StgToCmm +import GHC.Driver.Config.Cmm import GHC.Prelude import GHC.Runtime.Heap.Layout (isStackRep) -import GHC.Settings (Platform, platformUnregisterised) +import GHC.Settings (Platform, platformTablesNextToCode) import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState) import GHC.StgToCmm.Prof (initInfoTableProv) import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos) @@ -41,7 +41,7 @@ But to make them readable / meaningful, one needs to know the source location of each return frame. Every return frame has a distinct info table and thus a distinct code pointer (for tables next to -code) or at least a distict address itself. Info Table Provernance Entries (IPE) are searchable by +code) or at least a distinct address itself. Info Table Provenance Entries (IPEs) are searchable by this pointer and contain a source location. The info table / info table code pointer to source location map is described in: @@ -52,13 +52,13 @@ This leads to the question: How to figure out the source location of a return frame? -While the lookup algorithms for registerised and unregisterised builds differ in details, they have in +While the lookup algorithms when tables-next-to-code is on/off differ in details, they have in common that we want to lookup the `CmmNode.CmmTick` (containing a `SourceNote`) that is nearest (before) the usage of the return frame's label. (Which label and label type is used differs between these two use cases.) -Registerised -~~~~~~~~~~~~~ +With tables-next-to-code +~~~~~~~~~~~~~~~~~~~~~~~~ Let's consider this example: ``` @@ -117,10 +117,10 @@ `IpeSourceLocation`. (There are other `Tickish` constructors like `ProfNote` or `HpcTick`, these are ignored.) -Unregisterised -~~~~~~~~~~~~~ +Without tables-next-to-code +~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In unregisterised builds there is no return frame / continuation label in calls. The continuation (i.e. return +When tables-next-to-code is off, there is no return frame / continuation label in calls. The continuation (i.e. return frame) is set in an explicit Cmm assignment. Thus the tick lookup algorithm has to be slightly different. ``` @@ -182,7 +182,9 @@ generateCgIPEStub hsc_env this_mod denv s = do let dflags = hsc_dflags hsc_env platform = targetPlatform dflags + logger = hsc_logger hsc_env fstate = initFCodeState platform + cmm_cfg = initCmmConfig dflags cgState <- liftIO initC -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty. @@ -193,7 +195,7 @@ let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)} ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOf3 labeledInfoTablesWithTickishes) denv') - (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline hsc_env (emptySRT this_mod) ipeCmmGroup + (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) ipeCmmGroup Stream.yield ipeCmmGroupSRTs return CmmCgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub} @@ -208,7 +210,7 @@ collectNothing _ cmmGroupSRTs = pure ([], cmmGroupSRTs) collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)] - collectInfoTables cmmGroup = concat $ catMaybes $ map extractInfoTables cmmGroup + collectInfoTables cmmGroup = concat $ mapMaybe extractInfoTables cmmGroup extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Maybe [(Label, CmmInfoTable)] extractInfoTables (CmmProc h _ _ _) = Just $ mapToList (info_tbls h) @@ -221,9 +223,9 @@ if (isStackRep . cit_rep) infoTable then do let findFun = - if platformUnregisterised platform - then findCmmTickishForForUnregistered (cit_lbl infoTable) - else findCmmTickishForRegistered infoTableLabel + if platformTablesNextToCode platform + then findCmmTickishWithTNTC infoTableLabel + else findCmmTickishSansTNTC (cit_lbl infoTable) blocks = concatMap toBlockList (graphs cmmGroup) firstJusts $ map findFun blocks else Nothing @@ -234,8 +236,8 @@ go acc (CmmProc _ _ _ g) = g : acc go acc _ = acc - findCmmTickishForRegistered :: Label -> Block CmmNode C C -> Maybe IpeSourceLocation - findCmmTickishForRegistered label block = do + findCmmTickishWithTNTC :: Label -> Block CmmNode C C -> Maybe IpeSourceLocation + findCmmTickishWithTNTC label block = do let (_, middleBlock, endBlock) = blockSplit block isCallWithReturnFrameLabel endBlock label @@ -247,15 +249,14 @@ lastTickInBlock block = listToMaybe $ - catMaybes $ - map maybeTick $ (reverse . blockToList) block + mapMaybe maybeTick $ (reverse . blockToList) block maybeTick :: CmmNode O O -> Maybe IpeSourceLocation maybeTick (CmmTick (SourceNote span name)) = Just (span, name) maybeTick _ = Nothing - findCmmTickishForForUnregistered :: CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation - findCmmTickishForForUnregistered cLabel block = do + findCmmTickishSansTNTC :: CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation + findCmmTickishSansTNTC cLabel block = do let (_, middleBlock, _) = blockSplit block find cLabel (blockToList middleBlock) Nothing where diff --git a/GHC/Driver/Hooks.hs b/GHC/Driver/Hooks.hs --- a/GHC/Driver/Hooks.hs +++ b/GHC/Driver/Hooks.hs @@ -141,7 +141,7 @@ , runMetaHook :: !(Maybe (MetaHook TcM)) , linkHook :: !(Maybe (GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag)) - , runRnSpliceHook :: !(Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn))) + , runRnSpliceHook :: !(Maybe (HsUntypedSplice GhcRn -> RnM (HsUntypedSplice GhcRn))) , getValueSafelyHook :: !(Maybe (HscEnv -> Name -> Type -> IO (Either Type (HValue, [Linkable], PkgsLoaded)))) , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle)) diff --git a/GHC/Driver/LlvmConfigCache.hs b/GHC/Driver/LlvmConfigCache.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/LlvmConfigCache.hs @@ -0,0 +1,26 @@ +-- | LLVM config cache +module GHC.Driver.LlvmConfigCache + ( LlvmConfigCache + , initLlvmConfigCache + , readLlvmConfigCache + ) +where + +import GHC.Prelude +import GHC.CmmToLlvm.Config + +import System.IO.Unsafe + +-- | Cache LLVM configuration read from files in top_dir +-- +-- See Note [LLVM configuration] in GHC.CmmToLlvm.Config +-- +-- Currently implemented with unsafe lazy IO. But it could be implemented with +-- an IORef as the exposed interface is in IO. +data LlvmConfigCache = LlvmConfigCache LlvmConfig + +initLlvmConfigCache :: FilePath -> IO LlvmConfigCache +initLlvmConfigCache top_dir = pure $ LlvmConfigCache (unsafePerformIO $ initLlvmConfig top_dir) + +readLlvmConfigCache :: LlvmConfigCache -> IO LlvmConfig +readLlvmConfigCache (LlvmConfigCache !config) = pure config diff --git a/GHC/Driver/Main.hs b/GHC/Driver/Main.hs --- a/GHC/Driver/Main.hs +++ b/GHC/Driver/Main.hs @@ -1,7 +1,11 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -fprof-auto-top #-} @@ -39,16 +43,22 @@ -- * 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 @@ -99,21 +109,35 @@ 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.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) import GHC.Runtime.Context import GHC.Runtime.Interpreter ( addSptEntry ) @@ -131,8 +155,9 @@ import GHC.HsToCore import GHC.StgToByteCode ( byteCodeGen ) +import GHC.StgToJS ( stgToJS ) -import GHC.IfaceToCore ( typecheckIface ) +import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings ) import GHC.Iface.Load ( ifaceStats, writeIface ) import GHC.Iface.Make @@ -144,14 +169,14 @@ 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.Lint ( lintInteractiveExpr, endPassIO ) import GHC.Core.Multiplicity import GHC.Core.Utils ( exprType ) import GHC.Core.ConLike -import GHC.Core.Opt.Monad ( CoreToDo (..)) import GHC.Core.Opt.Pipeline +import GHC.Core.Opt.Pipeline.Types ( CoreToDo (..)) import GHC.Core.TyCon import GHC.Core.InstEnv import GHC.Core.FamInstEnv @@ -182,10 +207,10 @@ import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos) import GHC.Cmm -import GHC.Cmm.Parser ( parseCmmFile ) import GHC.Cmm.Info.Build import GHC.Cmm.Pipeline import GHC.Cmm.Info +import GHC.Cmm.Parser import GHC.Unit import GHC.Unit.Env @@ -216,6 +241,7 @@ import GHC.Types.Name.Cache ( initNameCache ) import GHC.Types.Name.Reader import GHC.Types.Name.Ppr +import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.TyThing import GHC.Types.HpcInfo @@ -233,25 +259,33 @@ 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 System.IO (fixIO) import qualified Data.Set as S import Data.Set (Set) import Data.Functor import Control.DeepSeq (force) import Data.Bifunctor (first) -import GHC.Data.Maybe -import GHC.Driver.Env.KnotVars -import GHC.Types.Name.Set (NonCaffySet) -import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) 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.Types.Unique.FM @@ -262,36 +296,80 @@ %* * %********************************************************************* -} -newHscEnv :: DynFlags -> IO HscEnv -newHscEnv dflags = newHscEnvWithHUG dflags (homeUnitId_ dflags) home_unit_graph +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 :: DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv -newHscEnvWithHUG top_dynflags cur_unit home_unit_graph = do +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) - return HscEnv { hsc_dflags = top_dynflags + 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_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) @@ -309,9 +387,10 @@ handleWarnings :: Hsc () handleWarnings = do diag_opts <- initDiagOpts <$> getDynFlags + print_config <- initPrintConfig <$> getDynFlags logger <- getLogger w <- getDiagnostics - liftIO $ printOrThrowDiagnostics logger diag_opts w + liftIO $ printOrThrowDiagnostics logger print_config diag_opts w clearDiagnostics -- | log warning in the monad, and if there are errors then @@ -329,7 +408,7 @@ logDiagnostics (GhcPsMessage <$> warnings) logger <- getLogger let (wWarns, wErrs) = partitionMessages warnings - liftIO $ printMessages logger diag_opts wWarns + liftIO $ printMessages logger NoDiagnosticOpts diag_opts wWarns throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs -- | Deal with errors and warnings returned by a compilation step @@ -368,11 +447,15 @@ -- ----------------------------------------------------------------------------- -- | Lookup things in the compiler's environment -hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name] +hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (NonEmpty Name) hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do { hsc_env <- getHscEnv - ; ioMsgMaybe $ hoistTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name } + -- 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 @@ -616,7 +699,7 @@ Nothing -> hscParse' mod_summary tc_result0 <- tcRnModule' mod_summary keep_rn' hpm if hsc_src == HsigFile - then do (iface, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary + 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 @@ -746,7 +829,7 @@ -> HscEnv -> ModSummary -> Maybe ModIface - -> Maybe Linkable + -> HomeModLinkable -> (Int,Int) -> IO HscRecompStatus hscRecompStatus @@ -772,39 +855,70 @@ return $ HscRecompNeeded $ fmap (mi_iface_hash . mi_final_exts) mb_checked_iface UpToDateItem checked_iface -> do let lcl_dflags = ms_hspp_opts mod_summary - case backend lcl_dflags of - -- No need for a linkable, we're good to go - NoBackend -> do - msg $ UpToDate - return $ HscUpToDate checked_iface Nothing - -- Do need linkable - backend - | not (backendProducesObject backend) - , IsBoot <- isBootSummary mod_summary - -> do - msg $ UpToDate - return $ HscUpToDate checked_iface Nothing - _ -> do - -- Check to see whether the expected build products already exist. - -- If they don't exists then we trigger recompilation. - recomp_linkable_result <- case () of - -- Interpreter can use either already loaded bytecode or loaded object code - _ | Interpreter <- backend lcl_dflags -> do - let res = checkByteCode old_linkable - case res of - UpToDateItem _ -> pure res - _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary - -- Need object files for making object files - | backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary - | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags) - case recomp_linkable_result of - UpToDateItem linkable -> do - msg $ UpToDate - return $ HscUpToDate checked_iface $ Just linkable - OutOfDateItem reason _ -> do - msg $ NeedsRecompile reason - return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface + 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) @@ -840,14 +954,24 @@ -- | 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 :: Maybe Linkable -> MaybeValidated Linkable -checkByteCode mb_old_linkable = +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) - -> UpToDateItem old_linkable - _ -> outOfDateItemBecause MissingBytecode Nothing + -> 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 -------------------------------------------------------------- @@ -855,18 +979,41 @@ -- Knot tying! See Note [Knot-tying typecheckIface] -- See Note [ModDetails and --make mode] -initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails -initModDetails hsc_env mod_summary iface = +initModDetails :: HscEnv -> ModIface -> IO ModDetails +initModDetails hsc_env iface = fixIO $ \details' -> do - let act hpt = addToHpt hpt (ms_mod_name mod_summary) - (HomeModInfo iface details' Nothing) - let hsc_env' = hscUpdateHPT act hsc_env + 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] @@ -934,6 +1081,7 @@ let bcknd = backend dflags hsc_src = ms_hsc_src summary diag_opts = initDiagOpts dflags + print_config = initPrintConfig dflags -- Desugar, if appropriate -- @@ -948,14 +1096,14 @@ -- Report the warnings from both typechecking and desugar together w <- getDiagnostics - liftIO $ printOrThrowDiagnostics logger diag_opts (unionMessages tc_warnings w) + 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 | bcknd /= NoBackend -> do + Just desugared_guts | backendGeneratesCode bcknd -> do plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) simplified_guts <- hscSimplify' plugins desugared_guts @@ -966,7 +1114,7 @@ {-# SCC "GHC.Driver.Main.mkPartialIface" #-} -- This `force` saves 2M residency in test T10370 -- See Note [Avoiding space leaks in toIface*] for details. - force (mkPartialIface hsc_env details summary simplified_guts) + force (mkPartialIface hsc_env (cg_binds cg_guts) details summary simplified_guts) return HscRecomp { hscs_guts = cg_guts, hscs_mod_location = ms_location summary, @@ -974,11 +1122,29 @@ hscs_old_iface_hash = mb_old_hash } - -- We are not generating code, so we can skip simplification + 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 tc_result summary + hscSimpleIface hsc_env Nothing tc_result summary liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) @@ -1042,10 +1208,7 @@ -> IO () hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do let force_write_interface = gopt Opt_WriteInterface dflags - write_interface = case backend dflags of - NoBackend -> False - Interpreter -> False - _ -> True + 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 @@ -1310,10 +1473,11 @@ logDiagnostics oldErrs diag_opts <- initDiagOpts <$> getDynFlags + print_config <- initPrintConfig <$> getDynFlags logger <- getLogger -- Will throw if failed safe check - liftIO $ printOrThrowDiagnostics logger diag_opts safeErrs + liftIO $ printOrThrowDiagnostics logger print_config diag_opts safeErrs -- No fatal warnings or errors: passed safe check let infPassed = isEmptyMessages infErrs @@ -1510,7 +1674,7 @@ -- 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 :: Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv +markUnsafeInfer :: forall e . Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv markUnsafeInfer tcg_env whyUnsafe = do dflags <- getDynFlags @@ -1520,6 +1684,7 @@ (logDiagnostics $ singleMessage $ mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $ GhcDriverMessage $ DriverUnknownMessage $ + UnknownDiagnostic $ mkPlainDiagnostic reason noHints $ whyUnsafe' dflags) @@ -1538,7 +1703,9 @@ whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" , text "Reason:" , nest 4 $ (vcat $ badFlags df) $+$ - (vcat $ pprMsgEnvelopeBagWithLoc (getMessages whyUnsafe)) $+$ + -- 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 @@ -1590,19 +1757,21 @@ -- Interface generators -------------------------------------------------------------- --- | Generate a striped down interface file, e.g. for boot files or when ghci +-- | 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 tc_result summary - = runHsc hsc_env $ hscSimpleIface' tc_result summary +hscSimpleIface hsc_env mb_core_program tc_result summary + = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary -hscSimpleIface' :: TcGblEnv +hscSimpleIface' :: Maybe CoreProgram + -> TcGblEnv -> ModSummary -> Hsc (ModIface, ModDetails) -hscSimpleIface' tc_result summary = do +hscSimpleIface' mb_core_program tc_result summary = do hsc_env <- getHscEnv logger <- getLogger details <- liftIO $ mkBootModDetailsTc logger tc_result @@ -1610,7 +1779,7 @@ new_iface <- {-# SCC "MkFinalIface" #-} liftIO $ - mkIfaceTc hsc_env safe_mode details summary tc_result + mkIfaceTc hsc_env safe_mode details summary mb_core_program tc_result -- And the answer is ... liftIO $ dumpIfaceStats hsc_env return (new_iface, details) @@ -1633,11 +1802,14 @@ cg_foreign = foreign_stubs0, cg_foreign_files = foreign_files, cg_dep_pkgs = dependencies, - cg_hpc_info = hpc_info } = cgguts + 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, @@ -1661,9 +1833,13 @@ ------------------- -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form - (prepd_binds) <- {-# SCC "CorePrep" #-} - corePrepPgm hsc_env this_mod location - late_cc_binds data_tycons + (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) @@ -1688,56 +1864,84 @@ ------------------ 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 showPass isn't very useful here. - -- Hence we have one showPass for the whole backend, the - -- next showPass after this will be "Assembler". - withTiming logger - (text "CodeGen"<+>brackets (ppr this_mod)) - (const ()) $ do - cmms <- {-# SCC "StgToCmm" #-} - doCodeGen hsc_env this_mod denv data_tycons - cost_centre_info - stg_binds hpc_info + -- 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 = [] - ------------------ Code output ----------------------- - rawcmms0 <- {-# SCC "cmmToRawCmm" #-} - case cmmToRawCmmHook hooks of - Nothing -> cmmToRawCmm logger profile cmms - Just h -> h dflags (Just this_mod) cmms + putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG + (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds) - 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 + -- 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) - let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init - `appendStubC` cgIPEStub st + _ -> + do + cmms <- {-# SCC "StgToCmm" #-} + doCodeGen hsc_env this_mod denv data_tycons + cost_centre_info + stg_binds hpc_info - (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos) - <- {-# SCC "codeOutput" #-} - codeOutput logger tmpfs 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) + ------------------ 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 - -> CgGuts + -> 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 CgGuts{ -- This is the last use of the ModGuts in a compilation. + let CgInteractiveGuts{ -- 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_tycons = tycons, - cg_foreign = foreign_stubs, - cg_modBreaks = mod_breaks, - cg_spt_entries = spt_entries } = cgguts + 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, @@ -1746,8 +1950,13 @@ ------------------- -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form - prepd_binds <- {-# SCC "CorePrep" #-} - corePrepPgm hsc_env this_mod location core_binds data_tycons + 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 @@ -1761,6 +1970,32 @@ <- 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) @@ -1772,15 +2007,18 @@ 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 dflags cmm_mod home_unit filename + $ parseCmmFile cmmpConfig cmm_mod home_unit filename let msgs = warns `unionMessages` errs return (GhcPsMessage <$> msgs, cmm) liftIO $ do @@ -1793,7 +2031,7 @@ -- 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 hsc_env (emptySRT cmm_mod) [cmm]) cmm + concatMapM (\cmm -> snd <$> cmmPipeline logger cmm_config (emptySRT cmm_mod) [cmm]) cmm unless (null cmmgroup) $ putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" @@ -1809,11 +2047,11 @@ in NoStubs `appendStubC` ip_init | otherwise = NoStubs (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos) - <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty + <- 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 filename, + 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", @@ -1881,11 +2119,13 @@ ppr_stream1 = Stream.mapM dump1 cmm_stream + cmm_config = initCmmConfig dflags + pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) pipeline_stream = do (non_cafs, lf_infos) <- {-# SCC "cmmPipeline" #-} - Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1 + Stream.mapAccumL_ (cmmPipeline logger cmm_config) (emptySRT this_mod) ppr_stream1 <&> first (srtMapNonCAFs . moduleSRTMap) return (non_cafs, lf_infos) @@ -1910,7 +2150,7 @@ binding for the stg2stg step) -} let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel") (mkPseudoUniqueE 0) - Many + ManyTy (exprType prepd_expr) (stg_binds, prov_map, collected_ccs, stg_cg_infos) <- myCoreToStg logger @@ -1932,11 +2172,11 @@ myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do let (stg_binds, denv, cost_centre_info) = {-# SCC "Core2Stg" #-} - coreToStg dflags this_mod ml prepd_binds + coreToStg (initCoreToStgOpts dflags) this_mod ml prepd_binds (stg_binds_with_fvs,stg_cg_info) <- {-# SCC "Stg2Stg" #-} - stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode) + stg2stg logger (interactiveInScope ictxt) (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG @@ -2016,7 +2256,7 @@ -> IO ([TyThing], InteractiveContext) hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "" 1 -hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO HsModule +hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO (HsModule GhcPs) hscParseModuleWithLocation hsc_env source line_num str = do L _ mod <- runInteractiveHsc hsc_env $ @@ -2085,8 +2325,13 @@ {- Prepare For Code Generation -} -- Do saturation and convert to A-normal form - prepd_binds <- {-# SCC "CorePrep" #-} - liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons + 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" #-} @@ -2158,14 +2403,18 @@ hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs) hscImport hsc_env str = runInteractiveHsc hsc_env $ do - (L _ (HsModule{hsmodImports=is})) <- - hscParseThing parseModule str - case is of - [L _ i] -> return i - _ -> liftIO $ throwOneError $ - mkPlainErrorMsgEnvelope noSrcSpan $ - GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $ - text "parse error in import declaration" + -- 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 @@ -2195,7 +2444,7 @@ Just (L _ (BodyStmt _ expr _ _)) -> return expr _ -> throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $ - GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $ + GhcPsMessage $ PsUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ text "not an expression:" <+> quotes (text expr) hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) @@ -2254,15 +2503,16 @@ -- post tidy pretty-printing and linting... let tidy_rules = md_rules details let all_tidy_binds = cg_binds cgguts - let print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) (mg_rdr_env guts) + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts) + ptc = initPromotionTickContext (hsc_dflags hsc_env) - endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules + 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 - (renderWithContext defaultSDocContext (ppr CoreTidy <+> text "rules")) + "Tidy Core rules" FormatText (pprRulesForUser tidy_rules) @@ -2296,13 +2546,21 @@ = do { {- Simplify it -} -- Question: should we call SimpleOpt.simpleOptExpr here instead? -- It is, well, simpler, and does less inlining etc. - simpl_expr <- simplifyExpr hsc_env ds_expr + 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 -} - ; prepd_expr <- corePrepExpr hsc_env tidy_expr + ; cp_cfg <- initCorePrepConfig hsc_env + ; prepd_expr <- corePrepExpr + logger cp_cfg + tidy_expr {- Lint if necessary -} ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr @@ -2315,8 +2573,8 @@ ; let ictxt = hsc_IC hsc_env ; (binding_id, stg_expr, _, _, _stg_cg_info) <- - myCoreToStgExpr (hsc_logger hsc_env) - (hsc_dflags hsc_env) + myCoreToStgExpr logger + dflags ictxt True (icInteractiveModule ictxt) @@ -2369,4 +2627,4 @@ writeInterfaceOnlyMode :: DynFlags -> Bool writeInterfaceOnlyMode dflags = gopt Opt_WriteInterface dflags && - NoBackend == backend dflags + not (backendGeneratesCode (backend dflags)) diff --git a/GHC/Driver/Make.hs b/GHC/Driver/Make.hs --- a/GHC/Driver/Make.hs +++ b/GHC/Driver/Make.hs @@ -3,8 +3,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -55,7 +55,7 @@ import GHC.Platform import GHC.Tc.Utils.Backpack -import GHC.Tc.Utils.Monad ( initIfaceCheck ) +import GHC.Tc.Utils.Monad ( initIfaceCheck, concatMapM ) import GHC.Runtime.Interpreter import qualified GHC.Linker.Loader as Linker @@ -148,7 +148,11 @@ import GHC.Runtime.Loader import GHC.Rename.Names import GHC.Utils.Constants +import GHC.Types.Unique.DFM (udfmRestrictKeysSet) +import qualified Data.IntSet as I +import GHC.Types.Unique + -- ----------------------------------------------------------------------------- -- Loading the program @@ -442,7 +446,7 @@ addHmiToCache c (HomeModInfo i _ l) = iface_addToCache c (CachedIface i l) data CachedIface = CachedIface { cached_modiface :: !ModIface - , cached_linkable :: !(Maybe Linkable) } + , cached_linkable :: !HomeModLinkable } instance Outputable CachedIface where ppr (CachedIface mi ln) = hsep [text "CachedIface", ppr (miKey mi), ppr ln] @@ -533,20 +537,29 @@ 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 [ModuleGraphNode] + = 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 -getNode :: ModuleGraphNodeWithBootFile -> ModuleGraphNode -getNode (ModuleGraphNodeWithBootFile mgn _) = mgn -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 ModuleGraphNodeWithBootFile] -- A resolved cycle, linearised by hs-boot files - | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files +-- | 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) @@ -609,7 +622,7 @@ select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode] select_boot_modules = mapMaybe (fmap fst . get_boot_module) - get_boot_module :: (ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])) + 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 @@ -620,13 +633,13 @@ -- Cyclic collapseSCC _ = Nothing - toNodeWithBoot :: (ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile) + 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 (snd path)) + 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. @@ -649,6 +662,9 @@ -- 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 @@ -777,9 +793,10 @@ -- 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' <- if platformOS platform == OSMinGW32 - then fmap (<.> "exe") name - else name + !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' @@ -821,7 +838,7 @@ linkable' | Just ms <- M.lookup modl ms_map , mi_src_hash iface /= ms_hs_hash ms - = Nothing + = emptyHomeModInfoLinkable | otherwise = linkable @@ -854,9 +871,9 @@ 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 parrelism is controlled by a semaphore. This is just used around the +* 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 overal memory usage and allocations. + 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. @@ -960,8 +977,7 @@ -- | Simple wrapper around MVar which allows a functor instance. data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a)) -instance Functor ResultVar where - fmap f (ResultVar g var) = ResultVar (f . g) var +deriving instance Functor ResultVar mkResultVar :: MVar (Maybe a) -> ResultVar a mkResultVar = ResultVar id @@ -970,10 +986,22 @@ 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) + } -data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey (SDoc, 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, 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 appropiate result of compiling a module but with + -- 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 @@ -987,14 +1015,20 @@ modify (\m -> m { nNODE = n + 1 }) return n -setModulePipeline :: NodeKey -> SDoc -> ResultVar (Maybe HomeModInfo) -> BuildM () -setModulePipeline mgn doc wrapped_pipeline = do - modify (\m -> m { buildDep = M.insert mgn (doc, wrapped_pipeline) (buildDep m) }) -getBuildMap :: BuildM (M.Map - NodeKey (SDoc, ResultVar (Maybe HomeModInfo))) +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 @@ -1038,7 +1072,7 @@ where collect_results build_map = - sequence (map (\(_doc, res_var) -> collect_result res_var) (M.elems build_map)) + sequence (map (\br -> collect_result (fst <$> resultVar br)) (M.elems build_map)) where collect_result res_var = runMaybeT (waitResult res_var) @@ -1053,7 +1087,7 @@ case plan of -- If there was no cycle, then typecheckLoop is not necessary SingleModule m -> do - (one_plan, _) <- buildSingleModule Nothing m + one_plan <- buildSingleModule Nothing NoLoop m (cycle, all_plans) <- buildLoop plans return (cycle, one_plan : all_plans) @@ -1068,75 +1102,126 @@ -- Can't continue past this point as the cycle is unresolved. UnresolvedCycle ns -> return (Just ns, []) - buildSingleModule :: Maybe [ModuleGraphNode] -- Modules we need to rehydrate before compiling this module + buildSingleModule :: Maybe [NodeKey] -- Modules we need to rehydrate before compiling this module + -> ResultOrigin -> ModuleGraphNode -- The node we are compiling - -> BuildM (MakeAction, ResultVar (Maybe HomeModInfo)) - buildSingleModule rehydrate_nodes mod = do + -> BuildM MakeAction + buildSingleModule rehydrate_nodes origin mod = do mod_idx <- nodeId - home_mod_map <- getBuildMap + !build_map <- getBuildMap hug_var <- gets hug_var - -- 1. Get the transitive dependencies of this module, by looking up in the dependency map + -- 1. Get the direct dependencies of this module let direct_deps = nodeDependencies False mod - doc_build_deps = map (expectJust "dep_map" . flip M.lookup home_mod_map) direct_deps - build_deps = map snd doc_build_deps - -- 2. Set the default way to build this node, not in a loop here - let build_action = withCurrentUnit (moduleGraphNodeUnitId 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 = + withCurrentUnit (moduleGraphNodeUnitId mod) $ do + (hug, deps) <- wait_deps_hug hug_var build_deps case mod of - InstantiationNode uid iu -> - const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hug hug_var build_deps) uid iu + InstantiationNode uid iu -> do + executeInstantiationNode mod_idx n_mods hug uid iu + return (Nothing, deps) ModuleNode _build_deps ms -> do - let !old_hmi = M.lookup (msKey ms) old_hpt - rehydrate_mods = mapMaybe moduleGraphNodeModule <$> rehydrate_nodes - hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hug hug_var build_deps) 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. - hsc_env <- asks hsc_env - hmi' <- liftIO $ modifyMVar hug_var (\hug -> do - let new_hpt = addHomeModInfoToHug hmi hug - new_hsc = setHUG new_hpt hsc_env - maybeRehydrateAfter hmi new_hsc rehydrate_mods - ) - return (Just hmi') + let !old_hmi = M.lookup (msKey ms) old_hpt + rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes + 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 - executeLinkNode (wait_deps_hug hug_var build_deps) (mod_idx, n_mods) uid direct_deps - return Nothing + 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) (text "N") result_var - return $ (MakeAction build_action res_var, result_var) + setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var) + return $ (MakeAction build_action res_var) - buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM (MakeAction, (ResultVar (Maybe HomeModInfo))) - buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) = - buildSingleModule (Just deps) mn + 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 :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction] buildModuleLoop ms = do - (build_modules, wait_modules) <- mapAndUnzipM (either (buildSingleModule Nothing) buildOneLoopyModule) ms + 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_action = wait_deps wait_modules - let fanout i = Just . (!! i) <$> mkResultVar res_var + 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. - let update_module_pipeline (m, i) = setModulePipeline (NodeKey_Module m) (text "T") (fanout i) + 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) - let ms_i = zip (mapMaybe (fmap msKey . moduleGraphNodeModSum . either id getNode) ms) [0..] - mapM update_module_pipeline ms_i - return $ build_modules ++ [MakeAction loop_action res_var] + 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 @@ -1195,7 +1280,7 @@ -> 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) (old_hmi >>= hm_linkable) + 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 @@ -1203,7 +1288,7 @@ -- 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) - (hm_linkable hmi) + (homeModInfoByteCode hmi) return hmi @@ -1253,10 +1338,12 @@ that is imported by a module that uses template haskell, to generate object code. -The flavour of generated object code is chosen by defaultObjectTarget for the -target platform. It would likely be faster to generate bytecode, but this is not -supported on all platforms(?Please Confirm?), and does not support the entirety -of GHC haskell. See #1257. +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. @@ -1683,6 +1770,12 @@ 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 @@ -1708,7 +1801,7 @@ , ms_hsc_src = HsSrcFile , ms_hspp_opts = dflags } <- ms - , mkNodeKey n `Set.member` needs_codegen_set = + , 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 @@ -1727,18 +1820,32 @@ , (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 $ dflags {backend = defaultBackendOf ms} + , ms_hspp_opts = updOptLevel 0 $ new_dflags } -- Recursive call to catch the other cases enable_code_gen (ModuleNode deps ms') - | dynamic_too_enable ms -> do + + -- 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 @@ -1755,23 +1862,45 @@ enable_code_gen ms = return ms nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) = - backend dflags == NoBackend && + 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 ms + 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) + 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 @@ -1781,19 +1910,44 @@ 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 - (mg, lookup_node) = moduleGraphNodes False mod_graph - needs_codegen_set = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) has_th_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]) - has_th_set = - [ mkNodeKey mn - | mn@(ModuleNode _ ms) <- mod_graph - , isTemplateHaskellOrQQNonBoot ms - ] + -- 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] @@ -2155,9 +2309,9 @@ let deferDiagnostics _dflags !msgClass !srcSpan !msg = do let action = logMsg logger msgClass srcSpan msg case msgClass of - MCDiagnostic SevWarning _reason + MCDiagnostic SevWarning _reason _code -> atomicModifyIORef' warnings $ \i -> (action: i, ()) - MCDiagnostic SevError _reason + MCDiagnostic SevError _reason _code -> atomicModifyIORef' errors $ \i -> (action: i, ()) MCFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ()) @@ -2178,7 +2332,8 @@ noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err - = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $ + = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ + DriverUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ cannotFindModule hsc_env wanted_mod err {- @@ -2263,7 +2418,8 @@ wrapAction hsc_env k = do let lcl_logger = hsc_logger hsc_env lcl_dynflags = hsc_dflags hsc_env - let logg err = printMessages lcl_logger (initDiagOpts lcl_dynflags) (srcErrorMessages err) + 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 @@ -2304,13 +2460,11 @@ executeInstantiationNode :: Int -> Int - -> RunMakeM HomeUnitGraph + -> HomeUnitGraph -> UnitId -> InstantiatedUnit -> RunMakeM () -executeInstantiationNode k n wait_deps uid iu = do - -- Wait for the dependencies of this node - deps <- wait_deps +executeInstantiationNode k n deps uid iu = do env <- ask -- Output of the logger is mediated by a central worker to -- avoid output interleaving @@ -2326,23 +2480,22 @@ executeCompileNode :: Int -> Int -> Maybe HomeModInfo - -> RunMakeM HomeUnitGraph + -> HomeUnitGraph -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling -> ModSummary -> RunMakeM HomeModInfo -executeCompileNode k n !old_hmi wait_deps mrehydrate_mods mod = do +executeCompileNode k n !old_hmi hug mrehydrate_mods mod = do me@MakeEnv{..} <- ask - deps <- wait_deps -- 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 deps hsc_env) mod fixed_mrehydrate_mods + 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 semphore to avoid too many modules + -- 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 @@ -2364,11 +2517,11 @@ -> [HomeModInfo] -- ^ These are the modules we want to rehydrate. -> IO HscEnv rehydrate hsc_env hmis = do - debugTraceMsg logger 2 $ - text "Re-hydrating loop: " + 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 (const new_hpt) hsc_env + 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 }) @@ -2398,17 +2551,14 @@ let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (ms_mod mod) in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv -maybeRehydrateAfter :: HomeModInfo - -> HscEnv - -> Maybe [ModuleName] - -> IO (HomeUnitGraph, HomeModInfo) -maybeRehydrateAfter hmi new_hsc Nothing = return (hsc_HUG new_hsc, hmi) -maybeRehydrateAfter hmi new_hsc (Just mns) = do +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 - new_mod_name = moduleName (mi_module (hm_iface hmi)) - hsc_env <- rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) (hmi : hmis) - return (hsc_HUG hsc_env, expectJust "rehydrate" $ lookupHpt (hsc_HPT hsc_env) new_mod_name) + 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] @@ -2509,6 +2659,49 @@ 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. @@ -2520,9 +2713,9 @@ 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 the argument type of `MkX`. So: +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 beeen compiled. (This is what we do) +* 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. @@ -2536,11 +2729,10 @@ -} -executeLinkNode :: RunMakeM HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM () -executeLinkNode wait_deps kn uid deps = do +executeLinkNode :: HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM () +executeLinkNode hug kn uid deps = do withCurrentUnit uid $ do MakeEnv{..} <- ask - hug <- wait_deps 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 @@ -2559,29 +2751,77 @@ 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 I.IntSet + +addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet +addToModuleNameSet uid mn s = + let k = (getKey $ getUnique $ mn) + in M.insertWith (I.union) uid (I.singleton k) s + -- | Wait for some dependencies to finish and then read from the given MVar. -wait_deps_hug :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b +wait_deps_hug :: MVar HomeUnitGraph -> [BuildResult] -> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet) wait_deps_hug hug_var deps = do - _ <- wait_deps deps - liftIO $ readMVar hug_var - + (_, 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 I.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 :: [ResultVar (Maybe HomeModInfo)] -> RunMakeM [HomeModInfo] -wait_deps [] = return [] +wait_deps :: [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet) +wait_deps [] = return ([], M.empty) wait_deps (x:xs) = do - res <- lift $ waitResult x + (res, deps) <- lift $ waitResult (resultVar x) + (hmis, all_deps) <- wait_deps xs + let !new_deps = deps `unionModuleNameSet` all_deps case res of - Nothing -> wait_deps xs - Just hmi -> (hmi:) <$> wait_deps xs + Nothing -> return (hmis, new_deps) + Just hmi -> return (hmi:hmis, new_deps) + where + unionModuleNameSet = M.unionWith I.union -- Executing the pipelines --- | Start a thread which reads from the LogQueueQueue - label_self :: String -> IO () label_self thread_name = do self_tid <- CC.myThreadId @@ -2591,13 +2831,11 @@ runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO () -- Don't even initialise plugins if there are no pipelines runPipelines _ _ _ [] = return () -runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do +runPipelines n_job hsc_env mHscMessager all_pipelines = do liftIO $ label_self "main --make thread" - - plugins_hsc_env <- initializePlugins orig_hsc_env case n_job of - 1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines - _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines + 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 = @@ -2687,7 +2925,7 @@ MC.bracket spawn_actions kill_actions $ \_ -> do mapM_ waitMakeAction acts --- | Execute each action in order, limiting the amount of parrelism by the given +-- | 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 [] @@ -2740,4 +2978,9 @@ 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. -} diff --git a/GHC/Driver/MakeFile.hs b/GHC/Driver/MakeFile.hs --- a/GHC/Driver/MakeFile.hs +++ b/GHC/Driver/MakeFile.hs @@ -27,6 +27,7 @@ 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 @@ -260,7 +261,7 @@ -- Emit a dependency for each CPP import ; when (depIncludeCppDeps dflags) $ do - -- CPP deps are descovered in the module parsing phase by parsing + -- CPP deps are discovered in the module parsing phase by parsing -- comment lines left by the preprocessor. -- Note that GHC.parseModule may throw an exception if the module -- fails to parse, which may not be desirable (see #16616). @@ -306,7 +307,8 @@ fail -> throwOneError $ mkPlainErrorMsgEnvelope srcloc $ - GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $ + GhcDriverMessage $ DriverUnknownMessage $ + UnknownDiagnostic $ mkPlainError noHints $ cannotFindModule hsc_env imp fail ----------------------------- diff --git a/GHC/Driver/Monad.hs b/GHC/Driver/Monad.hs --- a/GHC/Driver/Monad.hs +++ b/GHC/Driver/Monad.hs @@ -147,15 +147,16 @@ dflags <- getSessionDynFlags logger <- getLogger let !diag_opts = initDiagOpts dflags - liftIO $ printOrThrowDiagnostics logger diag_opts warns + !print_config = initPrintConfig dflags + liftIO $ printOrThrowDiagnostics logger print_config diag_opts warns -- ----------------------------------------------------------------------------- -- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, -- e.g., to maintain additional state consider wrapping this monad or using -- 'GhcT'. newtype Ghc a = Ghc { unGhc :: Session -> IO a } - deriving (Functor) - deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session IO) + deriving stock (Functor) + deriving (Applicative, Monad, MonadFail, MonadFix, MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT Session IO) -- | The Session is a handle to the complete state of a compilation -- session. A compilation session consists of a set of modules @@ -163,19 +164,6 @@ -- interactive evaluation, and various caches. data Session = Session !(IORef HscEnv) -instance Applicative Ghc where - pure a = Ghc $ \_ -> return a - g <*> m = do f <- g; a <- m; return (f a) - -instance Monad Ghc where - m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s - -instance MonadIO Ghc where - liftIO ioA = Ghc $ \_ -> ioA - -instance MonadFix Ghc where - mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s) - instance HasDynFlags Ghc where getDynFlags = getSessionDynFlags @@ -213,22 +201,12 @@ -- -- Note that the wrapped monad must support IO and handling of exceptions. newtype GhcT m a = GhcT { unGhcT :: Session -> m a } - deriving (Functor) - deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session m) + deriving stock (Functor) + deriving (Applicative, Monad, MonadFail, MonadFix, MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT Session m) liftGhcT :: m a -> GhcT m a liftGhcT m = GhcT $ \_ -> m -instance Applicative m => Applicative (GhcT m) where - pure x = GhcT $ \_ -> pure x - g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s - -instance Monad m => Monad (GhcT m) where - m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s - -instance MonadIO m => MonadIO (GhcT m) where - liftIO ioA = GhcT $ \_ -> liftIO ioA - instance MonadIO m => HasDynFlags (GhcT m) where getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) @@ -247,7 +225,8 @@ dflags <- getDynFlags logger <- getLogger let !diag_opts = initDiagOpts dflags - liftIO $ printMessages logger diag_opts (srcErrorMessages err) + !print_config = initPrintConfig dflags + liftIO $ printMessages logger print_config diag_opts (srcErrorMessages err) -- | A function called to log warnings and errors. type WarnErrLogger = forall m. (HasDynFlags m , MonadIO m, HasLogger m) => Maybe SourceError -> m () diff --git a/GHC/Driver/Phases.hs b/GHC/Driver/Phases.hs --- a/GHC/Driver/Phases.hs +++ b/GHC/Driver/Phases.hs @@ -99,6 +99,7 @@ | CmmCpp -- pre-process Cmm source | Cmm -- parse & compile Cmm code | MergeForeign -- merge in the foreign object files + | Js -- pre-process Js source -- The final phase is a pseudo-phase that tells the pipeline to stop. | StopLn -- Stop, but linking will follow, so generate .o file @@ -134,6 +135,7 @@ eqPhase StopLn StopLn = True eqPhase Ccxx Ccxx = True eqPhase Cobjcxx Cobjcxx = True +eqPhase Js Js = True eqPhase _ _ = False -- MP: happensBefore is only used in preprocessPipeline, that usage should @@ -157,14 +159,15 @@ LlvmLlc -> LlvmMangle LlvmMangle -> As False As _ -> MergeForeign - Ccxx -> As False - Cc -> As False - Cobjc -> As False - Cobjcxx -> As False + Ccxx -> MergeForeign + Cc -> MergeForeign + Cobjc -> MergeForeign + Cobjcxx -> MergeForeign CmmCpp -> Cmm Cmm -> maybeHCc - HCc -> As False + HCc -> MergeForeign MergeForeign -> StopLn + Js -> StopLn StopLn -> panic "nextPhase: nothing after StopLn" where maybeHCc = if platformUnregisterised platform then HCc @@ -198,6 +201,7 @@ startPhase "o" = StopLn startPhase "cmm" = CmmCpp startPhase "cmmcpp" = Cmm +startPhase "js" = Js startPhase _ = StopLn -- all unknown file types -- This is used to determine the extension for the output from the @@ -226,10 +230,11 @@ phaseInputExt CmmCpp = "cmmcpp" phaseInputExt Cmm = "cmm" phaseInputExt MergeForeign = "o" +phaseInputExt Js = "js" phaseInputExt StopLn = "o" haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, - haskellish_user_src_suffixes, haskellish_sig_suffixes + js_suffixes, haskellish_user_src_suffixes, haskellish_sig_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. @@ -238,6 +243,7 @@ haskellish_suffixes = haskellish_src_suffixes ++ [ "hc", "cmm", "cmmcpp" ] cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] +js_suffixes = [ "js" ] -- Will not be deleted as temp files: haskellish_user_src_suffixes = @@ -259,13 +265,14 @@ _ -> ["so"] isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, - isHaskellUserSrcSuffix, isHaskellSigSuffix + isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix :: String -> Bool isHaskellishSuffix s = s `elem` haskellish_suffixes isBackpackishSuffix s = s `elem` backpackish_suffixes isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes isCishSuffix s = s `elem` cish_suffixes +isJsSuffix s = s `elem` js_suffixes isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool @@ -275,6 +282,7 @@ isSourceSuffix :: String -> Bool isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff + || isJsSuffix suff || isBackpackishSuffix suff -- | When we are given files (modified by -x arguments) we need @@ -291,7 +299,7 @@ isHaskellishTarget (f,Nothing) = looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f) isHaskellishTarget (_,Just phase) = - phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm + phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm, Js , StopLn] isHaskellishFilename, isHaskellSrcFilename, isCishFilename, @@ -319,5 +327,5 @@ HCc -> Just LangC As _ -> Just LangAsm MergeForeign -> Just RawObject + Js -> Just LangJs _ -> Nothing - diff --git a/GHC/Driver/Pipeline.hs b/GHC/Driver/Pipeline.hs --- a/GHC/Driver/Pipeline.hs +++ b/GHC/Driver/Pipeline.hs @@ -1,12 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeApplications #-} + {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- -- @@ -40,7 +42,7 @@ TPipelineClass, MonadUse(..), preprocessPipeline, fullPipeline, hscPipeline, hscBackendPipeline, hscPostBackendPipeline, - hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline, + hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline, jsPipeline, llvmPipeline, llvmLlcPipeline, llvmManglePipeline, pipelineStart, -- * Default method of running a pipeline @@ -60,6 +62,7 @@ import GHC.Driver.Errors.Types import GHC.Driver.Pipeline.Monad import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.StgToJS import GHC.Driver.Phases import GHC.Driver.Pipeline.Execute import GHC.Driver.Pipeline.Phases @@ -71,6 +74,7 @@ import GHC.Platform.Ways import GHC.SysTools +import GHC.SysTools.Cpp import GHC.Utils.TmpFs import GHC.Linker.ExtraObj @@ -78,6 +82,9 @@ import GHC.Linker.Static.Utils import GHC.Linker.Types +import GHC.StgToJS.Linker.Linker +import GHC.StgToJS.Linker.Types (defaultJSLinkConfig) + import GHC.Utils.Outputable import GHC.Utils.Error import GHC.Utils.Panic @@ -96,7 +103,7 @@ import GHC.Types.Basic ( SuccessFlag(..), ForeignSrcLang(..) ) -import GHC.Types.Error ( singleMessage, getMessages ) +import GHC.Types.Error ( singleMessage, getMessages, UnknownDiagnostic (..) ) import GHC.Types.Target import GHC.Types.SrcLoc import GHC.Types.SourceFile @@ -122,7 +129,6 @@ import Data.Time ( getCurrentTime ) import GHC.Iface.Recomp -import GHC.Types.Unique.DSet -- Simpler type synonym for actions in the pipeline monad type P m = TPipelineClass TPhase m @@ -156,13 +162,14 @@ handler (ProgramError msg) = return $ Left $ singleMessage $ mkPlainErrorMsgEnvelope srcspan $ - DriverUnknownMessage $ mkPlainError noHints $ text msg + DriverUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ text msg handler ex = throwGhcExceptionIO ex to_driver_messages :: Messages GhcMessage -> Messages DriverMessage to_driver_messages msgs = case traverse to_driver_message msgs of Nothing -> pprPanic "non-driver message in preprocess" - (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs)) + -- MP: Default config is fine here as it's just in a panic. + (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @GhcMessage) (getMessages msgs)) Just msgs' -> msgs' to_driver_message = \case @@ -210,7 +217,7 @@ -> Int -- ^ module N ... -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one - -> Maybe Linkable -- ^ old linkable, if we have one + -> HomeModLinkable -- ^ old linkable, if we have one -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compileOne = compileOne' (Just batchMsg) @@ -221,7 +228,7 @@ -> Int -- ^ module N ... -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one - -> Maybe Linkable -- ^ old linkable, if we have one + -> HomeModLinkable -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compileOne' mHscMessage @@ -230,33 +237,31 @@ debugTraceMsg logger 2 (text "compile: input file" <+> text input_fnpp) - let flags = hsc_dflags hsc_env0 - in do unless (gopt Opt_KeepHiFiles flags) $ - addFilesToClean tmpfs TFL_CurrentModule $ - [ml_hi_file $ ms_location summary] - unless (gopt Opt_KeepOFiles flags) $ - addFilesToClean tmpfs TFL_GhcSession $ - [ml_obj_file $ ms_location summary] + unless (gopt Opt_KeepHiFiles lcl_dflags) $ + addFilesToClean tmpfs TFL_CurrentModule $ + [ml_hi_file $ ms_location summary] + unless (gopt Opt_KeepOFiles lcl_dflags) $ + addFilesToClean tmpfs TFL_GhcSession $ + [ml_obj_file $ ms_location summary] + -- Initialise plugins here for any plugins enabled locally for a module. plugin_hsc_env <- initializePlugins hsc_env let pipe_env = mkPipeEnv NoStop input_fn Nothing pipelineOutput status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary mb_old_iface mb_old_linkable (mod_index, nmods) let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status) - (iface, linkable) <- runPipeline (hsc_hooks hsc_env) pipeline + (iface, linkable) <- runPipeline (hsc_hooks plugin_hsc_env) pipeline -- See Note [ModDetails and --make mode] - details <- initModDetails plugin_hsc_env upd_summary iface - return $! HomeModInfo iface details linkable + details <- initModDetails plugin_hsc_env iface + linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable) + return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' }) where lcl_dflags = ms_hspp_opts summary location = ms_location summary input_fn = expectJust "compile:hs" (ml_hs_file location) input_fnpp = ms_hspp_file summary - pipelineOutput = case bcknd of - Interpreter -> NoOutputFile - NoBackend -> NoOutputFile - _ -> Persistent + pipelineOutput = backendPipelineOutput bcknd logger = hsc_logger hsc_env0 tmpfs = hsc_tmpfs hsc_env0 @@ -280,7 +285,10 @@ -- was set), force it to generate byte-code. This is NOT transitive and -- only applies to direct targets. | loadAsByteCode - = (Interpreter, gopt_set (lcl_dflags { backend = Interpreter }) Opt_ForceRecomp) + = ( interpreterBackend + , gopt_set (lcl_dflags { backend = interpreterBackend }) Opt_ForceRecomp + ) + | otherwise = (backend dflags, lcl_dflags) -- See Note [Filepaths and Multiple Home Units] @@ -361,17 +369,17 @@ link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt = case linkHook hooks of Nothing -> case ghcLink of - NoLink -> return Succeeded - LinkBinary -> normal_link - LinkStaticLib -> normal_link - LinkDynLib -> normal_link - LinkMergedObj -> normal_link - LinkInMemory - | platformMisc_ghcWithInterpreter $ platformMisc dflags - -> -- Not Linking...(demand linker will do the job) - return Succeeded - | otherwise - -> panicBadLink LinkInMemory + NoLink -> return Succeeded + LinkBinary -> normal_link + LinkStaticLib -> normal_link + LinkDynLib -> normal_link + LinkMergedObj -> normal_link + LinkInMemory + | platformMisc_ghcWithInterpreter $ platformMisc dflags + -- Not Linking...(demand linker will do the job) + -> return Succeeded + | otherwise + -> 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 @@ -407,9 +415,11 @@ $ home_mod_infos -- the linkables to link - linkables = map (expectJust "link".hm_linkable) home_mod_infos + linkables = map (expectJust "link". homeModInfoObject) home_mod_infos + debugTraceMsg logger 3 (text "link: hmi ..." $$ vcat (map (ppr . mi_module . hm_iface) home_mod_infos)) debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) + debugTraceMsg logger 3 (text "link: pkg deps are ..." $$ vcat (map ppr pkg_deps)) -- check for the -no-link flag if isNoLink (ghcLink dflags) @@ -420,7 +430,8 @@ let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked) obj_files = concatMap getOfiles linkables platform = targetPlatform dflags - exe_file = exeFileName platform staticLink (outputFile_ dflags) + arch_os = platformArchOS platform + exe_file = exeFileName arch_os staticLink (outputFile_ dflags) linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps @@ -432,12 +443,13 @@ -- Don't showPass in Batch mode; doLink will do that for us. - let link = case ghcLink dflags of - LinkBinary -> linkBinary logger tmpfs - LinkStaticLib -> linkStaticLib logger - LinkDynLib -> linkDynLibCheck logger tmpfs - other -> panicBadLink other - link dflags unit_env obj_files pkg_deps + case ghcLink dflags of + LinkBinary + | backendUseJSLinker (backend dflags) -> linkJSBinary logger 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 + other -> panicBadLink other debugTraceMsg logger 3 (text "link: done") @@ -450,6 +462,15 @@ return Succeeded +linkJSBinary :: Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkJSBinary logger 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 cfg = initStgToJSConfig dflags + let extra_js = mempty + jsLinkBinary lc_cfg cfg extra_js logger 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 -- if the modification time on the executable is later than the @@ -457,7 +478,8 @@ -- linking (unless the -fforce-recomp flag was given). let platform = ue_platform unit_env unit_state = ue_units unit_env - exe_file = exeFileName platform staticLink (outputFile_ dflags) + arch_os = platformArchOS platform + exe_file = exeFileName arch_os staticLink (outputFile_ dflags) e_exe_time <- tryIO $ getModificationUTCTime exe_file case e_exe_time of Left _ -> return $ NeedsRecompile MustCompile @@ -473,18 +495,8 @@ -- next, check libraries. XXX this only checks Haskell libraries, -- not extra_libraries or -l things from the command line. - -- pkg_deps is just the direct dependencies so take the transitive closure here - -- to decide if we need to relink or not. - let pkg_hslibs acc uid - | uid `elementOfUniqDSet` acc = acc - | Just c <- lookupUnitId unit_state uid = - foldl' @[] pkg_hslibs (addOneToUniqDSet acc uid) (unitDepends c) - | otherwise = acc - - all_pkg_deps = foldl' @[] pkg_hslibs emptyUniqDSet pkg_deps - let pkg_hslibs = [ (collectLibraryDirs (ways dflags) [c], lib) - | Just c <- map (lookupUnitId unit_state) (uniqDSetToList all_pkg_deps), + | Just c <- map (lookupUnitId unit_state) pkg_deps, lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ] pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs @@ -515,7 +527,11 @@ -- Compile files in one-shot mode. oneShot :: HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO () -oneShot hsc_env stop_phase srcs = do +oneShot orig_hsc_env stop_phase srcs = do + -- 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. + hsc_env <- initializePlugins orig_hsc_env o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs case stop_phase of StopPreprocess -> return () @@ -538,7 +554,7 @@ -- When linking, the -o argument refers to the linker's output. -- otherwise, we use it as the name for the pipeline's output. output - | NoBackend <- backend dflags, notStopPreprocess = NoOutputFile + | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile -- avoid -E -fno-code undesirable interactions. see #20439 | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent -- -o foo applies to linker @@ -551,24 +567,28 @@ doLink :: HscEnv -> [FilePath] -> IO () -doLink hsc_env o_files = - let - dflags = hsc_dflags hsc_env - logger = hsc_logger hsc_env - unit_env = hsc_unit_env hsc_env - tmpfs = hsc_tmpfs hsc_env - in case ghcLink dflags of - NoLink -> return () - LinkBinary -> 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 [] - LinkMergedObj - | Just out <- outputFile dflags - , let objs = [ f | FileOption _ f <- ldInputs dflags ] - -> joinObjectFiles hsc_env (o_files ++ objs) out - | otherwise -> panic "Output path must be specified for LinkMergedObj" - other -> panicBadLink other +doLink hsc_env o_files = do + let + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + unit_env = hsc_unit_env hsc_env + tmpfs = hsc_tmpfs hsc_env + case ghcLink dflags of + NoLink -> return () + LinkBinary + | backendUseJSLinker (backend dflags) + -> linkJSBinary logger 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 [] + LinkMergedObj + | Just out <- outputFile dflags + , let objs = [ f | FileOption _ f <- ldInputs dflags ] + -> joinObjectFiles hsc_env (o_files ++ objs) out + | otherwise -> panic "Output path must be specified for LinkMergedObj" + other -> panicBadLink other + ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support), and cc files. @@ -592,6 +612,7 @@ LangObjc -> viaCPipeline Cobjc 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 @@ -601,7 +622,7 @@ -- This should never happen as viaCPipeline should only return `Nothing` when the stop phase is `StopC`. -- and the same should never happen for asPipeline -- Future refactoring to not check StopC for this case - Nothing -> pprPanic "compileForeign" (ppr stub_c) + Nothing -> pprPanic "compileForeign" (text stub_c) Just fp -> return fp compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () @@ -615,16 +636,29 @@ -- and https://github.com/haskell/cabal/issues/2257 let logger = hsc_logger hsc_env let tmpfs = hsc_tmpfs hsc_env - empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c" let home_unit = hsc_home_unit hsc_env - src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" - writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) - let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename} - pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub - _ <- runPipeline (hsc_hooks hsc_env) pipeline - return () + case backendCodeOutput (backend dflags) of + JSCodeOutput -> do + empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" + let src = ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" + writeFile empty_stub (showSDoc dflags (pprCode src)) + let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename} + pipeline = Just <$> foreignJsPipeline pipe_env hsc_env (Just location) empty_stub + _ <- runPipeline (hsc_hooks hsc_env) pipeline + pure () + _ -> do + empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c" + let src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" + writeFile empty_stub (showSDoc dflags (pprCode src)) + let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename} + pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub + _ <- runPipeline (hsc_hooks hsc_env) pipeline + pure () + + + {- Environment Initialisation -} mkPipeEnv :: StopPhase -- End phase @@ -700,8 +734,9 @@ -- Reparse with original hsc_env so that we don't get duplicated options use (T_FileArgs hsc_env pp_fn) - liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3)) - liftIO (handleFlagWarnings (hsc_logger hsc_env) (initDiagOpts dflags3) warns3) + 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) return (dflags3, pp_fn) @@ -722,7 +757,7 @@ $ phaseIfFlag hsc_env flag def action -- | The complete compilation pipeline, from start to finish -fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, Maybe Linkable) +fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable) fullPipeline pipe_env hsc_env pp_fn src_flavour = do (dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn let hsc_env' = hscSetFlags dflags hsc_env @@ -731,7 +766,7 @@ hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) -- | Everything after preprocess -hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, Maybe Linkable) +hscPipeline :: P m => PipeEnv -> ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, HomeModLinkable) hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do case hsc_recomp_status of HscUpToDate iface mb_linkable -> return (iface, mb_linkable) @@ -740,28 +775,28 @@ hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash ) hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction -hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, Maybe Linkable) +hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, HomeModLinkable) hscBackendPipeline pipe_env hsc_env mod_sum result = - case backend (hsc_dflags hsc_env) of - NoBackend -> - case result of - HscUpdate iface -> return (iface, Nothing) - HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing) <*> pure Nothing - -- TODO: Why is there not a linkable? - -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing - _ -> do + 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 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 hscGenBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction - -> m (ModIface, Maybe Linkable) + -> m (ModIface, HomeModLinkable) hscGenBackendPipeline pipe_env hsc_env mod_sum result = do let mod_name = moduleName (ms_mod mod_sum) src_flavour = (ms_hsc_src mod_sum) @@ -776,7 +811,8 @@ 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] - return (Just linkable) + -- Add the object linkable to the potential bytecode linkable which was generated in HscBackend. + return (mlinkable { homeMod_object = Just linkable }) return (miface, final_linkable) asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile) @@ -787,10 +823,10 @@ 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 input_fn) + out_fn <- use (T_Cc c_phase pipe_env hsc_env location input_fn) case stop_phase pipe_env of StopC -> return Nothing - _ -> asPipeline False pipe_env hsc_env location out_fn + _ -> return $ Just out_fn llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) llvmPipeline pipe_env hsc_env location fp = do @@ -810,30 +846,46 @@ else use (T_LlvmMangle pipe_env hsc_env llc_fn) asPipeline False pipe_env hsc_env location mangled_fn -cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) +cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath cmmCppPipeline pipe_env hsc_env input_fn = do output_fn <- use (T_CmmCpp pipe_env hsc_env input_fn) cmmPipeline pipe_env hsc_env output_fn -cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) +cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath cmmPipeline pipe_env hsc_env input_fn = do (fos, output_fn) <- use (T_Cmm pipe_env hsc_env input_fn) mo_fn <- hscPostBackendPipeline pipe_env hsc_env HsSrcFile (backend (hsc_dflags hsc_env)) Nothing output_fn case mo_fn of - Nothing -> return Nothing - Just mo_fn -> Just <$> use (T_MergeForeign pipe_env hsc_env mo_fn fos) + Nothing -> panic "CMM pipeline - produced no .o file" + Just mo_fn -> use (T_MergeForeign pipe_env hsc_env mo_fn fos) +jsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath +jsPipeline pipe_env hsc_env location input_fn = do + use (T_Js pipe_env hsc_env location input_fn) + +foreignJsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath +foreignJsPipeline pipe_env hsc_env location input_fn = do + 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 = - case bcknd of - ViaC -> viaCPipeline HCc pipe_env hsc_env ml input_fn - NCG -> asPipeline False pipe_env hsc_env ml input_fn - LLVM -> llvmPipeline pipe_env hsc_env ml input_fn - NoBackend -> return Nothing - Interpreter -> return Nothing + applyPostHscPipeline (backendPostHscPipeline bcknd) pipe_env hsc_env ml input_fn +applyPostHscPipeline + :: TPipelineClass TPhase m + => DefunctionalizedPostHscPipeline + -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) +applyPostHscPipeline NcgPostHscPipeline = + \pe he ml fp -> asPipeline False pe he ml fp +applyPostHscPipeline ViaCPostHscPipeline = viaCPipeline HCc +applyPostHscPipeline LlvmPostHscPipeline = + \pe he ml fp -> llvmPipeline pe he ml fp +applyPostHscPipeline JSPostHscPipeline = + \pe he ml fp -> Just <$> jsPipeline pe he ml fp +applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing + -- Pipeline from a given suffix pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> Maybe Phase -> m (Maybe FilePath) pipelineStart pipe_env hsc_env input_fn mb_phase = @@ -865,10 +917,9 @@ as :: P m => Bool -> m (Maybe FilePath) as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn - objFromLinkable (_, Just (LM _ _ [DotO lnk])) = Just lnk + objFromLinkable (_, homeMod_object -> Just (LM _ _ [DotO lnk])) = Just lnk objFromLinkable _ = Nothing - fromPhase :: P m => Phase -> m (Maybe FilePath) fromPhase (Unlit p) = frontend p fromPhase (Cpp p) = frontend p @@ -884,8 +935,9 @@ fromPhase LlvmLlc = llvmLlcPipeline pipe_env hsc_env Nothing input_fn fromPhase LlvmMangle = llvmManglePipeline pipe_env hsc_env Nothing input_fn fromPhase StopLn = return (Just input_fn) - fromPhase CmmCpp = cmmCppPipeline pipe_env hsc_env input_fn - fromPhase Cmm = cmmPipeline pipe_env hsc_env input_fn + fromPhase CmmCpp = Just <$> cmmCppPipeline pipe_env hsc_env input_fn + fromPhase Cmm = Just <$> cmmPipeline pipe_env hsc_env input_fn + fromPhase Js = Just <$> foreignJsPipeline pipe_env hsc_env Nothing input_fn fromPhase MergeForeign = panic "fromPhase: MergeForeign" {- @@ -902,7 +954,7 @@ `TPipelineClass` to give different behaviours that the default `HookedPhase` implementation: * Additional logging of different phases -* Automatic parrelism (in the style of shake) +* Automatic parallelism (in the style of shake) * Easy consumption by external tools such as ghcide * Easier to create your own pipeline and extend existing pipelines. 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 @@ -5,8 +5,9 @@ import GHC.ForeignSrcLang ( ForeignSrcLang ) import GHC.Prelude (FilePath, IO) import GHC.Unit.Module.Location (ModLocation) -import GHC.Unit.Module.Name (ModuleName) import GHC.Driver.Session (DynFlags) + +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 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 @@ -22,12 +22,10 @@ import GHC.Driver.Env hiding (Hsc) import GHC.Unit.Module.Location import GHC.Driver.Phases -import GHC.Unit.Module.Name ( ModuleName ) import GHC.Unit.Types import GHC.Types.SourceFile import GHC.Unit.Module.Status import GHC.Unit.Module.ModIface -import GHC.Linker.Types import GHC.Driver.Backend import GHC.Driver.Session import GHC.Driver.CmdLine @@ -44,11 +42,11 @@ import GHC.Platform import Data.List (intercalate, isInfixOf) import GHC.Unit.Env -import GHC.SysTools.Info import GHC.Utils.Error import Data.Maybe import GHC.CmmToLlvm.Mangler import GHC.SysTools +import GHC.SysTools.Cpp import GHC.Utils.Panic.Plain import System.Directory import System.FilePath @@ -59,30 +57,32 @@ import GHC.Unit.Home import GHC.Data.Maybe import GHC.Iface.Make -import Data.Time import GHC.Driver.Config.Parser import GHC.Parser.Header import GHC.Data.StringBuffer import GHC.Types.SourceError import GHC.Unit.Finder -import GHC.Runtime.Loader import Data.IORef import GHC.Types.Name.Env import GHC.Platform.Ways -import GHC.Platform.ArchOS -import GHC.CmmToLlvm.Base ( llvmVersionList ) +import GHC.Driver.LlvmConfigCache (readLlvmConfigCache) +import GHC.CmmToLlvm.Config (LlvmTarget (..), LlvmConfig (..)) import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub) import GHC.Settings import System.IO import GHC.Linker.ExtraObj import GHC.Linker.Dynamic -import Data.Version import GHC.Utils.Panic import GHC.Unit.Module.Env import GHC.Driver.Env.KnotVars import GHC.Driver.Config.Finder import GHC.Rename.Names +import GHC.StgToJS.Linker.Linker (embedJsFile) +import Language.Haskell.Syntax.Module.Name +import GHC.Unit.Home.ModInfo +import GHC.Runtime.Loader (initializePlugins) + newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO) @@ -121,9 +121,16 @@ (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (hsc_unit_env hsc_env) - False{-not raw-} + (CppOpts + { cppUseCc = True + , cppLinePragmas = True + }) input_fn output_fn return output_fn +runPhase (T_Js pipe_env hsc_env location js_src) = + runJsPhase pipe_env hsc_env location js_src +runPhase (T_ForeignJs pipe_env hsc_env location js_src) = + runForeignJsPhase pipe_env hsc_env location js_src runPhase (T_Cmm pipe_env hsc_env input_fn) = do let dflags = hsc_dflags hsc_env let next_phase = hscPostBackendPhase HsSrcFile (backend dflags) @@ -133,7 +140,7 @@ let foreign_os = maybeToList stub_o return (foreign_os, output_fn) -runPhase (T_Cc phase pipe_env hsc_env input_fn) = runCcPhase phase pipe_env hsc_env input_fn +runPhase (T_Cc phase pipe_env hsc_env location input_fn) = runCcPhase phase pipe_env hsc_env location input_fn runPhase (T_As cpp pipe_env hsc_env location input_fn) = do runAsPhase cpp pipe_env hsc_env location input_fn runPhase (T_LlvmOpt pipe_env hsc_env input_fn) = @@ -209,6 +216,7 @@ -- -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa -- + llvm_config <- readLlvmConfigCache (hsc_llvm_config hsc_env) let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env llvmOpts = case llvmOptLevel dflags of @@ -217,7 +225,7 @@ _ -> "-O2" defaultOptions = map GHC.SysTools.Option . concatMap words . snd - $ unzip (llvmOptions dflags) + $ unzip (llvmOptions llvm_config dflags) optFlag = if null (getOpts dflags opt_lc) then map GHC.SysTools.Option $ words llvmOpts else [] @@ -243,16 +251,17 @@ runLlvmOptPhase pipe_env hsc_env input_fn = do let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env + llvm_config <- readLlvmConfigCache (hsc_llvm_config hsc_env) let -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate optIdx = max 0 $ min 2 $ llvmOptLevel dflags -- ensure we're in [0,2] - llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of + llvmOpts = case lookup optIdx $ llvmPasses llvm_config of Just passes -> passes Nothing -> panic ("runPhase LlvmOpt: llvm-passes file " ++ "is missing passes for level " ++ show optIdx) defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst - $ unzip (llvmOptions dflags) + $ unzip (llvmOptions llvm_config dflags) -- don't specify anything if user has specified commands. We do this -- for opt but not llc since opt is very specifically for optimisation @@ -284,13 +293,11 @@ -- 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) | backend dflags == LLVM - , platformOS platform == OSDarwin - = (GHC.SysTools.runClang, pure Clang) - | otherwise - = (GHC.SysTools.runAs, getAssemblerInfo logger dflags) - - asmInfo <- get_asm_info + 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 @@ -310,6 +317,7 @@ = withAtomicRename outputFilename $ \temp_outputFilename -> as_prog logger dflags + platform (local_includes ++ global_includes -- See Note [-fPIC for assembler] ++ map GHC.SysTools.Option pic_c_flags @@ -319,6 +327,10 @@ , not $ target32Bit (targetPlatform dflags) ] + -- See Note [-Wa,--no-type-check on wasm32] + ++ [ GHC.SysTools.Option "-Wa,--no-type-check" + | platformArch (targetPlatform dflags) == ArchWasm32] + ++ (if any (asmInfo ==) [Clang, AppleClang, AppleClang51] then [GHC.SysTools.Option "-Qunused-arguments"] else []) @@ -338,8 +350,87 @@ return output_fn -runCcPhase :: Phase -> PipeEnv -> HscEnv -> FilePath -> IO FilePath -runCcPhase cc_phase pipe_env hsc_env input_fn = do +-- Note [JS Backend .o file procedure] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The JS backend breaks some of the assumptions on file generation order +-- because it directly produces .o files. This violation breaks some of the +-- assumptions on file timestamps, particularly in the postHsc phase. The +-- postHsc phase for the JS backend is performed in 'runJsPhase'. Consider +-- what the NCG does: +-- +-- With other NCG backends we have the following order: +-- 1. The backend produces a .s file +-- 2. Then we write the interface file, .hi +-- 3. Then we generate a .o file in a postHsc phase (calling the asm phase etc.) +-- +-- For the JS Backend this order is different +-- 1. The JS Backend _directly_ produces .o files +-- 2. Then we write the interface file. Notice that this breaks the ordering +-- of .hi > .o (step 2 and step 3 in the NCG above). +-- +-- This violation results in timestamp checks which pass on the NCG but fail +-- in the JS backend. In particular, checks that compare 'ms_obj_date', and +-- 'ms_iface_date' in 'GHC.Unit.Module.ModSummary'. +-- +-- Thus to fix this ordering we touch the object files we generated earlier +-- to ensure these timestamps abide by the proper ordering. + +-- | 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 + + -- 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 + + return input_fn + +-- | Deal with foreign JS files (embed them into .o files) +runForeignJsPhase :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath +runForeignJsPhase pipe_env hsc_env _location input_fn = do + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env + let tmpfs = hsc_tmpfs hsc_env + let unit_env = hsc_unit_env hsc_env + + output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env Nothing + 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 @@ -402,10 +493,12 @@ | llvmOptLevel dflags >= 1 = [ "-O" ] | otherwise = [] - -- Decide next phase - let next_phase = As False - output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing + output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env location + -- we create directories for the object file, because it + -- might be a hierarchical module. + createDirectoryIfMissing True (takeDirectory output_fn) + let more_hcc_opts = -- on x86 the floating point regs have greater precision @@ -425,14 +518,22 @@ ghcVersionH <- getGhcVersionPathName dflags unit_env - GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags ( - [ GHC.SysTools.FileOption "" input_fn + withAtomicRename output_fn $ \temp_outputFilename -> + GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags ( + [ GHC.SysTools.Option "-c" + , GHC.SysTools.FileOption "" input_fn , GHC.SysTools.Option "-o" - , GHC.SysTools.FileOption "" output_fn + , GHC.SysTools.FileOption "" temp_outputFilename ] ++ map GHC.SysTools.Option ( pic_c_flags + -- See Note [Produce big objects on Windows] + ++ [ "-Wa,-mbig-obj" + | platformOS (targetPlatform dflags) == OSMinGW32 + , not $ target32Bit (targetPlatform dflags) + ] + -- 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 @@ -452,7 +553,6 @@ then gcc_extra_viac_flags ++ more_hcc_opts else []) ++ verbFlags - ++ [ "-S" ] ++ cc_opt ++ [ "-include", ghcVersionH ] ++ framework_paths @@ -470,7 +570,7 @@ -> HscSource -> ModLocation -> HscBackendAction - -> IO ([FilePath], ModIface, Maybe Linkable, FilePath) + -> IO ([FilePath], ModIface, HomeModLinkable, FilePath) runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env @@ -478,13 +578,13 @@ next_phase = hscPostBackendPhase src_flavour (backend dflags) case result of HscUpdate iface -> - if | NoBackend <- backend dflags -> + if | not (backendGeneratesCode (backend dflags)) -> panic "HscUpdate not relevant for NoBackend" - | Interpreter <- backend dflags -> do + | not (backendGeneratesCodeForHsBoot (backend dflags)) -> do -- In Interpreter way, there is just no linkable for hs-boot files -- and we don't want to write an empty `o-boot` file when we're not -- supposed to be writing any .o files (#22669) - return ([], iface, Nothing, o_file) + return ([], iface, emptyHomeModInfoLinkable, o_file) | otherwise -> do case src_flavour of HsigFile -> do @@ -499,47 +599,38 @@ HsBootFile -> touchObjectFile logger dflags o_file HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile" - -- MP: I wonder if there are any lurking bugs here because we - -- return Linkable == emptyHomeModInfoLinkable, despite the fact that there is a - -- linkable (.o-boot) which we check for in `Iface/Recomp.hs` and - -- then will carry around the linkable if we're doing - -- recompilation. - return ([], iface, Nothing, o_file) + -- MP: I wonder if there are any lurking bugs here because we + -- return Linkable == emptyHomeModInfoLinkable, despite the fact that there is a + -- linkable (.o-boot) which we check for in `Iface/Recomp.hs` and + -- then will carry around the linkable if we're doing + -- recompilation. + return ([], iface, emptyHomeModInfoLinkable, o_file) HscRecomp { hscs_guts = cgguts, hscs_mod_location = mod_location, hscs_partial_iface = partial_iface, hscs_old_iface_hash = mb_old_iface_hash } - -> case backend dflags of - NoBackend -> panic "HscRecomp not relevant for NoBackend" - Interpreter -> do - -- In interpreted mode the regular codeGen backend is not run so we - -- generate a interface without codeGen info. - final_iface <- mkFullIface hsc_env partial_iface Nothing Nothing - hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location - - (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location - - stub_o <- case hasStub of - Nothing -> return [] - Just stub_c -> do - stub_o <- compileStub hsc_env stub_c - return [DotO stub_o] - - let hs_unlinked = [BCOs comp_bc spt_entries] - unlinked_time <- getCurrentTime - let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) - (hs_unlinked ++ stub_o) - return ([], final_iface, Just linkable, panic "interpreter") - _ -> do + -> if not (backendGeneratesCode (backend dflags)) then + panic "HscRecomp not relevant for NoBackend" + else if backendWritesFiles (backend dflags) then + do output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location) - (outputFilename, mStub, foreign_files, mb_stg_infos, mb_cg_infos) <- + (outputFilename, mStub, foreign_files, stg_infos, cg_infos) <- + hscGenHardCode hsc_env cgguts mod_location output_fn - final_iface <- mkFullIface hsc_env partial_iface mb_stg_infos mb_cg_infos + final_iface <- mkFullIface hsc_env partial_iface stg_infos cg_infos -- 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 + 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 @@ -549,17 +640,26 @@ -- 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 -- is in TPipeline and in this branch we can invoke the rest of the backend phase. - return (fos, final_iface, Nothing, outputFilename) + return (fos, final_iface, mlinkable, outputFilename) + else + -- 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 + 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") + runUnlitPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath runUnlitPhase hsc_env input_fn output_fn = do let -- escape the characters \, ", and ', but don't try to escape -- Unicode or anything else (so we don't use Util.charToC -- here). If we get this wrong, then in - -- GHC.HsToCore.Coverage.isGoodTickSrcSpan where we check that the filename in - -- a SrcLoc is the same as the source filenaame, the two will + -- 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 escape ('\\':cs) = '\\':'\\': escape cs @@ -599,7 +699,10 @@ (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (hsc_unit_env hsc_env) - True{-raw-} + (CppOpts + { cppUseCc = False + , cppLinePragmas = True + }) input_fn output_fn return output_fn @@ -621,9 +724,11 @@ new_includes = addImplicitQuoteInclude paths [current_dir] paths = includePaths dflags0 dflags = dflags0 { includePaths = new_includes } - hsc_env = hscSetFlags dflags hsc_env0 - + hsc_env1 = hscSetFlags dflags hsc_env0 + -- Initialise plugins as the flags passed into runHscPhase might have local plugins just + -- specific to this module. + hsc_env <- initializePlugins hsc_env1 -- gather the imports and module name (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do @@ -683,18 +788,17 @@ -- run the compiler! let msg :: Messager msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what - plugin_hsc_env' <- initializePlugins hsc_env -- Need to set the knot-tying mutable variable for interface -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var. -- See also Note [hsc_type_env_var hack] type_env_var <- newIORef emptyNameEnv - let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } + let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } - status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary - Nothing Nothing (1, 1) + status <- hscRecompStatus (Just msg) hsc_env' mod_summary + Nothing emptyHomeModInfoLinkable (1, 1) - return (plugin_hsc_env, mod_summary, status) + return (hsc_env', mod_summary, status) -- | Calculate the ModLocation from the provided DynFlags. This function is only used -- in one-shot mode and therefore takes into account the effect of -o/-ohi flags @@ -813,7 +917,7 @@ | StopLn <- next_phase, Just loc <- maybe_location = return $ if dynamicNow dflags then ml_dyn_obj_file loc else ml_obj_file loc - -- 2. If output style is persistant then + -- 2. If output style is persistent then | is_last_phase, Persistent <- output = persistent_fn -- 3. Specific file is only set when outputFile is set by -o -- If we are in dynamic mode but -dyno is not set then write to the same path as @@ -835,9 +939,11 @@ | otherwise = newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule suffix where - getOutputFile_ dflags = case outputFile_ dflags of - Nothing -> pprPanic "SpecificFile: No filename" (ppr $ (dynamicNow dflags, outputFile_ dflags, dynOutputFile_ dflags)) - Just fn -> fn + getOutputFile_ dflags = + case outputFile_ dflags of + Nothing -> pprPanic "SpecificFile: No filename" (ppr (dynamicNow dflags) $$ + text (fromMaybe "-" (dynOutputFile_ dflags))) + Just fn -> fn hcsuf = hcSuf dflags odir = objectDir dflags @@ -879,9 +985,10 @@ -- | LLVM Options. These are flags to be passed to opt and llc, to ensure -- consistency we list them in pairs, so that they form groups. -llvmOptions :: DynFlags +llvmOptions :: LlvmConfig + -> DynFlags -> [(String, String)] -- ^ pairs of (opt, llc) arguments -llvmOptions dflags = +llvmOptions llvm_config dflags = [("-enable-tbaa -tbaa", "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ] ++ [("-relocation-model=" ++ rmodel ,"-relocation-model=" ++ rmodel) | not (null rmodel)] @@ -895,7 +1002,7 @@ ++ [("", "-target-abi=" ++ abi) | not (null abi) ] where target = platformMisc_llvmTarget $ platformMisc dflags - Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags) + Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets llvm_config) -- Relocation models rmodel | gopt Opt_PIC dflags = "pic" @@ -927,156 +1034,14 @@ abi :: String abi = case platformArch (targetPlatform dflags) of ArchRISCV64 -> "lp64d" + ArchLoongArch64 -> "lp64d" _ -> "" - --- Note [Filepaths and Multiple Home Units] -offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs -offsetIncludePaths dflags (IncludeSpecs incs quotes impl) = - let go = map (augmentByWorkingDirectory dflags) - in IncludeSpecs (go incs) (go quotes) (go impl) --- ----------------------------------------------------------------------------- --- Running CPP - --- | Run CPP --- --- UnitEnv is needed to compute MIN_VERSION macros -doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO () -doCpp logger tmpfs dflags unit_env raw 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 - pkg_include_dirs <- mayThrowUnitErr - (collectIncludeDirs <$> preloadUnitsInfo unit_env) - -- MP: This is not quite right, the headers which are supposed to be installed in - -- the package might not be the same as the provided include paths, but it's a close - -- enough approximation for things to work. A proper solution would be to have to declare which paths should - -- be propagated to dependent packages. - let home_pkg_deps = - [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) [] - (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs - ++ concatMap includePathsGlobal dep_pkg_extra_inputs) - let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] - (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 | raw = GHC.SysTools.runCpp logger dflags args - | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags - (GHC.SysTools.Option "-E" : args) - - let platform = targetPlatform dflags - targetArch = stringEncodeArch $ platformArch platform - targetOS = stringEncodeOS $ platformOS platform - isWindows = platformOS platform == OSMinGW32 - let target_defs = - [ "-D" ++ HOST_OS ++ "_BUILD_OS", - "-D" ++ HOST_ARCH ++ "_BUILD_ARCH", - "-D" ++ targetOS ++ "_HOST_OS", - "-D" ++ targetArch ++ "_HOST_ARCH" ] - -- remember, in code we *compile*, the HOST is the same our TARGET, - -- and BUILD is the same as our HOST. - - let io_manager_defs = - [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++ - [ "-D__IO_MANAGER_MIO__=1" ] - - let sse_defs = - [ "-D__SSE__" | isSseEnabled platform ] ++ - [ "-D__SSE2__" | isSse2Enabled platform ] ++ - [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] - - let avx_defs = - [ "-D__AVX__" | isAvxEnabled dflags ] ++ - [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ - [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ - [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ - [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ - [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] - - backend_defs <- getBackendDefs logger dflags - - let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] - -- Default CPP defines in Haskell source - ghcVersionH <- getGhcVersionPathName dflags unit_env - let hsSourceCppOpts = [ "-include", ghcVersionH ] - - -- MIN_VERSION macros - let uids = explicitUnits unit_state - pkgs = mapMaybe (lookupUnit unit_state . fst) uids - mb_macro_include <- - if not (null pkgs) && gopt Opt_VersionMacros dflags - then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h" - writeFile macro_stub (generatePackageVersionMacros pkgs) - -- Include version macros for every *exposed* package. - -- Without -hide-all-packages and with a package database - -- size of 1000 packages, it takes cpp an estimated 2 - -- milliseconds to process this file. See #10970 - -- comment 8. - return [GHC.SysTools.FileOption "-include" macro_stub] - else return [] - - cpp_prog ( map GHC.SysTools.Option verbFlags - ++ map GHC.SysTools.Option include_paths - ++ map GHC.SysTools.Option hsSourceCppOpts - ++ map GHC.SysTools.Option target_defs - ++ map GHC.SysTools.Option backend_defs - ++ map GHC.SysTools.Option th_defs - ++ map GHC.SysTools.Option hscpp_opts - ++ map GHC.SysTools.Option sse_defs - ++ map GHC.SysTools.Option avx_defs - ++ map GHC.SysTools.Option io_manager_defs - ++ mb_macro_include - -- Set the language mode to assembler-with-cpp when preprocessing. This - -- alleviates some of the C99 macro rules relating to whitespace and the hash - -- operator, which we tend to abuse. Clang in particular is not very happy - -- about this. - ++ [ GHC.SysTools.Option "-x" - , GHC.SysTools.Option "assembler-with-cpp" - , GHC.SysTools.Option input_fn - -- We hackily use Option instead of FileOption here, so that the file - -- name is not back-slashed on Windows. cpp is capable of - -- dealing with / in filenames, so it works fine. Furthermore - -- if we put in backslashes, cpp outputs #line directives - -- with *double* backslashes. And that in turn means that - -- our error messages get double backslashes in them. - -- In due course we should arrange that the lexer deals - -- with these \\ escapes properly. - , GHC.SysTools.Option "-o" - , GHC.SysTools.FileOption "" output_fn - ]) - -getBackendDefs :: Logger -> DynFlags -> IO [String] -getBackendDefs logger dflags | backend dflags == LLVM = do - llvmVer <- figureLlvmVersion logger dflags - return $ case fmap llvmVersionList llvmVer of - Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] - Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] - _ -> [] - where - format (major, minor) - | minor >= 100 = error "getBackendDefs: Unsupported minor version" - | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int - -getBackendDefs _ _ = - return [] - -- | 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 = - case bcknd of - ViaC -> HCc - NCG -> As False - LLVM -> LlvmOpt - NoBackend -> StopLn - Interpreter -> StopLn +hscPostBackendPhase _ bcknd = backendNormalSuccessorPhase bcknd compileStub :: HscEnv -> FilePath -> IO FilePath @@ -1117,7 +1082,7 @@ Note [Object merging] ~~~~~~~~~~~~~~~~~~~~~ On most platforms one can "merge" a set of relocatable object files into a new, -partiall-linked-but-still-relocatable object. In a typical UNIX-style linker, +partially-linked-but-still-relocatable object. In a typical UNIX-style linker, this is accomplished with the `ld -r` command. We rely on this for two ends: * We rely on `ld -r` to squash together split sections, making GHCi loading @@ -1161,21 +1126,14 @@ -- | See Note [Object merging]. joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO () joinObjectFiles hsc_env o_files output_fn - | can_merge_objs = do + | can_merge_objs && not dashLSupported = do let toolSettings' = toolSettings dflags ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) ( - map GHC.SysTools.Option ld_build_id - ++ [ GHC.SysTools.Option "-o", + [ GHC.SysTools.Option "-o", GHC.SysTools.FileOption "" output_fn ] ++ args) - -- suppress the generation of the .note.gnu.build-id section, - -- which we don't need and sometimes causes ld to emit a - -- warning: - ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"] - | otherwise = [] - if ldIsGnuLd then do script <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "ldscript" @@ -1229,36 +1187,6 @@ --- --------------------------------------------------------------------------- --- Macros (cribbed from Cabal) - -generatePackageVersionMacros :: [UnitInfo] -> String -generatePackageVersionMacros pkgs = concat - -- Do not add any C-style comments. See #3389. - [ generateMacros "" pkgname version - | pkg <- pkgs - , let version = unitPackageVersion pkg - pkgname = map fixchar (unitPackageNameString pkg) - ] - -fixchar :: Char -> Char -fixchar '-' = '_' -fixchar c = c - -generateMacros :: String -> String -> Version -> String -generateMacros prefix name version = - concat - ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" - ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" - ," (major1) < ",major1," || \\\n" - ," (major1) == ",major1," && (major2) < ",major2," || \\\n" - ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" - ,"\n\n" - ] - where - (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) - - -- ----------------------------------------------------------------------------- -- Misc. @@ -1269,22 +1197,6 @@ createDirectoryIfMissing True $ takeDirectory path GHC.SysTools.touch logger dflags "Touching object file" path --- | Find out path to @ghcversion.h@ file -getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath -getGhcVersionPathName dflags unit_env = do - candidates <- case ghcVersionFile dflags of - Just path -> return [path] - Nothing -> do - ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId]) - return (( "ghcversion.h") <$> collectIncludeDirs ps) - - found <- filterM doesFileExist candidates - case found of - [] -> throwGhcExceptionIO (InstallationError - ("ghcversion.h missing; tried: " - ++ intercalate ", " candidates)) - (x:_) -> return x - -- Note [-fPIC for assembler] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ -- When compiling .c source file GHC's driver pipeline basically @@ -1353,9 +1265,9 @@ 4) -fhpc At some point during compilation with -fhpc, in the function - `GHC.HsToCore.Coverage.isGoodTickSrcSpan`, we compare the filename that a + `GHC.HsToCore.Ticks.isGoodTickSrcSpan`, we compare the filename that a `SrcSpan` refers to with the name of the file we are currently compiling. - For some reason I don't yet understand, they can sometimes legitimally be + For some reason I don't yet understand, they can sometimes legitimately be different, and then hpc ignores that SrcSpan. Problem @@ -1382,4 +1294,31 @@ that commit was addressing has since been solved in a different manner, in a commit called "Fix the filename passed to unlit" (1eedbc6b). So the `normalise` is no longer necessary. +-} + +{- +Note [-Wa,--no-type-check on wasm32] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Wasm32 has a type system and corresponding validation rules, so it's +possible to produce syntactically valid object code that doesn't pass +validation. + +We have no problem with that, but we do have a problem with clang. +When clang takes an assembly input for wasm32, it uses its internal +type-checker, which is a huge source of trouble (see llvm ticket +#56935 #58438): it may reject valid assembly, and even worse, it may +silently alter the output object code!!! The worsest of all, is the +person that added the wasm32 asm typechecker logic has moved on from +Google/LLVM, and while other LLVM devs may be knowledgable enough to +fix this mess, they likely got tons of other stuff on their table and +don't care enough. + +We do have an escape hatch, just pass -Wa,--no-type-check to clang to +bypass the entire wasm32 asm typechecking logic. There's little point +in type-checking object code at compile-time anyway, the wasm engines +will do type-checking at run-time. And even if we want to add some +linting flag to do compile-time checks, we should just rely on +battle-tested external tools instead of a completely broken horror +story. -} 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 @@ -16,11 +16,12 @@ import GHC.Driver.Errors.Types import GHC.Fingerprint.Type import GHC.Unit.Module.Location ( ModLocation ) -import GHC.Unit.Module.Name ( ModuleName ) import GHC.Unit.Module.ModIface -import GHC.Linker.Types import GHC.Driver.Phases +import Language.Haskell.Syntax.Module.Name ( ModuleName ) +import GHC.Unit.Home.ModInfo + -- Typed Pipeline Phases -- MP: TODO: We need to refine the arguments to each of these phases so recompilation -- can be smarter. For example, rather than passing a whole HscEnv, just pass the options @@ -38,11 +39,13 @@ -> Messages GhcMessage -> Maybe Fingerprint -> TPhase HscBackendAction - T_HscBackend :: PipeEnv -> HscEnv -> ModuleName -> HscSource -> ModLocation -> HscBackendAction -> TPhase ([FilePath], ModIface, Maybe Linkable, FilePath) + T_HscBackend :: PipeEnv -> HscEnv -> ModuleName -> HscSource -> ModLocation -> HscBackendAction -> TPhase ([FilePath], ModIface, HomeModLinkable, FilePath) T_CmmCpp :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_Cmm :: PipeEnv -> HscEnv -> FilePath -> TPhase ([FilePath], FilePath) - T_Cc :: Phase -> PipeEnv -> HscEnv -> FilePath -> TPhase FilePath + T_Cc :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath T_As :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath + T_Js :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath + T_ForeignJs :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath T_LlvmOpt :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_LlvmLlc :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_LlvmMangle :: PipeEnv -> HscEnv -> 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 @@ -1,6 +1,13 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +#if defined(HAVE_INTERNAL_INTERPRETER) && defined(CAN_LOAD_DLL) +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE UnboxedTuples #-} +#endif + -- | Definitions for writing /plugins/ for GHC. Plugins can hook into -- several areas of the compiler. See the 'Plugin' type. These plugins -- include type-checker plugins, source plugins, and core-to-core plugins. @@ -14,6 +21,10 @@ , CommandLineOption , PsMessages(..) , ParsedResult(..) + + -- * External plugins + , loadExternalPlugins + -- ** Recompilation checking , purePlugin, impurePlugin, flagRecompile , PluginRecompile(..) @@ -52,6 +63,7 @@ , PluginWithArgs(..), pluginsWithArgs, pluginRecompile' , LoadedPlugin(..), lpModuleName , StaticPlugin(..) + , ExternalPlugin(..) , mapPlugins, withPlugins, withPlugins_ ) where @@ -60,6 +72,7 @@ import GHC.Driver.Env import GHC.Driver.Monad import GHC.Driver.Phases +import GHC.Driver.Plugins.External import GHC.Unit.Module import GHC.Unit.Module.ModIface @@ -71,11 +84,16 @@ import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR ) -import GHC.Core.Opt.Monad ( CoreToDo, CoreM ) +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.Unique.DFM + import GHC.Utils.Fingerprint -import GHC.Utils.Outputable (Outputable(..), text, (<+>)) +import GHC.Utils.Outputable +import GHC.Utils.Panic import Data.List (sort) @@ -84,9 +102,14 @@ import qualified Data.Semigroup import Control.Monad -import GHC.Linker.Types -import GHC.Types.Unique.DFM +#if defined(HAVE_INTERNAL_INTERPRETER) && defined(CAN_LOAD_DLL) +import GHCi.ObjLink +import GHC.Exts (addrToAny#, Ptr(..)) +import GHC.Utils.Encoding +#endif + + -- | Command line options gathered from the -PModule.Name:stuff syntax -- are given to you as this type type CommandLineOption = String @@ -195,6 +218,14 @@ -- ^ the module containing the plugin } +-- | External plugin loaded directly from a library without loading module +-- interfaces +data ExternalPlugin = ExternalPlugin + { epPlugin :: PluginWithArgs -- ^ Plugin with its arguments + , epUnit :: String -- ^ UnitId + , epModule :: String -- ^ Module name + } + -- | A static plugin with its arguments. For registering compiled-in plugins -- through the GHC API. data StaticPlugin = StaticPlugin @@ -284,6 +315,10 @@ -- To add dynamically loaded plugins through the GHC API see -- 'addPluginModuleName' instead. + , externalPlugins :: ![ExternalPlugin] + -- ^ External plugins loaded directly from libraries without loading + -- module interfaces. + , loadedPlugins :: ![LoadedPlugin] -- ^ Plugins dynamically loaded after processing arguments. What -- will be loaded here is directed by DynFlags.pluginModNames. @@ -298,12 +333,17 @@ } emptyPlugins :: Plugins -emptyPlugins = Plugins [] [] ([], emptyUDFM) - +emptyPlugins = Plugins + { staticPlugins = [] + , externalPlugins = [] + , loadedPlugins = [] + , loadedPluginDeps = ([], emptyUDFM) + } pluginsWithArgs :: Plugins -> [PluginWithArgs] pluginsWithArgs plugins = map lpPlugin (loadedPlugins plugins) ++ + map epPlugin (externalPlugins plugins) ++ map spPlugin (staticPlugins plugins) -- | Perform an operation by using all of the plugins in turn. @@ -327,3 +367,53 @@ } defaultFrontendPlugin :: FrontendPlugin defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () } + + +-- | Load external plugins +loadExternalPlugins :: [ExternalPluginSpec] -> IO [ExternalPlugin] +loadExternalPlugins [] = return [] +#if !defined(HAVE_INTERNAL_INTERPRETER) +loadExternalPlugins _ = do + panic "loadExternalPlugins: can't load external plugins with GHC built without internal interpreter" +#elif !defined(CAN_LOAD_DLL) +loadExternalPlugins _ = do + panic "loadExternalPlugins: loading shared libraries isn't supported by this compiler" +#else +loadExternalPlugins ps = do + -- initialize the linker + initObjLinker RetainCAFs + -- load plugins + forM ps $ \(ExternalPluginSpec path unit mod_name opts) -> do + loadExternalPluginLib path + -- lookup symbol + let ztmp = zEncodeString mod_name ++ "_plugin_closure" + symbol + | null unit = ztmp + | otherwise = zEncodeString unit ++ "_" ++ ztmp + plugin <- lookupSymbol symbol >>= \case + Nothing -> pprPanic "loadExternalPlugins" + (vcat [ text "Symbol not found" + , text " Library path: " <> text path + , text " Symbol : " <> text symbol + ]) + Just (Ptr addr) -> case addrToAny# addr of + (# a #) -> pure a + + pure $ ExternalPlugin (PluginWithArgs plugin opts) unit mod_name + +loadExternalPluginLib :: FilePath -> IO () +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 + -- resolve objects + resolveObjs >>= \case + True -> return () + False -> pprPanic "loadExternalPluginLib" (text "Unable to resolve objects for library: " <> text path) + +#endif diff --git a/GHC/Driver/Plugins/External.hs b/GHC/Driver/Plugins/External.hs new file mode 100644 --- /dev/null +++ b/GHC/Driver/Plugins/External.hs @@ -0,0 +1,79 @@ +-- | External plugins +-- +-- GHC supports two kinds of "static" plugins: +-- 1. internal: setup with GHC-API +-- 2. external: setup as explained below and loaded from shared libraries +-- +-- The intended use case for external static plugins is with cross compilers: at +-- the time of writing, GHC is mono-target and a GHC cross-compiler (i.e. when +-- host /= target) can't build nor load plugins for the host using the +-- "non-static" plugin approach. Fixing this is tracked in #14335. If you're not +-- using a cross-compiler, you'd better use non-static plugins which are easier +-- to build and and safer to use (see below). +-- +-- External static plugins can be configured via the command-line with +-- the -fplugin-library flag. Syntax is: +-- +-- -fplugin-library=⟨file-path⟩;⟨unit-id⟩;⟨module⟩;⟨args⟩ +-- +-- Example: +-- -fplugin-library=path/to/plugin;package-123;Plugin.Module;["Argument","List"] +-- +-- Building the plugin library: +-- 1. link with the libraries used to build the compiler you target. If you +-- target a cross-compiler (stage2), you can't directly use it to build the +-- plugin library. Use the stage1 compiler instead. +-- +-- 2. if you use cabal to build the library, its unit-id will be set by cabal +-- and will contain a hash (e.g. "my-plugin-unit-1345656546ABCDEF"). To force +-- the unit id, use GHC's `-this-unit-id` command line flag: +-- e.g. -this-unit-id my-plugin-unit +-- You can set this in the .cabal file of your library with the following +-- stanza: `ghc-options: -this-unit-id my-plugin-unit` +-- +-- 3. To make your plugin easier to distribute, you may want to link it +-- statically with all its dependencies. You would need to use `-shared` +-- without `-dynamic` when building your library. +-- +-- However, all the static dependencies have to be built with `-fPIC` and it's +-- not done by default. See +-- https://www.hobson.space/posts/haskell-foreign-library/ for a way to modify +-- the compiler to do it. +-- +-- In any case, don't link your plugin library statically with the RTS (e.g. +-- use `-fno-link-rts`) as there are some global variables in the RTS that must +-- be shared between the plugin and the compiler. +-- +-- With external static plugins we don't check the type of the `plugin` closure +-- we look up. If it's not a valid `Plugin` value, it will probably crash badly. +-- + +module GHC.Driver.Plugins.External + ( ExternalPluginSpec (..) + , parseExternalPluginSpec + ) +where + +import GHC.Prelude +import Text.Read + +-- | External plugin spec +data ExternalPluginSpec = ExternalPluginSpec + { esp_lib :: !FilePath + , esp_unit_id :: !String + , esp_module :: !String + , esp_args :: ![String] + } + +-- | Parser external static plugin specification from command-line flag +parseExternalPluginSpec :: String -> Maybe ExternalPluginSpec +parseExternalPluginSpec optflag = + case break (== ';') optflag of + (libPath, _:rest) -> case break (== ';') rest of + (libName, _:pack) -> case break (== ';') pack of + (modName, _:args) -> case readMaybe args of + Just as -> Just (ExternalPluginSpec libPath libName modName as) + Nothing -> Nothing + _ -> Nothing + _ -> Nothing + _ -> Nothing diff --git a/GHC/Driver/Ppr.hs b/GHC/Driver/Ppr.hs --- a/GHC/Driver/Ppr.hs +++ b/GHC/Driver/Ppr.hs @@ -26,14 +26,14 @@ showPpr :: Outputable a => DynFlags -> a -> String showPpr dflags thing = showSDoc dflags (ppr thing) --- | Allows caller to specify the PrintUnqualified to use -showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String -showSDocForUser dflags unit_state unqual doc = renderWithContext (initSDocContext dflags sty) doc' +-- | Allows caller to specify the NamePprCtx to use +showSDocForUser :: DynFlags -> UnitState -> NamePprCtx -> SDoc -> String +showSDocForUser dflags unit_state name_ppr_ctx doc = renderWithContext (initSDocContext dflags sty) doc' where - sty = mkUserStyle unqual AllTheWay + sty = mkUserStyle name_ppr_ctx AllTheWay doc' = pprWithUnitState unit_state doc -printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO () -printForUser dflags handle unqual depth doc +printForUser :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO () +printForUser dflags handle name_ppr_ctx depth doc = printSDocLn ctx (PageMode False) handle doc - where ctx = initSDocContext dflags (mkUserStyle unqual depth) + where ctx = initSDocContext dflags (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 @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-} @@ -40,6 +41,7 @@ DynamicTooState(..), dynamicTooState, setDynamicNow, sccProfilingEnabled, needSourceNotes, + OnOff(..), DynFlags(..), outputFile, objectSuf, ways, FlagSpec(..), @@ -71,9 +73,6 @@ safeDirectImpsReq, safeImplicitImpsReq, unsafeFlags, unsafeFlagsForInfer, - -- ** LLVM Targets - LlvmTarget(..), LlvmConfig(..), - -- ** System tool settings and locations Settings(..), sProgramName, @@ -84,7 +83,6 @@ sTopDir, sGlobalPackageDatabasePath, sLdSupportsCompactUnwind, - sLdSupportsBuildId, sLdSupportsFilelist, sLdIsGnuLd, sGccSupportsNoPie, @@ -99,7 +97,6 @@ sPgm_dll, sPgm_T, sPgm_windres, - sPgm_libtool, sPgm_ar, sPgm_ranlib, sPgm_lo, @@ -133,7 +130,7 @@ 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_libtool, pgm_ar, pgm_otool, pgm_install_name_tool, + 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, @@ -217,6 +214,7 @@ -- * SDoc initSDocContext, initDefaultSDocContext, + initPromotionTickContext, ) where import GHC.Prelude @@ -233,6 +231,7 @@ 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 @@ -250,6 +249,7 @@ 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 @@ -418,7 +418,7 @@ 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 attemps and + 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. -} @@ -453,9 +453,6 @@ rawSettings :: [(String, String)], tmpDir :: TempDir, - llvmConfig :: LlvmConfig, - -- ^ N.B. It's important that this field is lazy since we load the LLVM - -- configuration lazily. See Note [LLVM configuration] in "GHC.SysTools". llvmOptLevel :: Int, -- ^ LLVM optimisation level verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] debugLevel :: Int, -- ^ How much debug information to produce @@ -596,6 +593,9 @@ -- ^ 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, @@ -739,6 +739,15 @@ 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 @@ -766,27 +775,8 @@ class ContainsDynFlags t where extractDynFlags :: t -> DynFlags -data ProfAuto - = NoProfAuto -- ^ no SCC annotations added - | ProfAutoAll -- ^ top-level and nested functions are annotated - | ProfAutoTop -- ^ top-level functions annotated only - | ProfAutoExports -- ^ exported functions annotated only - | ProfAutoCalls -- ^ annotate call-sites - deriving (Eq,Enum) - -data LlvmTarget = LlvmTarget - { lDataLayout :: String - , lCPU :: String - , lAttributes :: [String] - } - --- | See Note [LLVM configuration] in "GHC.SysTools". -data LlvmConfig = LlvmConfig { llvmTargets :: [(String, LlvmTarget)] - , llvmPasses :: [(Int, String)] - } - ----------------------------------------------------------------------------- --- Accessessors from '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 @@ -839,16 +829,10 @@ pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags pgm_windres :: DynFlags -> String pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags -pgm_libtool :: DynFlags -> String -pgm_libtool dflags = toolSettings_pgm_libtool $ 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_otool :: DynFlags -> String -pgm_otool dflags = toolSettings_pgm_otool $ toolSettings dflags -pgm_install_name_tool :: DynFlags -> String -pgm_install_name_tool dflags = toolSettings_pgm_install_name_tool $ toolSettings dflags pgm_ranlib :: DynFlags -> String pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags pgm_lo :: DynFlags -> (String,[Option]) @@ -1120,8 +1104,8 @@ -- | 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 -> LlvmConfig -> DynFlags -defaultDynFlags mySettings llvmConfig = +defaultDynFlags :: Settings -> DynFlags +defaultDynFlags mySettings = -- See Note [Updating flag description in the User's Guide] DynFlags { ghcMode = CompManager, @@ -1194,6 +1178,8 @@ pluginModNameOpts = [], frontendPluginOpts = [], + externalPluginSpecs = [], + outputFile_ = Nothing, dynOutputFile_ = Nothing, outputHi = Nothing, @@ -1230,8 +1216,6 @@ tmpDir = panic "defaultDynFlags: uninitialized tmpDir", - -- See Note [LLVM configuration]. - llvmConfig = llvmConfig, llvmOptLevel = 0, -- ghc -M values @@ -1450,36 +1434,7 @@ -- | Test whether a 'DumpFlag' is set dopt :: DumpFlag -> DynFlags -> Bool -dopt f dflags = (f `EnumSet.member` dumpFlags dflags) - || (verbosity dflags >= 4 && enableIfVerbose f) - where enableIfVerbose Opt_D_dump_tc_trace = False - enableIfVerbose Opt_D_dump_rn_trace = False - enableIfVerbose Opt_D_dump_cs_trace = False - enableIfVerbose Opt_D_dump_if_trace = False - enableIfVerbose Opt_D_dump_tc = False - enableIfVerbose Opt_D_dump_rn = False - enableIfVerbose Opt_D_dump_rn_stats = False - enableIfVerbose Opt_D_dump_hi_diffs = False - enableIfVerbose Opt_D_verbose_core2core = False - enableIfVerbose Opt_D_verbose_stg2stg = False - enableIfVerbose Opt_D_dump_splices = False - enableIfVerbose Opt_D_th_dec_file = False - enableIfVerbose Opt_D_dump_rule_firings = False - enableIfVerbose Opt_D_dump_rule_rewrites = False - enableIfVerbose Opt_D_dump_simpl_trace = False - enableIfVerbose Opt_D_dump_rtti = False - enableIfVerbose Opt_D_dump_inlinings = False - enableIfVerbose Opt_D_dump_verbose_inlinings = False - enableIfVerbose Opt_D_dump_core_stats = False - enableIfVerbose Opt_D_dump_asm_stats = False - enableIfVerbose Opt_D_dump_types = False - enableIfVerbose Opt_D_dump_simpl_iterations = False - enableIfVerbose Opt_D_dump_ticked = False - enableIfVerbose Opt_D_dump_view_pattern_commoning = False - enableIfVerbose Opt_D_dump_mod_cycles = False - enableIfVerbose Opt_D_dump_mod_map = False - enableIfVerbose Opt_D_dump_ec_trace = False - enableIfVerbose _ = True +dopt = getDumpFlagFrom verbosity dumpFlags -- | Set a 'DumpFlag' dopt_set :: DynFlags -> DumpFlag -> DynFlags @@ -1764,6 +1719,11 @@ [] -> "" -- 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 } @@ -1881,6 +1841,7 @@ 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) @@ -1890,9 +1851,6 @@ pure x = CmdLineP (pure x) (<*>) = ap -instance Functor (CmdLineP s) where - fmap f (CmdLineP k) = CmdLineP (fmap f k) - getCmdLineState :: CmdLineP s s getCmdLineState = CmdLineP State.get @@ -1994,8 +1952,9 @@ "-fpackage-trust ignored;" ++ " must be specified with a Safe Haskell flag"] - -- Have we inferred Unsafe? See Note [GHC.Driver.Main . Safe Haskell Inference] - safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer + -- 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 {- ********************************************************************** @@ -2193,8 +2152,6 @@ $ 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 "pgmlibtool" - $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_libtool = f } , make_ord_flag defFlag "pgmar" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f } , make_ord_flag defFlag "pgmotool" @@ -2235,14 +2192,10 @@ , 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" - (noArgM (\dflags -> do - if platformHasSubsectionsViaSymbols (targetPlatform dflags) - then do addWarn $ - "-split-sections is not useful on this platform " ++ - "since it always uses subsections via symbols. Ignoring." - return dflags - else return (gopt_set dflags Opt_SplitSections))) + (NoArg $ setGeneralFlag Opt_SplitSections) -------- ghc -M ----------------------------------------------------- , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) @@ -2316,9 +2269,9 @@ , make_ord_flag defGhcFlag "keep-s-files" (NoArg (setGeneralFlag Opt_KeepSFiles)) , make_ord_flag defGhcFlag "keep-llvm-file" - (NoArg $ setObjBackend LLVM >> setGeneralFlag Opt_KeepLlvmFiles) + (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles) , make_ord_flag defGhcFlag "keep-llvm-files" - (NoArg $ setObjBackend LLVM >> setGeneralFlag Opt_KeepLlvmFiles) + (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles) -- This only makes sense as plural , make_ord_flag defGhcFlag "keep-tmp-files" (NoArg (setGeneralFlag Opt_KeepTmpFiles)) @@ -2422,7 +2375,7 @@ , make_ord_flag defFlag "fdiagnostics-color=never" (NoArg (upd (\d -> d { useColor = Never }))) - -- Suppress all that is suppressable in core dumps. + -- 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" @@ -2477,12 +2430,16 @@ (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" @@ -2746,6 +2703,8 @@ , 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" @@ -2927,24 +2886,25 @@ (NoArg (setGeneralFlag Opt_InfoTableMap)) ------ Compiler flags ----------------------------------------------- - , make_ord_flag defGhcFlag "fasm" (NoArg (setObjBackend NCG)) + , 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 LLVM)) + , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjBackend llvmBackend)) , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> - d { ghcLink=NoLink }) >> setBackend NoBackend)) + d { ghcLink=NoLink }) >> setBackend noBackend)) , make_ord_flag defFlag "fbyte-code" (noArgM $ \dflags -> do - setBackend Interpreter - pure $ gopt_set dflags Opt_ByteCode) - , make_ord_flag defFlag "fobject-code" $ NoArg $ do - dflags <- liftEwM getCmdLineState + 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" @@ -3217,6 +3177,17 @@ 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" @@ -3416,6 +3387,9 @@ 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" @@ -3440,6 +3414,8 @@ 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, @@ -3479,6 +3455,7 @@ 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, @@ -3504,12 +3481,13 @@ 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, + 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, @@ -3524,12 +3502,16 @@ 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)) - + return dflags)), + flagSpec "show-error-context" Opt_ShowErrorContext, + flagSpec "cmm-thread-sanitizer" Opt_CmmThreadSanitizer, + flagSpec "split-sections" Opt_SplitSections ] ++ fHoleFlags @@ -3784,7 +3766,9 @@ flagSpec "TransformListComp" LangExt.TransformListComp, flagSpec "TupleSections" LangExt.TupleSections, flagSpec "TypeApplications" LangExt.TypeApplications, - flagSpec "TypeInType" LangExt.TypeInType, + flagSpec "TypeData" LangExt.TypeData, + depFlagSpec' "TypeInType" LangExt.TypeInType + (deprecatedForExtensions ["DataKinds", "PolyKinds"]), flagSpec "TypeFamilies" LangExt.TypeFamilies, flagSpec "TypeOperators" LangExt.TypeOperators, flagSpec "TypeSynonymInstances" LangExt.TypeSynonymInstances, @@ -3819,17 +3803,24 @@ 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 @@ -3888,6 +3879,8 @@ ,(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) ] ++ validHoleFitsImpliedGFlags -- General flags that are switched on/off when other general flags are switched @@ -4448,7 +4441,7 @@ -- code are allowed (requests for other target types are ignored). setBackend :: Backend -> DynP () setBackend l = upd $ \ dfs -> - if ghcLink dfs /= LinkBinary || backendProducesObject l + if ghcLink dfs /= LinkBinary || backendWritesFiles l then dfs{ backend = l } else dfs @@ -4460,7 +4453,7 @@ setObjBackend l = updM set where set dflags - | backendProducesObject (backend dflags) + | backendWritesFiles (backend dflags) = return $ dflags { backend = l } | otherwise = return dflags @@ -4475,12 +4468,11 @@ setMainIs :: String -> DynP () setMainIs arg - | not (null main_fn) && isLower (head main_fn) - -- The arg looked like "Foo.Bar.baz" + | x:_ <- main_fn, isLower x -- The arg looked like "Foo.Bar.baz" = upd $ \d -> d { mainFunIs = Just main_fn, mainModuleNameIs = mkModuleName main_mod } - | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" + | x:_ <- arg, isUpper x -- The arg looked like "Foo" or "Foo.Bar" = upd $ \d -> d { mainModuleNameIs = mkModuleName arg } | otherwise -- The arg looked like "baz" @@ -4805,32 +4797,42 @@ 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. - | backend dflags == ViaC && + | backendUnregisterisedAbiOnly (backend dflags) && not (platformUnregisterised (targetPlatform dflags)) - = case platformDefaultBackend (targetPlatform dflags) of - NCG -> let dflags' = dflags { backend = NCG } - warn = "Target platform doesn't use unregisterised ABI, so using native code generator rather than compiling via C" - in loop dflags' warn - LLVM -> let dflags' = dflags { backend = LLVM } - warn = "Target platform doesn't use unregisterised ABI, so using LLVM rather than compiling via C" - in loop dflags' warn - _ -> pgmError "Compiling via C only supports unregisterised ABI but target platform doesn't use it." + = 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 && backend dflags == Interpreter + | gopt Opt_Hpc dflags && not (backendSupportsHpc (backend dflags)) = let dflags' = gopt_unset dflags Opt_Hpc - warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc." + warn = "Hpc can't be used with " ++ backendDescription (backend dflags) ++ + ". Ignoring -fhpc." in loop dflags' warn - | backend dflags `elem` [NCG, LLVM] && + | backendSwappableWithViaC (backend dflags) && platformUnregisterised (targetPlatform dflags) - = loop (dflags { backend = ViaC }) + = loop (dflags { backend = viaCBackend }) "Target platform uses unregisterised ABI, so compiling via C" - | backend dflags == NCG && + | backendNeedsPlatformNcgSupport (backend dflags) && not (platformNcgSupported $ targetPlatform dflags) - = let dflags' = dflags { backend = LLVM } + = let dflags' = dflags { backend = llvmBackend } warn = "Native code generator doesn't support target platform, so using LLVM" in loop dflags' warn @@ -4843,15 +4845,17 @@ = loop (gopt_set dflags Opt_PIC) "Enabling -fPIC as it is always on for this platform" - | backend dflags == Interpreter + | backendForcesOptimization0 (backend dflags) , let (dflags', changed) = updOptLevelChanged 0 dflags , changed - = loop dflags' "Optimization flags conflict with --interactive; optimization flags ignored." + = loop dflags' ("Optimization flags are incompatible with the " ++ + backendDescription (backend dflags) ++ + "; optimization flags ignored.") | LinkInMemory <- ghcLink dflags , not (gopt Opt_ExternalInterpreter dflags) , hostIsProfiled - , backendProducesObject (backend dflags) + , 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" @@ -4945,6 +4949,7 @@ | Clang | AppleClang | AppleClang51 + | Emscripten | UnknownCC deriving Eq @@ -5037,8 +5042,8 @@ , sdocSuppressStgReps = gopt Opt_SuppressStgReps dflags , sdocErrorSpans = gopt Opt_ErrorSpans dflags , sdocStarIsType = xopt LangExt.StarIsType dflags - , sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags , sdocLinearTypes = xopt LangExt.LinearTypes dflags + , sdocListTuplePuns = True , sdocPrintTypeAbbreviations = True , sdocUnitIdForUser = ftext } @@ -5046,6 +5051,13 @@ -- | 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 diff --git a/GHC/Hs.hs b/GHC/Hs.hs --- a/GHC/Hs.hs +++ b/GHC/Hs.hs @@ -9,6 +9,7 @@ therefore, is almost nothing but re-exporting. -} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} @@ -34,7 +35,7 @@ Fixity, HsModule(..), AnnsModule(..), - HsParsedModule(..) + HsParsedModule(..), XModulePs(..) ) where -- friends: @@ -58,53 +59,18 @@ import GHC.Utils.Outputable import GHC.Types.Fixity ( Fixity ) import GHC.Types.SrcLoc -import GHC.Unit.Module ( ModuleName ) import GHC.Unit.Module.Warnings ( WarningTxt ) -- libraries: import Data.Data hiding ( Fixity ) --- | Haskell Module --- --- All we actually declare here is the top-level structure for a module. -data HsModule - = -- | '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 { +-- | Haskell Module extension point: GHC specific +data XModulePs + = XModulePs { hsmodAnn :: EpAnn AnnsModule, - hsmodLayout :: LayoutInfo, + hsmodLayout :: LayoutInfo GhcPs, -- ^ Layout info for the module. -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo. - hsmodName :: Maybe (LocatedA ModuleName), - -- ^ @Nothing@: \"module X where\" is omitted (in which case the next - -- field is Nothing too) - hsmodExports :: Maybe (LocatedL [LIE GhcPs]), - -- ^ Export list - -- - -- - @Nothing@: export list omitted, so export everything - -- - -- - @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 GhcPs], - -- ^ We snaffle interesting stuff out of the imported interfaces early - -- on, adding that info to TyDecls/etc; so this list is often empty, - -- downstream. - hsmodDecls :: [LHsDecl GhcPs], - -- ^ Type, class, value, and interface signature decls hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs)), -- ^ reason\/explanation for warning/deprecation of this module -- @@ -121,29 +87,44 @@ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation } + deriving Data -deriving instance Data HsModule +type instance XCModule GhcPs = XModulePs +type instance XCModule GhcRn = DataConCantHappen +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 } deriving (Data, Eq) -instance Outputable HsModule where - - ppr (HsModule _ _ Nothing _ imports decls _ mbDoc) +instance Outputable (HsModule GhcPs) where + ppr (HsModule { hsmodExt = XModulePs { hsmodHaddockModHeader = mbDoc } + , hsmodName = Nothing + , hsmodImports = imports + , hsmodDecls = decls }) = pprMaybeWithDoc mbDoc $ pp_nonnull imports $$ pp_nonnull decls - ppr (HsModule _ _ (Just name) exports imports decls deprec mbDoc) + ppr (HsModule { hsmodExt = XModulePs { hsmodDeprecMessage = deprec + , hsmodHaddockModHeader = mbDoc } + , hsmodName = (Just name) + , hsmodExports = exports + , hsmodImports = imports + , hsmodDecls = decls }) = pprMaybeWithDoc mbDoc $ vcat [ case exports of Nothing -> pp_header (text "where") Just es -> vcat [ pp_header lparen, - nest 8 (fsep (punctuate comma (map ppr (unLoc es)))), + nest 8 (pprWithCommas ppr (unLoc es)), nest 4 (text ") where") ], pp_nonnull imports, @@ -161,7 +142,7 @@ pp_nonnull xs = vcat (map ppr xs) data HsParsedModule = HsParsedModule { - hpm_module :: Located HsModule, + hpm_module :: Located (HsModule GhcPs), hpm_src_files :: [FilePath] -- ^ extra source files (e.g. from #includes). The lexer collects -- these from '# ' pragmas, which the C preprocessor diff --git a/GHC/Hs/Binds.hs b/GHC/Hs/Binds.hs --- a/GHC/Hs/Binds.hs +++ b/GHC/Hs/Binds.hs @@ -28,12 +28,13 @@ import GHC.Prelude +import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Binds import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprFunBind, pprPatBind ) import {-# SOURCE #-} GHC.Hs.Pat (pprLPat ) -import Language.Haskell.Syntax.Extension +import GHC.Types.Tickish import GHC.Hs.Extension import GHC.Parser.Annotation import GHC.Hs.Type @@ -66,7 +67,7 @@ Global bindings (where clauses) -} --- the ...LR datatypes are parametrized by two id types, +-- 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 @@ -95,9 +96,10 @@ -- extension field contains the locally-bound free variables of this -- defn. See Note [Bind free vars] -type instance XFunBind (GhcPass pL) GhcTc = HsWrapper --- ^ After the type-checker, the FunBind extension field contains a --- coercion from the type of the MatchGroup to the type of the Id. +type instance XFunBind (GhcPass pL) GhcTc = (HsWrapper, [CoreTickish]) +-- ^ After the type-checker, the FunBind extension field contains +-- the ticks to put on the rhs, if any, and a coercion from the +-- type of the MatchGroup to the type of the Id. -- Example: -- -- @ @@ -113,7 +115,10 @@ type instance XPatBind GhcPs (GhcPass pR) = EpAnn [AddEpAnn] type instance XPatBind GhcRn (GhcPass pR) = NameSet -- See Note [Bind free vars] -type instance XPatBind GhcTc (GhcPass pR) = Type -- Type of the GRHSs +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 XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField @@ -512,14 +517,27 @@ = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] ppr_monobind (FunBind { fun_id = fun, fun_matches = matches, - fun_tick = ticks, - fun_ext = wrap }) - = pprTicks empty (if null ticks then empty - else text "-- ticks = " <> ppr ticks) + fun_ext = ext }) + = pprTicks empty ticksDoc $$ whenPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind matches - $$ whenPprDebug (pprIfTc @idR $ ppr wrap) + $$ whenPprDebug (pprIfTc @idR $ wrapDoc) + where + ticksDoc :: SDoc + ticksDoc = case ghcPass @idR of + GhcPs -> empty + GhcRn -> empty + GhcTc | (_, ticks) <- ext -> + if null ticks + then empty + else text "-- ticks = " <> ppr ticks + wrapDoc :: SDoc + wrapDoc = case ghcPass @idR of + GhcPs -> empty + GhcRn -> empty + GhcTc | (wrap, _) <- ext -> ppr wrap + ppr_monobind (PatSynBind _ psb) = ppr psb ppr_monobind (XHsBindsLR b) = case ghcPass @idL of #if __GLASGOW_HASKELL__ <= 900 @@ -600,6 +618,10 @@ then pp_when_debug else pp_no_debug +instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where + ppr (RecordPatSynField { recordPatSynField = v }) = ppr v + + {- ************************************************************************ * * @@ -651,20 +673,28 @@ type instance XTypeSig (GhcPass p) = EpAnn AnnSig type instance XPatSynSig (GhcPass p) = EpAnn AnnSig type instance XClassOpSig (GhcPass p) = EpAnn AnnSig -type instance XIdSig (GhcPass p) = NoExtField -- No anns, generated 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] -type instance XMinimalSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XSCCFunSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XCompleteMatchSig (GhcPass p) = EpAnn [AddEpAnn] - -type instance XXSig (GhcPass p) = DataConCantHappen +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 XXSig GhcPs = DataConCantHappen +type instance XXSig GhcRn = IdSig +type instance XXSig GhcTc = IdSig type instance XFixitySig (GhcPass p) = NoExtField type instance XXFixitySig (GhcPass p) = DataConCantHappen +-- | 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 +-- just like a type signature: there should be an accompanying binding +newtype IdSig = IdSig { unIdSig :: Id } + deriving Data + data AnnSig = AnnSig { asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option @@ -714,7 +744,6 @@ ppr_sig (ClassOpSig _ is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | otherwise = pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) 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) @@ -724,22 +753,25 @@ NoUserInlinePrag -> "{-# " ++ extractSpecPragName (inl_src inl) _ -> "{-# " ++ extractSpecPragName (inl_src inl) ++ "_INLINE" ppr_sig (InlineSig _ var inl) - = pragSrcBrackets (inlinePragmaSource inl) "{-# INLINE" (pprInline inl - <+> pprPrefixOcc (unLoc var)) -ppr_sig (SpecInstSig _ src ty) + = ppr_pfx <+> pprInline inl <+> pprPrefixOcc (unLoc var) <+> text "#-}" + where + ppr_pfx = case inlinePragmaSource inl of + SourceText src -> text src + NoSourceText -> text "{-#" <+> inlinePragmaName (inl_inline inl) +ppr_sig (SpecInstSig (_, src) ty) = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty) -ppr_sig (MinimalSig _ src bf) +ppr_sig (MinimalSig (_, src) bf) = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf) ppr_sig (PatSynSig _ names sig_ty) = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) -ppr_sig (SCCFunSig _ src fn mlabel) +ppr_sig (SCCFunSig (_, src) fn mlabel) = pragSrcBrackets src "{-# SCC" (ppr_fn <+> maybe empty ppr mlabel ) where ppr_fn = case ghcPass @p of GhcPs -> ppr fn GhcRn -> ppr fn GhcTc -> ppr fn -ppr_sig (CompleteMatchSig _ src cs mty) +ppr_sig (CompleteMatchSig (_, src) cs mty) = pragSrcBrackets src "{-# COMPLETE" ((hsep (punctuate comma (map ppr_n (unLoc cs)))) <+> opt_sig) @@ -749,7 +781,41 @@ GhcPs -> ppr n GhcRn -> ppr n GhcTc -> ppr n +ppr_sig (XSig x) = case ghcPass @p of + GhcRn | IdSig id <- x -> pprVarSig [id] (ppr (varType id)) + GhcTc | IdSig id <- x -> pprVarSig [id] (ppr (varType id)) +hsSigDoc :: forall p. IsPass p => Sig (GhcPass p) -> SDoc +hsSigDoc (TypeSig {}) = text "type signature" +hsSigDoc (PatSynSig {}) = text "pattern synonym signature" +hsSigDoc (ClassOpSig _ is_deflt _ _) + | is_deflt = text "default type signature" + | otherwise = text "class method signature" +hsSigDoc (SpecSig _ _ _ 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 +-- from the InlineSpec field of the pragma. +hsSigDoc (SpecInstSig (_, src) _) = text (extractSpecPragName src) <+> text "instance pragma" +hsSigDoc (FixSig {}) = text "fixity declaration" +hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" +hsSigDoc (SCCFunSig {}) = text "SCC pragma" +hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" +hsSigDoc (XSig _) = case ghcPass @p of + GhcRn -> text "id signature" + GhcTc -> text "id signature" + +-- | Extracts the name for a SPECIALIZE instance pragma. In 'hsSigDoc', the src +-- field of 'SpecInstSig' signature contains the SourceText for a SPECIALIZE +-- instance pragma of the form: "SourceText {-# SPECIALIZE" +-- +-- Extraction ensures that all variants of the pragma name (with a 'Z' or an +-- 'S') are output exactly as used in the pragma. +extractSpecPragName :: SourceText -> String +extractSpecPragName srcTxt = case (words $ show srcTxt) of + (_:_:pragName:_) -> filter (/= '\"') pragName + _ -> pprPanic "hsSigDoc: Misformed SPECIALISE instance pragma:" (ppr srcTxt) + instance OutputableBndrId p => Outputable (FixitySig (GhcPass p)) where ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops] @@ -782,7 +848,7 @@ instance Outputable TcSpecPrag where ppr (SpecPrag var _ inl) - = ppr (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "") inl + = text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "") inl pprMinimalSig :: (OutputableBndr name) => LBooleanFormula (GenLocated l name) -> SDoc diff --git a/GHC/Hs/Decls.hs b/GHC/Hs/Decls.hs --- a/GHC/Hs/Decls.hs +++ b/GHC/Hs/Decls.hs @@ -16,9 +16,6 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | Abstract syntax of global declarations. -- -- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, @@ -27,7 +24,7 @@ -- * Toplevel declarations HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys, - NewOrData(..), newOrDataToFlavour, + NewOrData, newOrDataToFlavour, anyLConIsGadt, StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName, -- ** Class or type declarations @@ -43,7 +40,8 @@ tyClDeclLName, tyClDeclTyVars, hsDeclHasCusk, famResultKindSignature, FamilyDecl(..), LFamilyDecl, - FunDep(..), + FunDep(..), ppDataDefnHeader, + pp_vanilla_decl_head, -- ** Instance declarations InstDecl(..), LInstDecl, FamilyInfo(..), @@ -69,7 +67,7 @@ -- ** @default@ declarations DefaultDecl(..), LDefaultDecl, -- ** Template haskell declaration splice - SpliceExplicitFlag(..), + SpliceDecoration(..), SpliceDecl(..), LSpliceDecl, -- ** Foreign function interface declarations ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), @@ -104,7 +102,7 @@ import Language.Haskell.Syntax.Decls -import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprSpliceDecl ) +import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice ) -- Because Expr imports Decls via HsBracket import GHC.Hs.Binds @@ -120,16 +118,19 @@ import GHC.Types.Fixity -- others: +import GHC.Utils.Misc (count) import GHC.Utils.Outputable import GHC.Utils.Panic 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.Data.Bag import GHC.Data.Maybe import Data.Data (Data) +import Data.Foldable (toList) {- ************************************************************************ @@ -187,6 +188,10 @@ -> (bs, ss, ts, tfis, dfis, L l d : docs) _ -> pprPanic "partitionBindsAndSigs" (ppr decl) +-- Okay, I need to reconstruct the document comments, but for now: +instance Outputable (DocDecl name) where + ppr _ = text "" + type instance XCHsGroup (GhcPass _) = NoExtField type instance XXHsGroup (GhcPass _) = DataConCantHappen @@ -313,8 +318,14 @@ instance OutputableBndrId p => Outputable (SpliceDecl (GhcPass p)) where - ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f + ppr (SpliceDecl _ (L _ e) DollarSplice) = pprUntypedSplice True Nothing e + ppr (SpliceDecl _ (L _ e) BareSplice) = pprUntypedSplice False Nothing e +instance Outputable SpliceDecoration where + ppr x = text $ show x + + + {- ************************************************************************ * * @@ -333,7 +344,14 @@ type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn -type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey, LayoutInfo) -- See Note [Class LayoutInfo] +data DataDeclRn = DataDeclRn + { tcdDataCusk :: Bool -- ^ does this have a CUSK? + -- See Note [CUSKs: complete user-supplied kind signatures] + , tcdFVs :: NameSet } + deriving Data + +type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey) + -- TODO:AZ:tidy up AnnSortKey above type instance XClassDecl GhcRn = NameSet -- FVs type instance XClassDecl GhcTc = NameSet -- FVs @@ -343,6 +361,17 @@ type instance XCTyFamInstDecl (GhcPass _) = EpAnn [AddEpAnn] type instance XXTyFamInstDecl (GhcPass _) = DataConCantHappen +------------- Pretty printing FamilyDecls ----------- + +pprFlavour :: FamilyInfo pass -> SDoc +pprFlavour DataFamily = text "data" +pprFlavour OpenTypeFamily = text "type" +pprFlavour (ClosedTypeFamily {}) = text "type" + +instance Outputable (FamilyInfo pass) where + ppr info = pprFlavour info <+> text "family" + + -- Dealing with names tyFamInstDeclName :: Anno (IdGhcP p) ~ SrcSpanAnnN @@ -361,6 +390,21 @@ tyClDeclLName (DataDecl { tcdLName = ln }) = ln tyClDeclLName (ClassDecl { tcdLName = ln }) = ln +countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int) + -- class, synonym decls, data, newtype, family decls +countTyClDecls decls + = (count isClassDecl decls, + count isSynDecl decls, -- excluding... + count isDataTy decls, -- ...family... + count isNewTy decls, -- ...instances + count isFamilyDecl decls) + where + isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = DataTypeCons _ _ } } = True + isDataTy _ = False + + isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = NewTypeCon _ } } = True + isNewTy _ = False + -- FIXME: tcdName is commonly used by both GHC and third-party tools, so it -- needs to be polymorphic in the pass tcdName :: Anno (IdGhcP p) ~ SrcSpanAnnN @@ -441,10 +485,11 @@ = hsep [pprLHsContext context, pp_tyvars tyvars] where pp_tyvars (varl:varsr) - | fixity == Infix && length varsr > 1 + | fixity == Infix, varr:varsr'@(_:_) <- varsr + -- If varsr has at least 2 elements, parenthesize. = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing) - , (ppr.unLoc) (head varsr), char ')' - , hsep (map (ppr.unLoc) (tail varsr))] + , (ppr.unLoc) varr, char ')' + , hsep (map (ppr.unLoc) varsr')] | fixity == Infix = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) , hsep (map (ppr.unLoc) varsr)] @@ -457,8 +502,8 @@ pprTyClDeclFlavour (SynDecl {}) = text "type" pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) = pprFlavour info <+> text "family" -pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) - = ppr nd +pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = nd } }) + = ppr (dataDefnConsNewOrData nd) instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where ppr = pprFunDep @@ -590,6 +635,15 @@ Just (L _ via@ViaStrategy{}) -> (empty, ppr via) _ -> (ppDerivStrategy dcs, empty) +-- | A short description of a @DerivStrategy'@. +derivStrategyName :: DerivStrategy a -> SDoc +derivStrategyName = text . go + where + go StockStrategy {} = "stock" + go AnyclassStrategy {} = "anyclass" + go NewtypeStrategy {} = "newtype" + go ViaStrategy {} = "via" + type instance XDctSingle (GhcPass _) = NoExtField type instance XDctMulti (GhcPass _) = NoExtField type instance XXDerivClauseTys (GhcPass _) = DataConCantHappen @@ -612,9 +666,10 @@ type instance XXConDecl (GhcPass _) = DataConCantHappen +-- Codomain could be 'NonEmpty', but at the moment all users need a list. getConNames :: ConDecl GhcRn -> [LocatedN Name] getConNames ConDeclH98 {con_name = name} = [name] -getConNames ConDeclGADT {con_names = names} = names +getConNames ConDeclGADT {con_names = names} = toList names -- | Return @'Just' fields@ if a data constructor declaration uses record -- syntax (i.e., 'RecCon'), where @fields@ are the field selectors. @@ -632,28 +687,41 @@ hsConDeclTheta Nothing = [] hsConDeclTheta (Just (L _ theta)) = theta +ppDataDefnHeader + :: (OutputableBndrId p) + => (Maybe (LHsContext (GhcPass p)) -> SDoc) -- Printing the header + -> HsDataDefn (GhcPass p) + -> SDoc +ppDataDefnHeader pp_hdr HsDataDefn + { dd_ctxt = context + , dd_cType = mb_ct + , dd_kindSig = mb_sig + , dd_cons = condecls } + = pp_type <+> ppr (dataDefnConsNewOrData condecls) <+> pp_ct <+> pp_hdr context <+> pp_sig + where + pp_type + | isTypeDataDefnCons condecls = text "type" + | otherwise = empty + pp_ct = case mb_ct of + Nothing -> empty + Just ct -> ppr ct + pp_sig = case mb_sig of + Nothing -> empty + Just kind -> dcolon <+> ppr kind + pp_data_defn :: (OutputableBndrId p) => (Maybe (LHsContext (GhcPass p)) -> SDoc) -- Printing the header -> HsDataDefn (GhcPass p) -> SDoc -pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context - , dd_cType = mb_ct - , dd_kindSig = mb_sig - , dd_cons = condecls, dd_derivs = derivings }) +pp_data_defn pp_hdr defn@HsDataDefn + { dd_cons = condecls + , dd_derivs = derivings } | null condecls - = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig - <+> pp_derivings derivings + = ppDataDefnHeader pp_hdr defn <+> pp_derivings derivings | otherwise - = hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig) - 2 (pp_condecls condecls $$ pp_derivings derivings) + = hang (ppDataDefnHeader pp_hdr defn) 2 (pp_condecls (toList condecls) $$ pp_derivings derivings) where - pp_ct = case mb_ct of - Nothing -> empty - Just ct -> ppr ct - pp_sig = case mb_sig of - Nothing -> empty - Just kind -> dcolon <+> ppr kind pp_derivings ds = vcat (map ppr ds) instance OutputableBndrId p @@ -667,15 +735,10 @@ pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc pp_condecls cs - | gadt_syntax -- In GADT syntax + | anyLConIsGadt cs -- In GADT syntax = hang (text "where") 2 (vcat (map ppr cs)) | otherwise -- In H98 syntax = equals <+> sep (punctuate (text " |") (map ppr cs)) - where - gadt_syntax = case cs of - [] -> False - (L _ ConDeclH98{} : _) -> False - (L _ ConDeclGADT{} : _) -> True instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where ppr = pprConDecl @@ -703,7 +766,7 @@ pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_doc = doc }) - = pprMaybeWithDoc doc $ ppr_con_names cons <+> dcolon + = pprMaybeWithDoc doc $ ppr_con_names (toList cons) <+> dcolon <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt, sep (ppr_args args ++ [ppr res_ty]) ]) where @@ -797,9 +860,9 @@ -- pp_data_defn pretty-prints the kind sig. See #14817. pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc -pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = - (FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }})}) - = ppr nd +pprDataFamInstFlavour DataFamInstDecl + { dfid_eqn = FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons }}} + = ppr (dataDefnConsNewOrData cons) pprHsFamInstLHS :: (OutputableBndrId p) => IdP (GhcPass p) @@ -870,6 +933,23 @@ do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] do_one (L _ (TyFamInstD {})) = [] +-- | Convert a 'NewOrData' to a 'TyConFlavour' +newOrDataToFlavour :: NewOrData -> TyConFlavour +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 + L _ ConDeclGADT {} : _ -> True + _ -> False +{-# SPECIALIZE anyLConIsGadt :: [GenLocated l (ConDecl pass)] -> Bool #-} +{-# SPECIALIZE anyLConIsGadt :: DataDefnCons (GenLocated l (ConDecl pass)) -> Bool #-} + {- ************************************************************************ * * @@ -986,6 +1066,14 @@ type instance XXForeignDecl (GhcPass _) = DataConCantHappen +type instance XCImport (GhcPass _) = Located 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 XXForeignExport (GhcPass _) = DataConCantHappen + +-- pretty printing of foreign declarations + instance OutputableBndrId p => Outputable (ForeignDecl (GhcPass p)) where ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) @@ -995,6 +1083,40 @@ hang (text "foreign export" <+> ppr fexport <+> ppr n) 2 (dcolon <+> ppr ty) +instance OutputableBndrId p + => Outputable (ForeignImport (GhcPass p)) where + ppr (CImport (L _ srcText) cconv safety mHeader spec) = + ppr cconv <+> ppr safety + <+> pprWithSourceText srcText (pprCEntity spec "") + where + pp_hdr = case mHeader of + Nothing -> empty + Just (Header _ header) -> ftext header + + pprCEntity (CLabel lbl) _ = + doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl + pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src = + if dqNeeded then doubleQuotes ce else empty + where + dqNeeded = (take 6 src == "static") + || isJust mHeader + || not isFun + || st /= NoSourceText + ce = + -- We may need to drop leading spaces first + (if take 6 src == "static" then text "static" else empty) + <+> pp_hdr + <+> (if isFun then empty else text "value") + <+> (pprWithSourceText st empty) + pprCEntity (CFunction DynamicTarget) _ = + doubleQuotes $ text "dynamic" + pprCEntity CWrapper _ = doubleQuotes $ text "wrapper" + +instance OutputableBndrId p + => Outputable (ForeignExport (GhcPass p)) where + ppr (CExport _ (L _ (CExportStatic _ lbl cconv))) = + ppr cconv <+> char '"' <> ppr lbl <> char '"' + {- ************************************************************************ * * @@ -1003,19 +1125,20 @@ ************************************************************************ -} -type instance XCRuleDecls GhcPs = EpAnn [AddEpAnn] -type instance XCRuleDecls GhcRn = NoExtField -type instance XCRuleDecls GhcTc = NoExtField +type instance XCRuleDecls GhcPs = (EpAnn [AddEpAnn], SourceText) +type instance XCRuleDecls GhcRn = SourceText +type instance XCRuleDecls GhcTc = SourceText type instance XXRuleDecls (GhcPass _) = DataConCantHappen -type instance XHsRule GhcPs = EpAnn HsRuleAnn -type instance XHsRule GhcRn = HsRuleRn -type instance XHsRule GhcTc = HsRuleRn +type instance XHsRule GhcPs = (EpAnn HsRuleAnn, SourceText) +type instance XHsRule GhcRn = (HsRuleRn, SourceText) +type instance XHsRule GhcTc = (HsRuleRn, SourceText) -type instance XXRuleDecl (GhcPass _) = DataConCantHappen +data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS + deriving Data -type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns +type instance XXRuleDecl (GhcPass _) = DataConCantHappen data HsRuleAnn = HsRuleAnn @@ -1036,19 +1159,24 @@ type instance XXRuleBndr (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where - ppr (HsRules { rds_src = st + ppr (HsRules { rds_ext = ext , rds_rules = rules }) = pprWithSourceText st (text "{-# RULES") <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" + where st = case ghcPass @p of + GhcPs | (_, st) <- ext -> st + GhcRn -> ext + GhcTc -> ext instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where - ppr (HsRule { rd_name = name + ppr (HsRule { rd_ext = ext + , rd_name = name , rd_act = act , rd_tyvs = tys , rd_tmvs = tms , rd_lhs = lhs , rd_rhs = rhs }) - = sep [pprFullRuleName name <+> ppr act, + = sep [pprFullRuleName st name <+> ppr act, nest 4 (pp_forall_ty tys <+> pp_forall_tm tys <+> pprExpr (unLoc lhs)), nest 6 (equals <+> pprExpr (unLoc rhs)) ] @@ -1057,11 +1185,19 @@ 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) + + {- ************************************************************************ * * @@ -1070,9 +1206,9 @@ ************************************************************************ -} -type instance XWarnings GhcPs = EpAnn [AddEpAnn] -type instance XWarnings GhcRn = NoExtField -type instance XWarnings GhcTc = NoExtField +type instance XWarnings GhcPs = (EpAnn [AddEpAnn], SourceText) +type instance XWarnings GhcRn = SourceText +type instance XWarnings GhcTc = SourceText type instance XXWarnDecls (GhcPass _) = DataConCantHappen @@ -1082,9 +1218,13 @@ instance OutputableBndrId p => Outputable (WarnDecls (GhcPass p)) where - ppr (Warnings _ (SourceText src) decls) + ppr (Warnings ext decls) = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" - ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls" + where src = case ghcPass @p of + GhcPs | (_, SourceText src) <- ext -> src + GhcRn | SourceText src <- ext -> src + GhcTc | SourceText src <- ext -> src + _ -> panic "WarnDecls" instance OutputableBndrId p => Outputable (WarnDecl (GhcPass p)) where @@ -1100,11 +1240,11 @@ ************************************************************************ -} -type instance XHsAnnotation (GhcPass _) = EpAnn AnnPragma +type instance XHsAnnotation (GhcPass _) = (EpAnn AnnPragma, SourceText) type instance XXAnnDecl (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where - ppr (HsAnnotation _ _ provenance expr) + ppr (HsAnnotation _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] pprAnnProvenance :: OutputableBndrId p => AnnProvenance (GhcPass p) -> SDoc @@ -1185,3 +1325,6 @@ 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 diff --git a/GHC/Hs/Doc.hs b/GHC/Hs/Doc.hs --- a/GHC/Hs/Doc.hs +++ b/GHC/Hs/Doc.hs @@ -36,10 +36,9 @@ import GHC.Data.EnumSet (EnumSet) import GHC.Types.Avail import GHC.Types.Name.Set -import GHC.Unit.Module.Name import GHC.Driver.Flags -import Control.Applicative (liftA2) +import Control.DeepSeq import Data.Data import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap @@ -48,13 +47,15 @@ import Data.List.NonEmpty (NonEmpty(..)) import GHC.LanguageExtensions.Type import qualified GHC.Utils.Outputable as O -import Language.Haskell.Syntax.Extension import GHC.Hs.Extension import GHC.Types.Unique.Map import Data.List (sortBy) import GHC.Hs.DocString +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Module.Name + -- | A docstring with the (probable) identifiers found in it. type HsDoc = WithHsDocIdentifiers HsDocString @@ -74,6 +75,8 @@ deriving instance (Data pass, Data (IdP pass), Data a) => Data (WithHsDocIdentifiers a pass) deriving instance (Eq (IdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass) +instance (NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where + rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf i -- | For compatibility with the existing @-ddump-parsed' output, we only show -- the docstring. @@ -85,9 +88,9 @@ instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where put_ bh (WithHsDocIdentifiers s ids) = do put_ bh s - put_ bh ids + put_ bh $ BinLocated <$> ids get bh = - liftA2 WithHsDocIdentifiers (get bh) (get bh) + liftA2 WithHsDocIdentifiers (get bh) (fmap unBinLocated <$> get bh) -- | Extract a mapping from the lexed identifiers to the names they may -- correspond to. @@ -118,19 +121,19 @@ -- | A simplified version of 'HsImpExp.IE'. data DocStructureItem - = DsiSectionHeading Int (HsDoc GhcRn) - | DsiDocChunk (HsDoc GhcRn) - | DsiNamedChunkRef String - | DsiExports Avails + = DsiSectionHeading !Int !(HsDoc GhcRn) + | DsiDocChunk !(HsDoc GhcRn) + | DsiNamedChunkRef !(String) + | DsiExports !Avails | DsiModExport - (NonEmpty ModuleName) -- ^ We might re-export avails from multiple + !(NonEmpty ModuleName) -- ^ We might re-export avails from multiple -- modules with a single export declaration. E.g. -- when we have -- -- > module M (module X) where -- > import R0 as X -- > import R1 as X - Avails + !Avails instance Binary DocStructureItem where put_ bh = \case @@ -179,6 +182,15 @@ DsiModExport mod_names avails -> text "re-exported module(s):" <+> ppr mod_names $$ nest 2 (ppr avails) +instance NFData DocStructureItem where + rnf = \case + DsiSectionHeading level doc -> rnf level `seq` rnf doc + DsiDocChunk doc -> rnf doc + DsiNamedChunkRef name -> rnf name + DsiExports avails -> rnf avails + DsiModExport mod_names avails -> rnf mod_names `seq` rnf avails + + type DocStructure = [DocStructureItem] data Docs = Docs @@ -202,6 +214,12 @@ , docs_extensions :: EnumSet Extension -- ^ The full set of language extensions used in the module. } + +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 + `seq` rnf haddock_opts `seq` rnf language `seq` rnf extentions + `seq` () instance Binary Docs where put_ bh docs = do diff --git a/GHC/Hs/DocString.hs b/GHC/Hs/DocString.hs --- a/GHC/Hs/DocString.hs +++ b/GHC/Hs/DocString.hs @@ -1,5 +1,7 @@ -- | An exactprintable structure for docstrings {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Hs.DocString ( LHsDocString @@ -27,6 +29,7 @@ import GHC.Utils.Encoding import GHC.Utils.Outputable as Outputable hiding ((<>)) import GHC.Types.SrcLoc +import Control.DeepSeq import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -59,6 +62,11 @@ instance Outputable HsDocString where ppr = text . renderHsDocString +instance NFData HsDocString where + rnf (MultiLineDocString a b) = rnf a `seq` rnf b + rnf (NestedDocString a b) = rnf a `seq` rnf b + rnf (GeneratedDocString a) = rnf a + -- | Annotate a pretty printed thing with its doc -- The docstring comes after if is 'HsDocStringPrevious' -- Otherwise it comes before. @@ -75,19 +83,19 @@ MultiLineDocString dec xs -> do putByte bh 0 put_ bh dec - put_ bh xs + put_ bh $ BinLocated <$> xs NestedDocString dec x -> do putByte bh 1 put_ bh dec - put_ bh x + put_ bh $ BinLocated x GeneratedDocString x -> do putByte bh 2 put_ bh x get bh = do tag <- getByte bh case tag of - 0 -> MultiLineDocString <$> get bh <*> get bh - 1 -> NestedDocString <$> get bh <*> get bh + 0 -> MultiLineDocString <$> get bh <*> (fmap unBinLocated <$> get bh) + 1 -> NestedDocString <$> get bh <*> (unBinLocated <$> get bh) 2 -> GeneratedDocString <$> get bh t -> fail $ "HsDocString: invalid tag " ++ show t @@ -101,6 +109,12 @@ instance Outputable HsDocStringDecorator where ppr = text . printDecorator +instance NFData HsDocStringDecorator where + rnf HsDocStringNext = () + rnf HsDocStringPrevious = () + rnf (HsDocStringNamed x) = rnf x + rnf (HsDocStringGroup x) = rnf x + printDecorator :: HsDocStringDecorator -> String printDecorator HsDocStringNext = "|" printDecorator HsDocStringPrevious = "^" @@ -124,9 +138,10 @@ type LHsDocStringChunk = Located HsDocStringChunk --- | A continguous chunk of documentation +-- | A contiguous chunk of documentation newtype HsDocStringChunk = HsDocStringChunk ByteString - deriving (Eq,Ord,Data, Show) + deriving stock (Eq,Ord,Data, Show) + deriving newtype (NFData) instance Binary HsDocStringChunk where put_ bh (HsDocStringChunk bs) = put_ bh bs @@ -135,9 +150,8 @@ instance Outputable HsDocStringChunk where ppr = text . unpackHDSC - mkHsDocStringChunk :: String -> HsDocStringChunk -mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeString s) +mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeByteString s) -- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. mkHsDocStringChunkUtf8ByteString :: ByteString -> HsDocStringChunk @@ -192,6 +206,6 @@ unlines' = intercalate "\n" -- | Just get the docstring, without any decorators --- Seperates docstrings using "\n\n", which is how haddock likes to render them +-- Separates docstrings using "\n\n", which is how haddock likes to render them renderHsDocStrings :: [HsDocString] -> String renderHsDocStrings = intercalate "\n\n" . map renderHsDocString diff --git a/GHC/Hs/Dump.hs b/GHC/Hs/Dump.hs --- a/GHC/Hs/Dump.hs +++ b/GHC/Hs/Dump.hs @@ -30,7 +30,6 @@ import GHC.Types.SrcLoc import GHC.Types.Var import GHC.Types.SourceText -import GHC.Unit.Module import GHC.Utils.Outputable import Data.Data hiding (Fixity) @@ -145,7 +144,7 @@ _ -> parens $ text "SourceText" <+> text "blanked" epaAnchor :: EpaLocation -> SDoc - epaAnchor (EpaSpan r) = parens $ text "EpaSpan" <+> realSrcSpan r + 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" @@ -159,7 +158,7 @@ occName n = braces $ text "OccName:" - <+> text (occNameString n) + <+> ftext (occNameFS n) moduleName :: ModuleName -> SDoc moduleName m = braces $ text "ModuleName:" <+> ppr m diff --git a/GHC/Hs/Expr.hs b/GHC/Hs/Expr.hs --- a/GHC/Hs/Expr.hs +++ b/GHC/Hs/Expr.hs @@ -14,7 +14,6 @@ {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable {- @@ -33,10 +32,11 @@ -- friends: import GHC.Prelude -import GHC.Hs.Decls +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 @@ -44,8 +44,8 @@ -- others: import GHC.Tc.Types.Evidence -import GHC.Core.DataCon (FieldLabelString) import GHC.Types.Name +import GHC.Types.Name.Reader import GHC.Types.Name.Set import GHC.Types.Basic import GHC.Types.Fixity @@ -64,6 +64,9 @@ 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(..)) @@ -163,21 +166,6 @@ ppr NoSyntaxExprTc = text "" --- | Extra data fields for a 'RecordUpd', added by the type checker -data RecordUpdTc = RecordUpdTc - { rupd_cons :: [ConLike] - -- Filled in by the type checker to the - -- _non-empty_ list of DataCons that have - -- all the upd'd fields - - , rupd_in_tys :: [Type] -- Argument types of *input* record type - , rupd_out_tys :: [Type] -- and *output* record type - -- For a data family, these are the type args of the - -- /representation/ type constructor - - , rupd_wrap :: HsWrapper -- See Note [Record Update HsWrapper] - } - -- | HsWrap appears only in typechecker output data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper (hs_syn GhcTc) -- the thing that is wrapped @@ -186,80 +174,14 @@ -- --------------------------------------------------------------------- -{- -Note [The life cycle of a TH quotation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When desugaring a bracket (aka quotation), we want to produce Core -code that, when run, will produce the TH syntax tree for the quotation. -To that end, we want to desugar /renamed/ but not /typechecked/ code; -the latter is cluttered with the typechecker's elaboration that should -not appear in the TH syntax tree. So in (HsExpr GhcTc) tree, we must -have a (HsExpr GhcRn) for the quotation itself. - -As such, when typechecking both typed and untyped brackets, -we keep a /renamed/ bracket in the extension field. - -The HsBracketTc, the GhcTc ext field for both brackets, contains: - - The renamed quote :: HsQuote GhcRn -- for the desugarer - - [PendingTcSplice] - - The type of the quote - - Maybe QuoteWrapper - -Note that (HsBracketTc) stores the untyped (HsQuote GhcRn) for both typed and -untyped brackets. They are treated uniformly by the desugarer, and we can -easily construct untyped brackets from typed ones (with ExpBr). - -Typed quotes -~~~~~~~~~~~~ -Here is the life cycle of a /typed/ quote [|| e ||], whose datacon is - HsTypedBracket (XTypedBracket p) (LHsExpr p) - - In pass p (XTypedBracket p) (LHsExpr p) - ------------------------------------------- - GhcPs Annotations only LHsExpr GhcPs - GhcRn Annotations only LHsExpr GhcRn - GhcTc HsBracketTc LHsExpr GhcTc: unused! - -Note that in the GhcTc tree, the second field (HsExpr GhcTc) -is entirely unused; the desugarer uses the (HsExpr GhcRn) from the -first field. - -Untyped quotes -~~~~~~~~~~~~~~ -Here is the life cycle of an /untyped/ quote, whose datacon is - HsUntypedBracket (XUntypedBracket p) (HsQuote p) - -Here HsQuote is a sum-type of expressions [| e |], patterns [| p |], -types [| t |] etc. - - In pass p (XUntypedBracket p) (HsQuote p) - ------------------------------------------------------- - GhcPs Annotations only HsQuote GhcPs - GhcRn Annotations, [PendingRnSplice] HsQuote GhcRn - GhcTc HsBracketTc HsQuote GhcTc: unused! - -The difficulty is: the typechecker does not typecheck the body of an -untyped quote, so how do we make a (HsQuote GhcTc) to put in the -second field? - -Answer: we use the extension constructor of HsQuote, XQuote, and make -all the other constructors into DataConCantHappen. That is, the only -non-bottom value of type (HsQuote GhcTc) is (XQuote noExtField). Hence -the instances - type instance XExpBr GhcTc = DataConCantHappen - ...etc... - -See the related Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice --} - data HsBracketTc = HsBracketTc - { brack_renamed_quote :: (HsQuote GhcRn) -- See Note [The life cycle of a TH quotation] - , brack_ty :: Type - , brack_quote_wrapper :: (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument to the quote. - , brack_pending_splices :: [PendingTcSplice] -- Output of the type checker is the *original* - -- renamed expression, plus - -- _typechecked_ splices to be - -- pasted back in by the desugarer + { 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] @@ -326,7 +248,7 @@ type instance XApp (GhcPass _) = EpAnnCO -type instance XAppTypeE GhcPs = SrcSpan -- Where the `@` lives +type instance XAppTypeE GhcPs = NoExtField type instance XAppTypeE GhcRn = NoExtField type instance XAppTypeE GhcTc = Type @@ -397,7 +319,10 @@ type instance XRecordUpd GhcPs = EpAnn [AddEpAnn] type instance XRecordUpd GhcRn = NoExtField -type instance XRecordUpd GhcTc = RecordUpdTc +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 @@ -419,7 +344,6 @@ type instance XArithSeq GhcRn = NoExtField type instance XArithSeq GhcTc = PostTcExpr -type instance XSpliceE (GhcPass _) = EpAnnCO type instance XProc (GhcPass _) = EpAnn [AddEpAnn] type instance XStatic GhcPs = EpAnn [AddEpAnn] @@ -463,7 +387,7 @@ -- --------------------------------------------------------------------- -type instance XSCC (GhcPass _) = EpAnn AnnPragma +type instance XSCC (GhcPass _) = (EpAnn AnnPragma, SourceText) type instance XXPragE (GhcPass _) = DataConCantHappen type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel @@ -565,7 +489,9 @@ ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv ppr_expr (HsRecSel _ f) = pprPrefixOcc f ppr_expr (HsIPVar _ v) = ppr v -ppr_expr (HsOverLabel _ l) = char '#' <> ppr l +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) @@ -621,10 +547,10 @@ ppr_expr (ExplicitTuple _ exprs boxity) -- Special-case unary boxed tuples so that they are pretty-printed as - -- `Solo x`, not `(x)` + -- `MkSolo x`, not `(x)` | [Present _ expr] <- exprs , Boxed <- boxity - = hsep [text (mkTupleStr Boxed 1), ppr expr] + = hsep [text (mkTupleStr Boxed dataName 1), ppr expr] | otherwise = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args exprs)) where @@ -713,7 +639,17 @@ ppr_expr (ArithSeq _ _ info) = brackets (ppr info) -ppr_expr (HsSpliceE _ s) = pprSplice s +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 @@ -797,7 +733,7 @@ -> SDoc ppr_apps (HsApp _ (L _ fun) arg) args = ppr_apps fun (Left arg : args) -ppr_apps (HsAppType _ (L _ fun) 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 @@ -867,7 +803,8 @@ go (ExprWithTySig{}) = prec >= sigPrec go (ArithSeq{}) = False go (HsPragE{}) = prec >= appPrec - go (HsSpliceE{}) = False + go (HsTypedSplice{}) = False + go (HsUntypedSplice{}) = False go (HsTypedBracket{}) = False go (HsUntypedBracket{}) = False go (HsProc{}) = prec > topPrec @@ -937,7 +874,7 @@ isAtomicHsExpr _ = False instance Outputable (HsPragE (GhcPass p)) where - ppr (HsPragSCC _ st (StringLiteral stl lbl _)) = + 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. @@ -1176,6 +1113,46 @@ -- 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 @@ -1185,6 +1162,7 @@ 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 @@ -1304,10 +1282,17 @@ ************************************************************************ -} -type instance XMG GhcPs b = NoExtField -type instance XMG GhcRn b = NoExtField +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] @@ -1698,16 +1683,47 @@ ************************************************************************ -} -newtype HsSplicedT = HsSplicedT DelayedSplice deriving (Data) +-- | 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 ())] -type instance XTypedSplice (GhcPass _) = EpAnn [AddEpAnn] -type instance XUntypedSplice (GhcPass _) = EpAnn [AddEpAnn] -type instance XQuasiQuote (GhcPass _) = NoExtField -type instance XSpliced (GhcPass _) = NoExtField -type instance XXSplice GhcPs = DataConCantHappen -type instance XXSplice GhcRn = DataConCantHappen -type instance XXSplice GhcTc = HsSplicedT +-- 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 = @@ -1726,6 +1742,13 @@ -- 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) @@ -1734,116 +1757,38 @@ data PendingTcSplice = PendingTcSplice SplicePointName (LHsExpr GhcTc) -{- -Note [Pending Splices] -~~~~~~~~~~~~~~~~~~~~~~ -When we rename an untyped bracket, we name and lift out all the nested -splices, so that when the typechecker hits the bracket, it can -typecheck those nested splices without having to walk over the untyped -bracket code. So for example - [| f $(g x) |] -looks like - HsUntypedBracket _ (HsApp (HsVar "f") (HsSpliceE _ (HsUntypedSplice sn (g x))) - -which the renamer rewrites to - - HsUntypedBracket - [PendingRnSplice UntypedExpSplice sn (g x)] - (HsApp (HsVar f) (HsSpliceE _ (HsUntypedSplice sn (g x))) - -* The 'sn' is the Name of the splice point, the SplicePointName - -* The PendingRnExpSplice gives the splice that splice-point name maps to; - and the typechecker can now conveniently find these sub-expressions - -* 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 - - In the HsSpliceE in the body of the bracket. This copy is used only for pretty printing. - -There are four varieties of pending splices generated by the renamer, -distinguished by their UntypedSpliceFlavour - - * Pending expression splices (UntypedExpSplice), e.g., - [|$(f x) + 2|] - - UntypedExpSplice is also used for - * quasi-quotes, where the pending expression expands to - $(quoter "...blah...") - (see GHC.Rename.Splice.makePending, HsQuasiQuote case) - - * cross-stage lifting, where the pending expression expands to - $(lift x) - (see GHC.Rename.Splice.checkCrossStageLifting) - - * Pending pattern splices (UntypedPatSplice), e.g., - [| \$(f x) -> x |] - - * Pending type splices (UntypedTypeSplice), e.g., - [| f :: $(g x) |] - - * Pending declaration (UntypedDeclSplice), e.g., - [| let $(f x) in ... |] - -There is a fifth variety of pending splice, which is generated by the type -checker: - - * Pending *typed* expression splices, (PendingTcSplice), e.g., - [||1 + $$(f 2)||] --} - -instance OutputableBndrId p - => Outputable (HsSplicedThing (GhcPass p)) where - ppr (HsSplicedExpr e) = ppr_expr e - ppr (HsSplicedTy t) = ppr t - ppr (HsSplicedPat p) = ppr p - -instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where - ppr s = pprSplice s - pprPendingSplice :: (OutputableBndrId p) => SplicePointName -> LHsExpr (GhcPass p) -> SDoc pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e)) -pprSpliceDecl :: (OutputableBndrId p) - => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc -pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e -pprSpliceDecl e ExplicitSplice = text "$" <> ppr_splice_decl e -pprSpliceDecl e ImplicitSplice = ppr_splice_decl e - -ppr_splice_decl :: (OutputableBndrId p) - => HsSplice (GhcPass p) -> SDoc -ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty -ppr_splice_decl e = pprSplice e +pprTypedSplice :: (OutputableBndrId p) => Maybe SplicePointName -> LHsExpr (GhcPass p) -> SDoc +pprTypedSplice n e = ppr_splice (text "$$") n e -pprSplice :: forall p. (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc -pprSplice (HsTypedSplice _ DollarSplice n e) - = ppr_splice (text "$$") n e empty -pprSplice (HsTypedSplice _ BareSplice _ _ ) - = panic "Bare typed splice" -- impossible -pprSplice (HsUntypedSplice _ DollarSplice n e) - = ppr_splice (text "$") n e empty -pprSplice (HsUntypedSplice _ BareSplice n e) - = ppr_splice empty n e empty -pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s -pprSplice (HsSpliced _ _ thing) = ppr thing -pprSplice (XSplice x) = case ghcPass @p of -#if __GLASGOW_HASKELL__ < 811 - GhcPs -> dataConCantHappen x - GhcRn -> dataConCantHappen x -#endif - GhcTc -> case x of - HsSplicedT _ -> text "Unevaluated typed splice" +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 -> p -> FastString -> SDoc -ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> - char '[' <> ppr quoter <> vbar <> +ppr_quasi :: OutputableBndr p => p -> FastString -> SDoc +ppr_quasi quoter quote = char '[' <> ppr quoter <> vbar <> ppr quote <> text "|]" ppr_splice :: (OutputableBndrId p) - => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc -ppr_splice herald n e trail - = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail + => 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 @@ -1958,12 +1903,24 @@ 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 @@ -2031,9 +1988,161 @@ , 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} * * ************************************************************************ @@ -2054,17 +2163,19 @@ 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 (HsExpr (GhcPass pr)))) = SrcSpanAnnA -type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))) = SrcSpanAnnA +type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))) = SrcSpanAnnA -type instance Anno (HsSplice (GhcPass p)) = SrcSpanAnnA +type instance Anno (HsUntypedSplice (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 [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 (DotFieldOcc (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)) => WrapXRec (GhcPass p) a where 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 @@ -1,3 +1,5 @@ +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] @@ -10,16 +12,20 @@ import GHC.Utils.Outputable ( SDoc, Outputable ) import Language.Haskell.Syntax.Pat ( LPat ) import {-# SOURCE #-} GHC.Hs.Pat () -- for Outputable -import GHC.Types.Basic ( SpliceExplicitFlag(..)) import Language.Haskell.Syntax.Expr ( HsExpr, LHsExpr , HsCmd , MatchGroup , GRHSs - , HsSplice + , HsUntypedSplice ) import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) +import GHC.Types.Name ( Name ) +import Data.Bool ( Bool ) +import Data.Maybe ( Maybe ) +type SplicePointName = Name + instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) @@ -27,10 +33,8 @@ pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc -pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc - -pprSpliceDecl :: (OutputableBndrId p) - => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc +pprTypedSplice :: (OutputableBndrId p) => Maybe SplicePointName -> LHsExpr (GhcPass p) -> SDoc +pprUntypedSplice :: (OutputableBndrId p) => Bool -> Maybe SplicePointName -> HsUntypedSplice (GhcPass p) -> SDoc pprPatBind :: forall bndr p . (OutputableBndrId bndr, OutputableBndrId p) @@ -38,3 +42,12 @@ pprFunBind :: (OutputableBndrId idR) => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc + +data ThModFinalizers +type role HsUntypedSpliceResult representational +data HsUntypedSpliceResult thing + = HsUntypedSpliceTop + { utsplice_result_finalizers :: ThModFinalizers + , utsplice_result :: thing + } + | HsUntypedSpliceNested SplicePointName diff --git a/GHC/Hs/Extension.hs b/GHC/Hs/Extension.hs --- a/GHC/Hs/Extension.hs +++ b/GHC/Hs/Extension.hs @@ -11,10 +11,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc] {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable + module GHC.Hs.Extension where -- This module captures the type families to precisely identify the extension @@ -22,7 +25,10 @@ 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 @@ -239,3 +245,20 @@ noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok) noHsUniTok = L NoTokenLoc HsNormalTok + +--- Outputable + +instance Outputable NoExtField where + ppr _ = text "NoExtField" + +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 @@ -1,4 +1,6 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable and IEWrappedName {-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -14,53 +16,43 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces -} -module GHC.Hs.ImpExp where +module GHC.Hs.ImpExp + ( module Language.Haskell.Syntax.ImpExp + , module GHC.Hs.ImpExp + ) where import GHC.Prelude -import GHC.Unit.Module ( ModuleName, IsBootInterface(..) ) -import GHC.Hs.Doc import GHC.Types.SourceText ( SourceText(..) ) import GHC.Types.FieldLabel ( FieldLabel ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SrcLoc -import Language.Haskell.Syntax.Extension -import GHC.Hs.Extension import GHC.Parser.Annotation +import GHC.Hs.Extension import GHC.Types.Name import GHC.Types.PkgQual import Data.Data import Data.Maybe +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Module.Name +import Language.Haskell.Syntax.ImpExp + {- ************************************************************************ * * -\subsection{Import and export declaration lists} + Import and export declaration lists * * ************************************************************************ -One per \tr{import} declaration in a module. +One per import declaration in a module. -} --- | 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 type instance Anno (ImportDecl (GhcPass p)) = SrcSpanAnnA --- | If/how an import is 'qualified'. -data ImportDeclQualifiedStyle - = QualifiedPre -- ^ 'qualified' appears in prepositive position. - | QualifiedPost -- ^ 'qualified' appears in postpositive position. - | NotQualified -- ^ Not qualified. - deriving (Eq, Data) - -- | 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". @@ -77,56 +69,40 @@ isImportDeclQualified NotQualified = False isImportDeclQualified _ = True --- | Import Declaration --- --- A single Haskell @import@ declaration. -data ImportDecl pass - = ImportDecl { - ideclExt :: XCImportDecl pass, - ideclSourceSrc :: SourceText, - -- Note [Pragma source text] in GHC.Types.SourceText - ideclName :: XRec pass ModuleName, -- ^ Module name. - ideclPkgQual :: ImportDeclPkgQual pass, -- ^ Package qualifier. - ideclSource :: IsBootInterface, -- ^ IsBoot <=> {-\# SOURCE \#-} import - ideclSafe :: Bool, -- ^ True => safe import - ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified. - ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude) - ideclAs :: Maybe (XRec pass ModuleName), -- ^ as Module - ideclHiding :: Maybe (Bool, XRec pass [LIE pass]) - -- ^ (True => 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 ideclHiding - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - -type family ImportDeclPkgQual pass type instance ImportDeclPkgQual GhcPs = RawPkgQual type instance ImportDeclPkgQual GhcRn = PkgQual type instance ImportDeclPkgQual GhcTc = PkgQual -type instance XCImportDecl GhcPs = EpAnn EpAnnImportDecl -type instance XCImportDecl GhcRn = NoExtField -type instance XCImportDecl GhcTc = NoExtField +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 + , ideclImplicit :: Bool + -- ^ GHC generates an `ImportDecl` to represent the invisible `import Prelude` + -- that appears in any file that omits `import Prelude`, setting + -- this field to indicate that the import doesn't appear in the + -- original source. True => implicit import (of Prelude) + } + deriving (Data) + type instance XXImportDecl (GhcPass _) = DataConCantHappen type instance Anno ModuleName = SrcSpanAnnA type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnL +deriving instance Data (IEWrappedName GhcPs) +deriving instance Data (IEWrappedName GhcRn) +deriving instance Data (IEWrappedName GhcTc) + +deriving instance Eq (IEWrappedName GhcPs) +deriving instance Eq (IEWrappedName GhcRn) +deriving instance Eq (IEWrappedName GhcTc) + -- --------------------------------------------------------------------- -- API Annotations types @@ -144,33 +120,36 @@ simpleImportDecl :: ModuleName -> ImportDecl GhcPs simpleImportDecl mn = ImportDecl { - ideclExt = noAnn, - ideclSourceSrc = NoSourceText, - ideclName = noLocA mn, - ideclPkgQual = NoRawPkgQual, - ideclSource = NotBoot, - ideclSafe = False, - ideclImplicit = False, - ideclQualified = NotQualified, - ideclAs = Nothing, - ideclHiding = Nothing + ideclExt = XImportDeclPass noAnn NoSourceText False, + ideclName = noLocA mn, + ideclPkgQual = NoRawPkgQual, + ideclSource = NotBoot, + ideclSafe = False, + ideclQualified = NotQualified, + ideclAs = Nothing, + ideclImportList = Nothing } instance (OutputableBndrId p , Outputable (Anno (IE (GhcPass p))) , Outputable (ImportDeclPkgQual (GhcPass p))) => Outputable (ImportDecl (GhcPass p)) where - ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod' + ppr (ImportDecl { ideclExt = impExt, ideclName = mod' , ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe - , ideclQualified = qual, ideclImplicit = implicit - , ideclAs = as, ideclHiding = spec }) - = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe, + , ideclQualified = qual + , ideclAs = as, ideclImportList = spec }) + = hang (hsep [text "import", ppr_imp impExt from, pp_implicit impExt, pp_safe safe, pp_qual qual False, ppr pkg, ppr mod', pp_qual qual True, pp_as as]) 4 (pp_spec spec) where - pp_implicit False = empty - pp_implicit True = text "(implicit)" + pp_implicit ext = + let implicit = case ghcPass @p of + GhcPs | XImportDeclPass { ideclImplicit = implicit } <- ext -> implicit + GhcRn | XImportDeclPass { ideclImplicit = implicit } <- ext -> implicit + GhcTc -> dataConCantHappen ext + in if implicit then text "(implicit)" + else empty pp_qual QualifiedPre False = text "qualified" -- Prepositive qualifier/prepositive position. pp_qual QualifiedPost True = text "qualified" -- Postpositive qualifier/postpositive position. @@ -184,14 +163,19 @@ pp_as Nothing = empty pp_as (Just a) = text "as" <+> ppr a - ppr_imp IsBoot = case mSrcText of - NoSourceText -> text "{-# SOURCE #-}" - SourceText src -> text src <+> text "#-}" - ppr_imp NotBoot = empty + ppr_imp ext IsBoot = + let mSrcText = case ghcPass @p of + GhcPs | XImportDeclPass { ideclSourceText = mst } <- ext -> mst + GhcRn | XImportDeclPass { ideclSourceText = mst } <- ext -> mst + GhcTc -> dataConCantHappen ext + in case mSrcText of + NoSourceText -> text "{-# SOURCE #-}" + SourceText src -> text src <+> text "#-}" + ppr_imp _ NotBoot = empty pp_spec Nothing = empty - pp_spec (Just (False, (L _ ies))) = ppr_ies ies - pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies + pp_spec (Just (Exactly, (L _ ies))) = ppr_ies ies + pp_spec (Just (EverythingBut, (L _ ies))) = text "hiding" <+> ppr_ies ies ppr_ies [] = text "()" ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')' @@ -204,86 +188,15 @@ ************************************************************************ -} --- | 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. -data IEWrappedName name - = IEName (LocatedN name) -- ^ no extra - | IEPattern EpaLocation (LocatedN name) -- ^ pattern X - | IEType EpaLocation (LocatedN name) -- ^ type (:+:) - deriving (Eq,Data) - --- | Located name with possible adornment --- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnType', --- 'GHC.Parser.Annotation.AnnPattern' -type LIEWrappedName name = LocatedA (IEWrappedName name) --- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - +type instance XIEName (GhcPass _) = NoExtField +type instance XIEPattern (GhcPass _) = EpaLocation +type instance XIEType (GhcPass _) = EpaLocation +type instance XXIEWrappedName (GhcPass _) = DataConCantHappen --- | 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' +type instance Anno (IEWrappedName (GhcPass _)) = SrcSpanAnnA - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation type instance Anno (IE (GhcPass p)) = SrcSpanAnnA --- | Imported or exported entity. -data IE pass - = IEVar (XIEVar pass) (LIEWrappedName (IdP pass)) - -- ^ Imported or Exported Variable - - | IEThingAbs (XIEThingAbs pass) (LIEWrappedName (IdP pass)) - -- ^ Imported or exported Thing with Absent 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' - - -- 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 (IdP pass)) - -- ^ Imported or exported Thing with All imported or exported - -- - -- 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' - - -- 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 (IdP pass)) - IEWildcard - [LIEWrappedName (IdP pass)] - -- ^ Imported or exported Thing With given imported or exported - -- - -- 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 - | IEModuleContents (XIEModuleContents pass) (XRec pass ModuleName) - -- ^ Imported or exported module contents - -- - -- (Export Only) - -- - -- - '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 - | XIE !(XXIE pass) - type instance XIEVar GhcPs = NoExtField type instance XIEVar GhcRn = NoExtField type instance XIEVar GhcTc = NoExtField @@ -307,9 +220,6 @@ type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA --- | Imported or Exported Wildcard -data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) - {- Note [IEThingWith] ~~~~~~~~~~~~~~~~~~ @@ -355,27 +265,27 @@ ieNames (IEDoc {}) = [] ieNames (IEDocNamed {}) = [] -ieWrappedLName :: IEWrappedName name -> LocatedN name -ieWrappedLName (IEName ln) = ln -ieWrappedLName (IEPattern _ ln) = ln -ieWrappedLName (IEType _ ln) = ln +ieWrappedLName :: IEWrappedName (GhcPass p) -> LIdP (GhcPass p) +ieWrappedLName (IEName _ (L l n)) = L l n +ieWrappedLName (IEPattern _ (L l n)) = L l n +ieWrappedLName (IEType _ (L l n)) = L l n -ieWrappedName :: IEWrappedName name -> name +ieWrappedName :: IEWrappedName (GhcPass p) -> IdP (GhcPass p) ieWrappedName = unLoc . ieWrappedLName -lieWrappedName :: LIEWrappedName name -> name +lieWrappedName :: LIEWrappedName (GhcPass p) -> IdP (GhcPass p) lieWrappedName (L _ n) = ieWrappedName n -ieLWrappedName :: LIEWrappedName name -> LocatedN name +ieLWrappedName :: LIEWrappedName (GhcPass p) -> LIdP (GhcPass p) ieLWrappedName (L _ n) = ieWrappedLName n -replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2 -replaceWrappedName (IEName (L l _)) n = IEName (L l n) +replaceWrappedName :: IEWrappedName GhcPs -> IdP GhcRn -> IEWrappedName GhcRn +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) -replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 +replaceLWrappedName :: LIEWrappedName GhcPs -> IdP GhcRn -> LIEWrappedName GhcRn replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') instance OutputableBndrId p => Outputable (IE (GhcPass p)) where @@ -403,18 +313,18 @@ ppr (IEDoc _ doc) = ppr doc ppr (IEDocNamed _ string) = text ("") -instance (HasOccName name) => HasOccName (IEWrappedName name) where +instance (HasOccName (IdP (GhcPass p)), OutputableBndrId p) => HasOccName (IEWrappedName (GhcPass p)) where occName w = occName (ieWrappedName w) -instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where +instance OutputableBndrId p => OutputableBndr (IEWrappedName (GhcPass p)) where pprBndr bs w = pprBndr bs (ieWrappedName w) pprPrefixOcc w = pprPrefixOcc (ieWrappedName w) pprInfixOcc w = pprInfixOcc (ieWrappedName w) -instance (OutputableBndr name) => Outputable (IEWrappedName name) where - ppr (IEName n) = pprPrefixOcc (unLoc n) - ppr (IEPattern _ n) = text "pattern" <+> pprPrefixOcc (unLoc n) - ppr (IEType _ n) = text "type" <+> pprPrefixOcc (unLoc n) +instance OutputableBndrId p => Outputable (IEWrappedName (GhcPass p)) where + ppr (IEName _ (L _ n)) = pprPrefixOcc n + ppr (IEPattern _ (L _ n)) = text "pattern" <+> pprPrefixOcc n + ppr (IEType _ (L _ n)) = text "type" <+> 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 @@ -231,6 +231,16 @@ deriving instance Data (ForeignDecl GhcRn) deriving instance Data (ForeignDecl GhcTc) +-- deriving instance (DataIdLR p p) => Data (ForeignImport p) +deriving instance Data (ForeignImport GhcPs) +deriving instance Data (ForeignImport GhcRn) +deriving instance Data (ForeignImport GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ForeignExport p) +deriving instance Data (ForeignExport GhcPs) +deriving instance Data (ForeignExport GhcRn) +deriving instance Data (ForeignExport GhcTc) + -- deriving instance (DataIdLR p p) => Data (RuleDecls p) deriving instance Data (RuleDecls GhcPs) deriving instance Data (RuleDecls GhcRn) @@ -373,15 +383,12 @@ deriving instance Data (HsMatchContext GhcRn) deriving instance Data (HsMatchContext GhcTc) --- deriving instance (DataIdLR p p) => Data (HsSplice p) -deriving instance Data (HsSplice GhcPs) -deriving instance Data (HsSplice GhcRn) -deriving instance Data (HsSplice GhcTc) +-- 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 (DataIdLR p p) => Data (HsSplicedThing p) -deriving instance Data (HsSplicedThing GhcPs) -deriving instance Data (HsSplicedThing GhcRn) -deriving instance Data (HsSplicedThing GhcTc) +deriving instance Data a => Data (HsUntypedSpliceResult a) -- deriving instance (DataIdLR p p) => Data (HsQuote p) deriving instance Data (HsQuote GhcPs) @@ -395,7 +402,6 @@ deriving instance Data (ArithSeqInfo GhcRn) deriving instance Data (ArithSeqInfo GhcTc) -deriving instance Data RecordUpdTc deriving instance Data CmdTopTc deriving instance Data PendingRnSplice deriving instance Data PendingTcSplice @@ -431,6 +437,10 @@ 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) @@ -479,6 +489,11 @@ deriving instance Data (HsType GhcPs) deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) + +-- 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) diff --git a/GHC/Hs/Lit.hs b/GHC/Hs/Lit.hs --- a/GHC/Hs/Lit.hs +++ b/GHC/Hs/Lit.hs @@ -25,14 +25,15 @@ import {-# SOURCE #-} GHC.Hs.Expr( pprExpr ) -import Language.Haskell.Syntax.Lit - +import GHC.Types.Basic (PprPrec(..), topPrec ) +import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Types.SourceText import GHC.Core.Type import GHC.Utils.Outputable +import GHC.Hs.Extension import Language.Haskell.Syntax.Expr ( HsExpr ) import Language.Haskell.Syntax.Extension -import GHC.Hs.Extension +import Language.Haskell.Syntax.Lit {- ************************************************************************ @@ -103,6 +104,40 @@ overLitType :: HsOverLit GhcTc -> Type overLitType (OverLit OverLitTc{ ol_type = ty } _) = ty +-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal +-- @ol@ needs to be parenthesized under precedence @p@. +hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool +hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv + where + go :: OverLitVal -> Bool + go (HsIntegral x) = p > topPrec && il_neg x + go (HsFractional x) = p > topPrec && fl_neg x + go (HsIsString {}) = False +hsOverLitNeedsParens _ (XOverLit { }) = False + +-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs +-- to be parenthesized under precedence @p@. +-- +-- See Note [Printing of literals in Core] in GHC.Types.Literal +-- for the reasoning. +hsLitNeedsParens :: PprPrec -> HsLit x -> Bool +hsLitNeedsParens p = go + where + go (HsChar {}) = False + go (HsCharPrim {}) = False + go (HsString {}) = False + go (HsStringPrim {}) = False + go (HsInt _ x) = p > topPrec && il_neg x + go (HsIntPrim {}) = False + go (HsWordPrim {}) = False + go (HsInt64Prim {}) = 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 + -- | Convert a literal from one index type to another convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2) convertLit (HsChar a x) = HsChar a x @@ -137,7 +172,7 @@ -- Instance specific to GhcPs, need the SourceText instance Outputable (HsLit (GhcPass p)) where ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) - ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c) + ppr (HsCharPrim st c) = pprWithSourceText st (pprPrimChar c) ppr (HsString st s) = pprWithSourceText st (pprHsString s) ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) ppr (HsInt _ i) @@ -148,12 +183,8 @@ ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) - ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i) - ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w) - -pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc -pp_st_suffix NoSourceText _ doc = doc -pp_st_suffix (SourceText st) suffix _ = text st <> suffix + ppr (HsInt64Prim st i) = pprWithSourceText st (pprPrimInt64 i) + ppr (HsWord64Prim st w) = pprWithSourceText st (pprPrimWord64 w) -- in debug mode, print the expression that it's resolved to, too instance OutputableBndrId p @@ -161,6 +192,11 @@ ppr (OverLit {ol_val=val, ol_ext=ext}) = ppr val <+> (whenPprDebug (parens (pprXOverLit (ghcPass @p) ext))) +instance Outputable OverLitVal where + ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) + ppr (HsFractional f) = ppr f + ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) + -- | pmPprHsLit pretty prints literals and is used when pretty printing pattern -- match warnings. All are printed the same (i.e., without hashes if they are -- primitive and not wrapped in constructors if they are boxed). This happens @@ -181,3 +217,4 @@ pmPprHsLit (HsRat _ f _) = ppr f pmPprHsLit (HsFloatPrim _ f) = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d + diff --git a/GHC/Hs/Pat.hs b/GHC/Hs/Pat.hs --- a/GHC/Hs/Pat.hs +++ b/GHC/Hs/Pat.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} @@ -28,9 +29,11 @@ XXPatGhcTc(..), HsConPatDetails, hsConPatArgs, + HsConPatTyArg(..), HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, + RecFieldsDotDot(..), hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr, @@ -53,7 +56,7 @@ import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Expr ( HsExpr ) -import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprSplice) +import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprUntypedSplice, HsUntypedSpliceResult(..)) -- friends: import GHC.Hs.Binds @@ -78,7 +81,7 @@ import GHC.Types.SrcLoc import GHC.Data.Bag -- collect ev vars from pats import GHC.Data.Maybe -import GHC.Types.Name (Name) +import GHC.Types.Name (Name, dataName) import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt import Data.Data @@ -94,7 +97,7 @@ type instance XLazyPat GhcRn = NoExtField type instance XLazyPat GhcTc = NoExtField -type instance XAsPat GhcPs = EpAnn [AddEpAnn] -- For '@' +type instance XAsPat GhcPs = EpAnnCO type instance XAsPat GhcRn = NoExtField type instance XAsPat GhcTc = NoExtField @@ -137,7 +140,7 @@ -- (= the argument type of the view function), for hsPatType. type instance XSplicePat GhcPs = NoExtField -type instance XSplicePat GhcRn = NoExtField +type instance XSplicePat GhcRn = HsUntypedSpliceResult (Pat GhcRn) -- See Note [Lifecycle of a splice] in GHC.Hs.Expr type instance XSplicePat GhcTc = DataConCantHappen type instance XLitPat (GhcPass _) = NoExtField @@ -259,6 +262,24 @@ ************************************************************************ -} +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) + => Outputable (HsRecFields p arg) where + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) + = braces (fsep (punctuate comma (map ppr flds))) + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> RecFieldsDotDot n) }) + = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) + where + dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) + +instance (Outputable p, OutputableBndr p, Outputable arg) + => Outputable (HsFieldBind p arg) where + ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg, + hfbPun = pun }) + = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg) + instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where ppr = pprPat @@ -307,7 +328,7 @@ 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) @@ -319,15 +340,20 @@ GhcPs -> ppr n GhcRn -> ppr n GhcTc -> ppr n -pprPat (SplicePat _ splice) = pprSplice splice +pprPat (SplicePat ext splice) = + case ghcPass @p of + GhcPs -> pprUntypedSplice True Nothing splice + GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) splice + GhcRn | HsUntypedSpliceTop _ p <- ext -> ppr p + GhcTc -> dataConCantHappen ext pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (ListPat _ pats) = brackets (interpp'SP pats) pprPat (TuplePat _ pats bx) -- Special-case unary boxed tuples so that they are pretty-printed as - -- `Solo x`, not `(x)` + -- `MkSolo x`, not `(x)` | [pat] <- pats , Boxed <- bx - = hcat [text (mkTupleStr Boxed 1), pprParendLPat appPrec pat] + = hcat [text (mkTupleStr Boxed dataName 1), pprParendLPat appPrec pat] | otherwise = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats) pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity) @@ -377,7 +403,7 @@ Outputable (Anno (IdGhcP p))) => HsConPatDetails (GhcPass p) -> SDoc pprConArgs (PrefixCon ts pats) = fsep (pprTyArgs ts : map (pprParendLPat appPrec) pats) - where pprTyArgs tyargs = fsep (map (\ty -> char '@' <> ppr ty) tyargs) + where pprTyArgs tyargs = fsep (map ppr tyargs) pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 , pprParendLPat appPrec p2 ] pprConArgs (RecCon rpats) = ppr rpats @@ -470,7 +496,7 @@ looksLazyPat :: Pat (GhcPass p) -> Bool looksLazyPat (ParPat _ _ p _) = looksLazyLPat p -looksLazyPat (AsPat _ _ p) = looksLazyLPat p +looksLazyPat (AsPat _ _ _ p) = looksLazyLPat p looksLazyPat (BangPat {}) = False looksLazyPat (VarPat {}) = False looksLazyPat (WildPat {}) = False @@ -537,7 +563,7 @@ | otherwise = True go (BangPat _ pat) = goL pat go (ParPat _ _ pat _) = goL pat - go (AsPat _ _ pat) = goL pat + go (AsPat _ _ _ pat) = goL pat go (ViewPat _ _ pat) = goL pat go (SigPat _ pat _) = goL pat go (TuplePat _ pats _) = all goL pats @@ -694,7 +720,7 @@ collectEvVarsPat pat = case pat of LazyPat _ p -> collectEvVarsLPat p - AsPat _ _ p -> collectEvVarsLPat p + AsPat _ _ _ p -> collectEvVarsLPat p ParPat _ _ p _ -> collectEvVarsLPat p BangPat _ p -> collectEvVarsLPat p ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps @@ -728,3 +754,4 @@ type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns type instance Anno ConLike = SrcSpanAnnN type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA +type instance Anno RecFieldsDotDot = SrcSpan diff --git a/GHC/Hs/Stats.hs b/GHC/Hs/Stats.hs --- a/GHC/Hs/Stats.hs +++ b/GHC/Hs/Stats.hs @@ -22,7 +22,7 @@ import Data.Char -- | Source Statistics -ppSourceStats :: Bool -> Located HsModule -> SDoc +ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc ppSourceStats short (L _ (HsModule{ hsmodExports = exports, hsmodImports = imports, hsmodDecls = ldecls })) = (if short then hcat else vcat) (map pp_val @@ -122,7 +122,7 @@ import_info :: LImportDecl GhcPs -> (Int, Int, Int, Int, Int, Int, Int) import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual - , ideclAs = as, ideclHiding = spec })) + , ideclAs = as, ideclImportList = spec })) = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) safe_info False = 0 @@ -132,8 +132,8 @@ as_info Nothing = 0 as_info (Just _) = 1 spec_info Nothing = (0,0,0,0,1,0,0) - spec_info (Just (False, _)) = (0,0,0,0,0,1,0) - spec_info (Just (True, _)) = (0,0,0,0,0,0,1) + 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 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 @@ -21,10 +21,10 @@ import GHC.Core.PatSyn import GHC.Core.TyCo.Rep import GHC.Core.Type -import GHC.Core.Utils import GHC.Hs import GHC.Tc.Types.Evidence import GHC.Types.Id +import GHC.Types.Var( VarBndr(..) ) import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -48,7 +48,7 @@ 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 (TuplePat tys _ bx) = mkTupleTy1 bx tys @@ -94,14 +94,14 @@ 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 (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 @@ -116,11 +116,7 @@ hsExprType (HsDo ty _ _) = ty hsExprType (ExplicitList ty _) = mkListTy ty hsExprType (RecordCon con_expr _ _) = hsExprType con_expr -hsExprType e@(RecordUpd (RecordUpdTc { rupd_cons = cons, rupd_out_tys = out_tys }) _ _) = - case cons of - con_like:_ -> conLikeResTy con_like out_tys - [] -> pprPanic "hsExprType: RecordUpdTc with empty rupd_cons" - (ppr e) +hsExprType (RecordUpd v _ _) = dataConCantHappen v hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v hsExprType (ExprWithTySig _ e _) = lhsExprType e @@ -129,13 +125,14 @@ Nothing -> asi_ty where asi_ty = arithSeqInfoType asi -hsExprType (HsTypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty -hsExprType (HsUntypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty -hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE" - (ppr e) - -- Typed splices should have been eliminated during zonking, but we - -- can't use `dataConCantHappen` since they are still present before - -- than in the typechecked AST +hsExprType (HsTypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty +hsExprType (HsUntypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty +hsExprType e@(HsTypedSplice{}) = pprPanic "hsExprType: Unexpected HsTypedSplice" + (ppr e) + -- Typed splices should have been eliminated during zonking, but we + -- can't use `dataConCantHappen` since they are still present before + -- than in the typechecked AST. +hsExprType (HsUntypedSplice ext _) = dataConCantHappen ext hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top hsExprType (HsStatic (_, ty) _s) = ty hsExprType (HsPragE _ _ e) = lhsExprType e @@ -185,9 +182,9 @@ exp_res = hsWrapperType w2 act_res in mkFunctionType m exp_arg exp_res go (WpCast co) = liftPRType $ \_ -> coercionRKind co - go (WpEvLam v) = liftPRType $ mkInvisFunTyMany (idType v) + go (WpEvLam v) = liftPRType $ mkInvisFunTy (idType v) go (WpEvApp _) = liftPRType $ funResultTy - go (WpTyLam tv) = liftPRType $ mkForAllTy tv Inferred + go (WpTyLam tv) = liftPRType $ mkForAllTy (Bndr tv Inferred) go (WpTyApp ta) = \(ty,tas) -> (ty, ta:tas) go (WpLet _) = id go (WpMultCoercion _) = id @@ -196,7 +193,7 @@ lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty matchGroupTcType :: MatchGroupTc -> Type -matchGroupTcType (MatchGroupTc args res) = mkVisFunTys args res +matchGroupTcType (MatchGroupTc args res _) = mkScaledFunTys args res syntaxExprType :: SyntaxExpr GhcTc -> Type syntaxExprType (SyntaxExprTc e _ _) = hsExprType e diff --git a/GHC/Hs/Type.hs b/GHC/Hs/Type.hs --- a/GHC/Hs/Type.hs +++ b/GHC/Hs/Type.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -91,28 +92,32 @@ import Language.Haskell.Syntax.Type -import {-# SOURCE #-} GHC.Hs.Expr ( pprSplice ) +import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) ) import Language.Haskell.Syntax.Extension +import GHC.Core.DataCon( SrcStrictness(..), SrcUnpackedness(..), 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) ) +import GHC.Types.Name( Name, NamedThing(getName), tcName, dataName ) import GHC.Types.Name.Reader ( RdrName ) -import GHC.Types.Var ( VarBndr ) +import GHC.Types.Var ( VarBndr, visArgTypeLike ) import GHC.Core.TyCo.Rep ( Type(..) ) import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr ) import GHC.Core.Ppr ( pprOccWithTick) import GHC.Core.Type +import GHC.Core.Multiplicity( pprArrowWithMultiplicity ) import GHC.Hs.Doc import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Utils.Outputable +import GHC.Utils.Misc (count) import Data.Maybe +import Data.Data (Data) import qualified Data.Semigroup as S @@ -202,10 +207,18 @@ type instance XXHsWildCardBndrs (GhcPass _) _ = DataConCantHappen -type instance XHsPS GhcPs = EpAnn EpaLocation +type instance XHsPS GhcPs = EpAnnCO type instance XHsPS GhcRn = HsPSRn type instance XHsPS GhcTc = HsPSRn +-- | The extension field for 'HsPatSigType', which is only used in the +-- renamer onwards. See @Note [Pattern signature binders and scoping]@. +data HsPSRn = HsPSRn + { hsps_nwcs :: [Name] -- ^ Wildcard names + , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names + } + deriving Data + type instance XXHsPatSigType (GhcPass _) = DataConCantHappen type instance XHsSig (GhcPass _) = NoExtField @@ -251,7 +264,7 @@ mkHsWildCardBndrs x = HsWC { hswc_body = x , hswc_ext = noExtField } -mkHsPatSigType :: EpAnn EpaLocation -> LHsType GhcPs -> HsPatSigType GhcPs +mkHsPatSigType :: EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs mkHsPatSigType ann x = HsPS { hsps_ext = ann , hsps_body = x } @@ -302,7 +315,7 @@ type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives type instance XSpliceTy GhcPs = NoExtField -type instance XSpliceTy GhcRn = NoExtField +type instance XSpliceTy GhcRn = HsUntypedSpliceResult (LHsType GhcRn) type instance XSpliceTy GhcTc = Kind type instance XDocTy (GhcPass _) = EpAnn [AddEpAnn] @@ -326,7 +339,20 @@ type instance XXType (GhcPass _) = 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" +type HsCoreTy = Type +type instance XNumTy (GhcPass _) = SourceText +type instance XStrTy (GhcPass _) = SourceText +type instance XCharTy (GhcPass _) = SourceText +type instance XXTyLit (GhcPass _) = DataConCantHappen + + oneDataConHsTy :: HsType GhcRn oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName) @@ -358,9 +384,9 @@ -- See #18846 pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc -pprHsArrow (HsUnrestrictedArrow _) = arrow -pprHsArrow (HsLinearArrow _) = lollipop -pprHsArrow (HsExplicitMult _ p _) = mulArrow (ppr p) +pprHsArrow (HsUnrestrictedArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left False) +pprHsArrow (HsLinearArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left True) +pprHsArrow (HsExplicitMult _ p _) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p)) type instance XConDeclField (GhcPass _) = EpAnn [AddEpAnn] type instance XXConDeclField (GhcPass _) = DataConCantHappen @@ -532,6 +558,66 @@ -------------------------------- +numVisibleArgs :: [HsArg tm ty] -> Arity +numVisibleArgs = count is_vis + where is_vis (HsValArg _) = True + is_vis _ = False + +-------------------------------- + +-- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@ +-- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix +-- or infix. Examples: +-- +-- @ +-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int] = T \@Bool Int +-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int] = (T \@Bool) Int +-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double] = Char ++ Double +-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering +-- @ +pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty) + => id -> LexicalFixity -> [HsArg tm ty] -> SDoc +pprHsArgsApp thing fixity (argl:argr:args) + | Infix <- fixity + = let pp_op_app = hsep [ ppr_single_hs_arg argl + , pprInfixOcc thing + , ppr_single_hs_arg argr ] in + case args of + [] -> pp_op_app + _ -> ppr_hs_args_prefix_app (parens pp_op_app) args + +pprHsArgsApp thing _fixity args + = ppr_hs_args_prefix_app (pprPrefixOcc thing) args + +-- | 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 +ppr_hs_args_prefix_app acc [] = acc +ppr_hs_args_prefix_app acc (arg:args) = + case arg of + HsValArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args + HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args + HsArgPar{} -> ppr_hs_args_prefix_app (parens acc) args + +-- | 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 +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 +-- allows this to be reachable, so don't fail here. +ppr_single_hs_arg (HsArgPar{}) = empty + +-- | 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 + ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp + +-------------------------------- + -- | Decompose a pattern synonym type signature into its constituent parts. -- -- Note that this function looks through parentheses, so it will work on types @@ -918,6 +1004,42 @@ => Outputable (HsPatSigType (GhcPass p)) where ppr (HsPS { hsps_body = ty }) = ppr ty + +instance (OutputableBndrId p) + => Outputable (HsTyLit (GhcPass p)) where + ppr = ppr_tylit + +instance Outputable HsIPName where + ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters + +instance OutputableBndr HsIPName where + pprBndr _ n = ppr n -- Simple for now + 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 (XRec pass RdrName) => Outputable (FieldOcc pass) 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 (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc 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)) +ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c)) + pprAnonWildCard :: SDoc pprAnonWildCard = char '_' @@ -1007,7 +1129,7 @@ => LHsType (GhcPass p) -> SDoc ppr_mono_lty ty = ppr_mono_ty (unLoc ty) -ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc +ppr_mono_ty :: forall p. (OutputableBndrId p) => HsType (GhcPass p) -> SDoc ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty }) = sep [pprHsForAll tele Nothing, ppr_mono_lty ty] @@ -1023,7 +1145,7 @@ -- `Solo x`, not `(x)` | [ty] <- tys , BoxedTuple <- std_con - = sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty] + = sep [text (mkTupleStr Boxed tcName 1), ppr_mono_lty ty] | otherwise = tupleParens std_con (pprWithCommas ppr tys) where std_con = case con of @@ -1035,15 +1157,20 @@ = ppr_mono_lty ty <+> dcolon <+> ppr kind ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty) ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty) -ppr_mono_ty (HsSpliceTy _ s) = pprSplice s +ppr_mono_ty (HsSpliceTy ext s) = + case ghcPass @p of + GhcPs -> pprUntypedSplice True Nothing s + GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) s + GhcRn | HsUntypedSpliceTop _ t <- ext -> ppr t + GhcTc -> pprUntypedSplice True Nothing s 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) -- Special-case unary boxed tuples so that they are pretty-printed as - -- `'Solo x`, not `'(x)` + -- `'MkSolo x`, not `'(x)` | [ty] <- tys - = quote $ sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty] + = quote $ sep [text (mkTupleStr Boxed dataName 1), ppr_mono_lty ty] | otherwise = quote $ parens (maybeAddSpace tys $ interpp'SP tys) ppr_mono_ty (HsTyLit _ t) = ppr t @@ -1106,7 +1233,7 @@ go_hs_ty (HsSpliceTy{}) = False go_hs_ty (HsExplicitListTy{}) = False -- Special-case unary boxed tuple applications so that they are - -- parenthesized as `Proxy ('Solo x)`, not `Proxy 'Solo x` (#18612) + -- parenthesized as `Proxy ('MkSolo x)`, not `Proxy 'MkSolo x` (#18612) -- See Note [One-tuples] in GHC.Builtin.Types go_hs_ty (HsExplicitTupleTy _ [_]) = p >= appPrec diff --git a/GHC/Hs/Utils.hs b/GHC/Hs/Utils.hs --- a/GHC/Hs/Utils.hs +++ b/GHC/Hs/Utils.hs @@ -55,10 +55,6 @@ mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, mkLocatedList, - -- * Constructing general big tuples - -- $big_tuples - mkChunkified, chunkify, - -- * Bindings mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind, mkPatSynBind, @@ -66,7 +62,7 @@ spanHsLocaLBinds, -- * Literals - mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit, + mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringFS, mkHsStringPrimLit, mkHsCharPrimLit, -- * Patterns @@ -89,10 +85,6 @@ unitRecStmtTc, mkLetStmt, - -- * Template Haskell - mkUntypedSplice, mkTypedSplice, - mkHsQuasiQuote, - -- * Collecting binders isUnliftedHsBind, isBangedHsBind, @@ -113,7 +105,7 @@ lStmtsImplicits, hsValBindsImplicits, lPatImplicits ) where -import GHC.Prelude +import GHC.Prelude hiding (head, init, last, tail) import GHC.Hs.Decls import GHC.Hs.Binds @@ -126,12 +118,16 @@ import GHC.Parser.Annotation import GHC.Tc.Types.Evidence -import GHC.Core.TyCo.Rep -import GHC.Core.Multiplicity ( pattern Many ) -import GHC.Builtin.Types ( unitTy ) -import GHC.Tc.Utils.TcType + +import GHC.Core.Coercion( isReflCo ) +import GHC.Core.Multiplicity ( pattern ManyTy ) import GHC.Core.DataCon import GHC.Core.ConLike +import GHC.Core.Make ( mkChunkified ) +import GHC.Core.Type ( Type, isUnliftedType ) + +import GHC.Builtin.Types ( unitTy ) + import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Set hiding ( unitFV ) @@ -142,17 +138,20 @@ import GHC.Types.SrcLoc import GHC.Types.Fixity import GHC.Types.SourceText + import GHC.Data.FastString import GHC.Data.Bag -import GHC.Settings.Constants import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import Data.Either +import Data.Foldable ( toList ) import Data.Function import Data.List ( partition, deleteBy ) +import Data.List.NonEmpty ( nonEmpty ) +import qualified Data.List.NonEmpty as NE {- ************************************************************************ @@ -200,7 +199,7 @@ unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)] type AnnoBody p body - = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ NoExtField + = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ Origin , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA ) @@ -209,9 +208,8 @@ => Origin -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) -mkMatchGroup origin matches = MG { mg_ext = noExtField - , mg_alts = matches - , mg_origin = origin } +mkMatchGroup origin matches = MG { mg_ext = origin + , mg_alts = matches } mkLamCaseMatchGroup :: AnnoBody p body => Origin @@ -224,8 +222,9 @@ mkLocatedList :: Semigroup a => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2] -mkLocatedList [] = noLocA [] -mkLocatedList ms = L (noAnnSrcSpan $ locA $ combineLocsA (head ms) (last ms)) ms +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) @@ -249,7 +248,7 @@ mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated) mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn -mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e paren_wct) +mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e noHsTok paren_wct) where t_body = hswc_body t paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body } @@ -257,7 +256,7 @@ mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType -mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) +mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) @@ -269,7 +268,7 @@ mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars - <.> mkWpLams dicts) expr + <.> mkWpEvLams dicts) expr -- |A simple case alternative with a single pattern, no binds, no guards; -- pre-typechecking @@ -345,13 +344,17 @@ ~ SrcSpanAnnL) => StmtLR GhcRn GhcRn bodyR emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc)) -mkRecStmt :: (Anno [GenLocated + +mkRecStmt :: forall (idL :: Pass) bodyR. + (Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] ~ SrcSpanAnnL) => EpAnn AnnList -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR +mkRecStmt anns stmts = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR) + { recS_stmts = stmts } mkHsIntegral i = OverLit noExtField (HsIntegral i) @@ -411,7 +414,7 @@ xbstc_boundResultType = unitTy, -- unitTy is a dummy value -- can't panic here: it's forced during zonking - xbstc_boundResultMult = Many, + xbstc_boundResultMult = ManyTy, xbstc_failOp = Nothing }) pat body emptyRecStmt' :: forall idL idR body . @@ -438,7 +441,6 @@ emptyRecStmtName = emptyRecStmt' noExtField emptyRecStmtId = emptyRecStmt' unitRecStmtTc -- a panic might trigger during zonking -mkRecStmt anns stmts = (emptyRecStmt' anns) { recS_stmts = stmts } mkLetStmt :: EpAnn [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b) mkLetStmt anns binds = LetStmt anns binds @@ -449,22 +451,12 @@ mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs mkHsOpApp e1 op e2 = OpApp noAnn e1 (noLocA (HsVar noExtField (noLocA op))) e2 -unqualSplice :: RdrName -unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) - -mkUntypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs -mkUntypedSplice ann hasParen e = HsUntypedSplice ann hasParen unqualSplice e - -mkTypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs -mkTypedSplice ann hasParen e = HsTypedSplice ann hasParen unqualSplice e - -mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs -mkHsQuasiQuote quoter span quote - = HsQuasiQuote noExtField unqualSplice quoter span quote - mkHsString :: String -> HsLit (GhcPass p) mkHsString s = HsString NoSourceText (mkFastString s) +mkHsStringFS :: FastString -> HsLit (GhcPass p) +mkHsStringFS s = HsString NoSourceText s + mkHsStringPrimLit :: FastString -> HsLit (GhcPass p) mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) @@ -670,7 +662,7 @@ mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn mkLHsPatTup [] = noLocA $ TuplePat noExtField [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed +mkLHsPatTup lpats@(lpat:_) = L (getLoc lpat) $ TuplePat noExtField lpats Boxed -- | The Big equivalents for the source tuple expressions mkBigLHsVarTup :: IsSrcSpanAnn p a @@ -689,47 +681,6 @@ mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn mkBigLHsPatTup = mkChunkified mkLHsPatTup --- $big_tuples --- #big_tuples# --- --- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but --- we might conceivably want to build such a massive tuple as part of the --- output of a desugaring stage (notably that for list comprehensions). --- --- We call tuples above this size \"big tuples\", and emulate them by --- creating and pattern matching on >nested< tuples that are expressible --- by GHC. --- --- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects) --- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any --- construction to be big. --- --- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector' --- and 'mkTupleCase' functions to do all your work with tuples you should be --- fine, and not have to worry about the arity limitation at all. - --- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decomposition -mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' - -> [a] -- ^ Possible \"big\" list of things to construct from - -> a -- ^ Constructed thing made possible by recursive decomposition -mkChunkified small_tuple as = mk_big_tuple (chunkify as) - where - -- Each sub-list is short enough to fit in a tuple - mk_big_tuple [as] = small_tuple as - mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) - -chunkify :: [a] -> [[a]] --- ^ Split a list into lists that are small enough to have a corresponding --- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE' --- But there may be more than 'mAX_TUPLE_SIZE' sub-lists -chunkify xs - | n_xs <= mAX_TUPLE_SIZE = [xs] - | otherwise = split xs - where - n_xs = length xs - split [] = [] - split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) - {- ************************************************************************ * * @@ -823,7 +774,7 @@ | otherwise = XPat $ CoPat co_fn p ty mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc -mkHsWrapPatCo co pat ty | isTcReflCo co = pat +mkHsWrapPatCo co pat ty | isReflCo co = pat | otherwise = XPat $ CoPat (mkWpCastN co) pat ty mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc @@ -845,7 +796,7 @@ = FunBind { fun_id = fn , fun_matches = mkMatchGroup origin (noLocA ms) , fun_ext = noExtField - , fun_tick = [] } + } mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn @@ -854,7 +805,7 @@ , fun_matches = mkMatchGroup origin (noLocA ms) , fun_ext = emptyNameSet -- NB: closed -- binding - , fun_tick = [] } + } mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs @@ -877,7 +828,7 @@ -- |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 (FunBind { fun_matches = MG _ matches _ }) +isInfixFunBind (FunBind { fun_matches = MG _ matches }) = any (isInfixMatch . unXRec @id2) (unXRec @id2 matches) isInfixFunBind _ = False @@ -1203,7 +1154,7 @@ 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 ListPat _ pats -> foldr (collect_lpat flag) bndrs pats @@ -1214,9 +1165,7 @@ NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs SigPat _ pat _ -> collect_lpat flag pat bndrs XPat ext -> collectXXPat @p flag ext bndrs - SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)) - -> collect_pat flag pat bndrs - SplicePat _ _ -> bndrs + SplicePat ext _ -> collectXSplicePat @p flag ext bndrs -- See Note [Dictionary binders in ConPatOut] ConPat {pat_args=ps} -> case flag of CollNoDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps) @@ -1242,6 +1191,7 @@ class UnXRec p => CollectPass p where collectXXPat :: CollectFlag p -> XXPat p -> [IdP p] -> [IdP p] collectXXHsBindsLR :: forall pR. XXHsBindsLR p pR -> [IdP p] -> [IdP p] + collectXSplicePat :: CollectFlag p -> XSplicePat p -> [IdP p] -> [IdP p] instance IsPass p => CollectPass (GhcPass p) where collectXXPat flag ext = @@ -1263,7 +1213,14 @@ -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Utils.Zonk + collectXSplicePat flag ext = + case ghcPass @p of + GhcPs -> id + GhcRn | (HsUntypedSpliceTop _ pat) <- ext -> collect_pat flag pat + GhcRn | (HsUntypedSpliceNested _) <- ext -> id + GhcTc -> dataConCantHappen ext + {- Note [Dictionary binders in ConPatOut] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1448,7 +1405,7 @@ => HsDataDefn (GhcPass p) -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) - = hsConDeclsBinders cons + = hsConDeclsBinders (toList cons) -- See Note [Binders in family instances] ------------------- @@ -1475,7 +1432,7 @@ -- 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 } - -> (map (L loc . unLoc) names ++ ns, flds ++ fs) + -> (toList (L loc . unLoc <$> names) ++ ns, flds ++ fs) where (remSeen', flds) = get_flds_gadt remSeen args (ns, fs) = go remSeen' rs @@ -1593,7 +1550,7 @@ 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 (ListPat _ pats) = hs_lpats pats @@ -1618,7 +1575,7 @@ (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<) . unLoc) + maybe True ((i<) . unRecFieldsDotDot . unLoc) (rec_dotdot fs)] err_loc = maybe (getLocA n) getLoc (rec_dotdot fs) diff --git a/GHC/HsToCore.hs b/GHC/HsToCore.hs --- a/GHC/HsToCore.hs +++ b/GHC/HsToCore.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -20,6 +20,9 @@ import GHC.Driver.Session 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 @@ -32,17 +35,20 @@ import GHC.HsToCore.Expr import GHC.HsToCore.Binds import GHC.HsToCore.Foreign.Decl +import GHC.HsToCore.Ticks +import GHC.HsToCore.Breakpoints import GHC.HsToCore.Coverage import GHC.HsToCore.Docs import GHC.Tc.Types -import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances ) +import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceLoad ) import GHC.Tc.Module ( runTcInteractive ) import GHC.Core.Type -import GHC.Core.TyCon ( tyConDataCons ) +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCon ( tyConDataCons ) import GHC.Core -import GHC.Core.FVs ( exprsSomeFreeVarsList ) +import GHC.Core.FVs ( exprsSomeFreeVarsList, exprFreeVars ) import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr ) import GHC.Core.Utils import GHC.Core.Unfold.Make @@ -50,8 +56,7 @@ import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make import GHC.Core.Rules -import GHC.Core.Opt.Monad ( CoreToDo(..) ) -import GHC.Core.Lint ( endPassIO ) +import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) import GHC.Core.Ppr import GHC.Builtin.Names @@ -61,6 +66,7 @@ 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 @@ -91,6 +97,7 @@ import Data.List (partition) import Data.IORef +import Data.Traversable (for) {- ************************************************************************ @@ -139,26 +146,41 @@ = do { let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env + ptc = initPromotionTickContext (hsc_dflags hsc_env) + name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env ; withTiming logger (text "Desugar"<+>brackets (ppr mod)) (const ()) $ do { -- Desugar the program ; let export_set = availsToNameSet exports bcknd = backend dflags - hpcInfo = emptyHpcInfo other_hpc_info - ; (binds_cvr, ds_hpc_info, modBreaks) + ; (binds_cvr, m_tickInfo) <- if not (isHsBootOrSig hsc_src) then addTicksToBinds - (CoverageConfig - { coverageConfig_logger = hsc_logger hsc_env - , coverageConfig_dynFlags = hsc_dflags hsc_env - , coverageConfig_mInterp = hsc_interp hsc_env - }) + (hsc_logger hsc_env) + (initTicksConfig (hsc_dflags hsc_env)) mod mod_loc export_set (typeEnvTyCons type_env) binds - else return (binds, hpcInfo, Nothing) + 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 + + ; ds_hpc_info <- case m_tickInfo of + Just (orig_file2, ticks) + | gopt Opt_Hpc $ hsc_dflags hsc_env + -> do + hashNo <- if gopt Opt_Hpc $ hsc_dflags hsc_env + 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 + ; (msgs, mb_res) <- initDs hsc_env tcg_env $ do { ds_ev_binds <- dsEvBinds ev_binds ; core_prs <- dsTopLHsBinds binds_cvr @@ -191,7 +213,7 @@ -- You might think it doesn't matter, but the simplifier brings all top-level -- things into the in-scope set before simplifying; so we get no unfolding for F#! - ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps + ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugar final_pgm rules_for_imps ; let simpl_opts = initSimpleOpts dflags ; let (ds_binds, ds_rules_for_imps, occ_anald_binds) = simpleOptPgm simpl_opts mod final_pgm rules_for_imps @@ -200,7 +222,7 @@ ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps ) - ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps + ; 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)) @@ -215,8 +237,13 @@ ; safe_mode <- finalSafeMode dflags tcg_env ; (needed_mods, needed_pkgs) <- readIORef (tcg_th_needed_deps tcg_env) - ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names - dep_files merged needed_mods needed_pkgs + ; 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 -- 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 @@ -335,33 +362,28 @@ addExportFlagsAndRules :: Backend -> NameSet -> NameSet -> [CoreRule] -> [(Id, t)] -> [(Id, t)] -addExportFlagsAndRules bcknd exports keep_alive rules prs - = mapFst add_one prs +addExportFlagsAndRules bcknd exports keep_alive rules + = mapFst (addRulesToId rule_base . add_export_flag) + -- addRulesToId: see Note [Attach rules to local ids] + -- NB: the binder might have some existing rules, + -- arising from specialisation pragmas + where - add_one bndr = add_rules name (add_export name bndr) - where - name = idName bndr ---------- Rules -------- - -- See Note [Attach rules to local ids] - -- NB: the binder might have some existing rules, - -- arising from specialisation pragmas - add_rules name bndr - | Just rules <- lookupNameEnv rule_base name - = bndr `addIdSpecialisations` rules - | otherwise - = bndr rule_base = extendRuleBaseList emptyRuleBase rules ---------- Export flag -------- -- See Note [Adding export flags] - add_export name bndr - | dont_discard name = setIdExported bndr + add_export_flag bndr + | dont_discard bndr = setIdExported bndr | otherwise = bndr - dont_discard :: Name -> Bool - dont_discard name = is_exported name + dont_discard :: Id -> Bool + dont_discard bndr = is_exported name || name `elemNameSet` keep_alive + where + name = idName bndr -- In interactive mode, we don't want to discard any top-level -- entities at all (eg. do not inline them away during @@ -371,7 +393,7 @@ -- isExternalName separates the user-defined top-level names from those -- introduced by the type checker. is_exported :: Name -> Bool - is_exported | backendRetainsAllBindings bcknd = isExternalName + is_exported | backendWantsGlobalBindings bcknd = isExternalName | otherwise = (`elemNameSet` exports) {- @@ -439,7 +461,7 @@ -- Substitute the dict bindings eagerly, -- and take the body apart into a (f args) form ; dflags <- getDynFlags - ; case decomposeRuleLhs dflags bndrs'' lhs'' of { + ; case decomposeRuleLhs dflags bndrs'' lhs'' (exprFreeVars rhs'') of { Left msg -> do { diagnosticDs msg; return Nothing } ; Right (final_bndrs, fn_id, args) -> do @@ -450,27 +472,28 @@ fn_name = idName fn_id simpl_opts = initSimpleOpts dflags final_rhs = simpleOptExpr simpl_opts rhs'' -- De-crap it - rule_name = snd (unLoc name) - final_bndrs_set = mkVarSet final_bndrs - arg_ids = filterOut (`elemVarSet` final_bndrs_set) $ - exprsSomeFreeVarsList isId args - - ; rule <- dsMkUserRule this_mod is_local - rule_name rule_act fn_name final_bndrs args - final_rhs - ; warnRuleShadowing rule_name rule_act fn_id arg_ids + rule_name = unLoc name + rule = mkRule this_mod False is_local rule_name rule_act + fn_name final_bndrs args final_rhs + ; dsWarnOrphanRule rule + ; dsWarnRuleShadowing fn_id rule ; return (Just rule) } } } -warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM () +dsWarnRuleShadowing :: Id -> CoreRule -> DsM () -- See Note [Rules and inlining/other rules] -warnRuleShadowing rule_name rule_act fn_id arg_ids +dsWarnRuleShadowing fn_id + (Rule { ru_name = rule_name, ru_act = rule_act, ru_bndrs = bndrs, ru_args = args}) = do { check False fn_id -- We often have multiple rules for the same Id in a -- module. Maybe we should check that they don't overlap -- but currently we don't ; mapM_ (check True) arg_ids } where + bndrs_set = mkVarSet bndrs + arg_ids = filterOut (`elemVarSet` bndrs_set) $ + exprsSomeFreeVarsList isId args + check check_rules_too lhs_id | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) -- If imported with no unfolding, no worries @@ -486,6 +509,8 @@ = [ rule | rule <- idCoreRules lhs_id , ruleActivation rule `competesWith` rule_act ] +dsWarnRuleShadowing _ _ = return () -- Not expecting built-in rules here + -- See Note [Desugaring coerce as cast] unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr) unfold_coerce bndrs lhs rhs = do @@ -720,11 +745,11 @@ , openAlphaTyVar, openBetaTyVar , x ] $ mkSingleAltCase scrut1 - (mkWildValBinder Many scrut1_ty) + (mkWildValBinder ManyTy scrut1_ty) (DataAlt unsafe_refl_data_con) [rr_cv] $ mkSingleAltCase scrut2 - (mkWildValBinder Many scrut2_ty) + (mkWildValBinder ManyTy scrut2_ty) (DataAlt unsafe_refl_data_con) [ab_cv] $ Var x `mkCast` x_co @@ -761,7 +786,7 @@ info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding' rhs + `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setArityInfo` arity ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar diff --git a/GHC/HsToCore/Arrows.hs b/GHC/HsToCore/Arrows.hs --- a/GHC/HsToCore/Arrows.hs +++ b/GHC/HsToCore/Arrows.hs @@ -2,8 +2,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -87,7 +85,7 @@ where mk_bind (std_name, expr) = do { rhs <- dsExpr expr - ; id <- newSysLocalDs Many (exprType rhs) + ; id <- newSysLocalDs ManyTy (exprType rhs) -- no check needed; these are functions ; return (NonRec id rhs, (std_name, id)) } @@ -136,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 Many a_ty - b_var <- newSysLocalDs Many b_ty - pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty) + a_var <- newSysLocalDs ManyTy a_ty + b_var <- newSysLocalDs ManyTy b_ty + pair_var <- newSysLocalDs ManyTy (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 Many a_ty - b_var <- newSysLocalDs Many b_ty - pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty) + a_var <- newSysLocalDs ManyTy a_ty + b_var <- newSysLocalDs ManyTy b_ty + pair_var <- newSysLocalDs ManyTy (mkCorePairTy a_ty b_ty) return (Lam pair_var (coreCasePair pair_var a_var b_var (Var b_var))) @@ -162,7 +160,7 @@ coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr coreCaseTuple uniqs scrut_var vars body - = mkTupleCase uniqs vars body scrut_var (Var scrut_var) + = mkBigTupleCase uniqs vars body (Var scrut_var) coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body @@ -178,11 +176,20 @@ mkCoreUnitExpr :: CoreExpr mkCoreUnitExpr = mkCoreTup [] -{- -The input is divided into a local environment, which is a flat tuple -(unless it's too big), and a stack, which is a right-nested pair. -In general, the input has the form +{- Note [Environment and stack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The input is divided into +* A local environment, which is a flat tuple (unless it's too big) + The elements of the local environment can be + - of kind Type (for ordinary variables), or + - of kind Constraint (for dictionaries bound by patterns) + +* A stack, which is a right-nested pair. + The elements on the stack are always of kind Type. + +So in general, the input has the form + ((x1,...,xn), (s1,...(sk,())...)) where xi are the environment values, and si the ones on the stack, @@ -225,9 +232,9 @@ -> DsM CoreExpr matchEnvStack env_ids stack_id body = do uniqs <- newUniqueSupply - tup_var <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids) + tup_var <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids) let match_env = coreCaseTuple uniqs tup_var env_ids body - pair_id <- newSysLocalDs Many (mkCorePairTy (idType tup_var) (idType stack_id)) + pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType tup_var) (idType stack_id)) return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env)) ---------------------------------------------- @@ -244,7 +251,7 @@ -> DsM CoreExpr matchEnv env_ids body = do uniqs <- newUniqueSupply - tup_id <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids) + tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids) return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body)) ---------------------------------------------- @@ -259,7 +266,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 Many (mkCorePairTy (idType param_id) (idType tail_id)) + pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType param_id) (idType tail_id)) return (pair_id, coreCasePair pair_id param_id tail_id tail_code) mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc @@ -288,7 +295,7 @@ let env_stk_ty = mkCorePairTy env_ty unitTy let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr fail_expr <- mkFailExpr (ArrowMatchCtxt ProcExpr) env_stk_ty - var <- selectSimpleMatchVarL Many pat + var <- selectSimpleMatchVarL ManyTy pat match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) 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 @@ -337,7 +344,7 @@ (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty core_arrow <- dsLExpr arrow core_arg <- dsLExpr arg - stack_id <- newSysLocalDs Many stack_ty + stack_id <- newSysLocalDs ManyTy stack_ty core_make_arg <- matchEnvStack env_ids stack_id core_arg return (do_premap ids (envStackType env_ids stack_ty) @@ -363,7 +370,7 @@ core_arrow <- dsLExpr arrow core_arg <- dsLExpr arg - stack_id <- newSysLocalDs Many stack_ty + stack_id <- newSysLocalDs ManyTy stack_ty core_make_pair <- matchEnvStack env_ids stack_id (mkCorePairExpr core_arrow core_arg) @@ -390,8 +397,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 Many stack_ty - arg_id <- newSysLocalDs Many arg_ty + stack_id <- newSysLocalDs ManyTy stack_ty + arg_id <- newSysLocalDs ManyTy arg_ty -- push the argument expression onto the stack let stack' = mkCorePairExpr (Var arg_id) (Var stack_id) @@ -436,7 +443,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 Many stack_ty + stack_id <- newSysLocalDs ManyTy stack_ty either_con <- dsLookupTyCon eitherTyConName left_con <- dsLookupDataCon leftDataConName right_con <- dsLookupDataCon rightDataConName @@ -498,10 +505,10 @@ -} dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do - stack_id <- newSysLocalDs Many stack_ty + stack_id <- newSysLocalDs ManyTy stack_ty (match', core_choices) <- dsCases ids local_vars stack_id stack_ty res_ty match - let MG{ mg_ext = MatchGroupTc _ sum_ty } = match' + let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match' in_ty = envStackType env_ids stack_ty core_body <- dsExpr (HsCase noExtField exp match') @@ -540,11 +547,11 @@ -- construct and desugar a case expression with multiple scrutinees (core_body, free_vars, env_ids') <- trimInput \env_ids -> do - stack_id <- newSysLocalDs Many stack_ty' + stack_id <- newSysLocalDs ManyTy stack_ty' (match', core_choices) <- dsCases ids local_vars' stack_id stack_ty' res_ty match - let MG{ mg_ext = MatchGroupTc _ sum_ty } = match' + let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match' in_ty = envStackType env_ids stack_ty' discrims = map nlHsVar arg_ids (discrim_vars, matching_code) @@ -556,8 +563,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 Many) pat_tys - stack_id' <- newSysLocalDs Many stack_ty' + param_ids <- mapM (newSysLocalDs ManyTy) pat_tys + stack_id' <- newSysLocalDs ManyTy stack_ty' -- the expression is built from the inside out, so the actions -- are presented in reverse order @@ -592,7 +599,7 @@ (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack_ty res_ty body - stack_id <- newSysLocalDs Many stack_ty + stack_id <- newSysLocalDs ManyTy 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 @@ -658,7 +665,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 Many stack_ty + stack_id <- newSysLocalDs ManyTy stack_ty trim_code <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id) let @@ -722,8 +729,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 Many) pat_tys - stack_id' <- newSysLocalDs Many stack_ty' + param_ids <- mapM (newSysLocalDs ManyTy) pat_tys + stack_id' <- newSysLocalDs ManyTy stack_ty' -- the expression is built from the inside out, so the actions -- are presented in reverse order @@ -756,8 +763,8 @@ CoreExpr) -- desugared choices dsCases ids local_vars stack_id stack_ty res_ty (MG { mg_alts = L l matches - , mg_ext = MatchGroupTc arg_tys _ - , mg_origin = origin }) = do + , mg_ext = MatchGroupTc arg_tys _ origin + }) = do -- Extract and desugar the leaf commands in the case, building tuple -- expressions that will (after tagging) replace these leaves @@ -805,8 +812,8 @@ Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$> dsExpr (HsLamCase EpAnnNotUsed LamCase (MG { mg_alts = noLocA [] - , mg_ext = MatchGroupTc [Scaled Many void_ty] res_ty - , mg_origin = Generated })) + , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty Generated + })) -- Replace the commands in the case with these tagged tuples, -- yielding a HsExpr Id we can feed to dsExpr. @@ -816,8 +823,8 @@ -- Note that we replace the MatchGroup result type by sum_ty, -- which is the type of matches' return (MG { mg_alts = L l matches' - , mg_ext = MatchGroupTc arg_tys sum_ty - , mg_origin = origin }, + , mg_ext = MatchGroupTc arg_tys sum_ty origin + }, core_choices) {- @@ -847,7 +854,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 Many env_ty + env_var <- newSysLocalDs ManyTy env_ty let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr) return (do_premap ids env_ty @@ -949,7 +956,7 @@ -- projection function -- \ (p, (xs2)) -> (zs) - env_id <- newSysLocalDs Many env_ty2 + env_id <- newSysLocalDs ManyTy env_ty2 uniqs <- newUniqueSupply let after_c_ty = mkCorePairTy pat_ty env_ty2 @@ -957,10 +964,10 @@ body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids) fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty - pat_id <- selectSimpleMatchVarL Many pat + pat_id <- selectSimpleMatchVarL ManyTy pat match_code <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat body_expr fail_expr - pair_id <- newSysLocalDs Many after_c_ty + pair_id <- newSysLocalDs ManyTy after_c_ty let proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code) @@ -1023,7 +1030,7 @@ -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) uniqs <- newUniqueSupply - env2_id <- newSysLocalDs Many env2_ty + env2_id <- newSysLocalDs ManyTy env2_ty let later_ty = mkBigCoreVarTupTy later_ids post_pair_ty = mkCorePairTy later_ty env2_ty @@ -1110,7 +1117,7 @@ -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids) - rec_id <- newSysLocalDs Many rec_ty + rec_id <- newSysLocalDs ManyTy rec_ty let env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set env1_ids = dVarSetElems env1_id_set @@ -1120,7 +1127,7 @@ where selectVar v | v `elemVarSet` rec_id_set - = mkTupleSelector rec_ids v rec_id (Var rec_id) + = mkBigTupleSelector rec_ids v rec_id (Var rec_id) | otherwise = Var v squash_pair_fn <- matchEnvStack env1_ids rec_id core_body diff --git a/GHC/HsToCore/Binds.hs b/GHC/HsToCore/Binds.hs --- a/GHC/HsToCore/Binds.hs +++ b/GHC/HsToCore/Binds.hs @@ -2,8 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -18,14 +16,14 @@ module GHC.HsToCore.Binds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec - , dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule + , dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds + , dsWarnOrphanRule ) where import GHC.Prelude import GHC.Driver.Session -import GHC.Driver.Ppr import GHC.Driver.Config import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Module @@ -54,6 +52,7 @@ 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 ) @@ -73,7 +72,6 @@ import GHC.Data.OrdList import GHC.Data.Graph.Directed import GHC.Data.Bag -import GHC.Data.FastString import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc @@ -81,7 +79,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Trace import Control.Monad @@ -154,8 +151,8 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun , fun_matches = matches - , fun_ext = co_fn - , fun_tick = tick }) + , 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 @@ -185,8 +182,8 @@ return (force_var, [core_binds]) } dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss - , pat_ext = ty - , pat_ticks = (rhs_tick, var_ticks) }) + , 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 @@ -300,7 +297,7 @@ mkLet aux_binds $ tup_expr - ; poly_tup_id <- newSysLocalDs Many (exprType poly_tup_rhs) + ; 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 @@ -311,10 +308,10 @@ , abe_poly = global , abe_mono = local, abe_prags = spec_prags }) -- See Note [AbsBinds wrappers] in "GHC.Hs.Binds" - = do { tup_id <- newSysLocalDs Many tup_ty + = do { tup_id <- newSysLocalDs ManyTy tup_ty ; core_wrap <- dsHsWrapper wrap ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $ - mkTupleSelector all_locals local tup_id $ + 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 @@ -371,7 +368,7 @@ ([],[]) lcls mk_export local = - do global <- newSysLocalDs Many + do global <- newSysLocalDs ManyTy (exprType (mkLams tyvars (mkLams dicts (Var local)))) return (ABE { abe_poly = global , abe_mono = local @@ -391,7 +388,7 @@ 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) + = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding' simpl_opts rhs, rhs) | otherwise = case inlinePragmaSpec inline_prag of @@ -403,19 +400,20 @@ where simpl_opts = initSimpleOpts dflags inline_prag = idInlinePragma gbl_id - inlinable_unf = mkInlinableUnfolding simpl_opts rhs + 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 in the InlineRule takes account of the dictionaries - = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity simpl_opts rhs + -- 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` mkInlineUnfolding simpl_opts rhs, rhs) + (gbl_id `setIdUnfolding` mkInlineUnfoldingNoArity simpl_opts StableUserSrc rhs, rhs) dictArity :: [Var] -> Arity -- Don't count coercion variables in arity @@ -527,7 +525,7 @@ get to do the inlining, which is a Terribly Bad thing given that the user said "inline"! -To avoid this we pre-emptively eta-expand the definition, so that foo +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. @@ -543,7 +541,7 @@ fromT :: T Bool -> Bool { fromT_1 ((TBool b)) = not b } } } -Note the nested AbsBind. The arity for the InlineRule on $cfromT should be +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 @@ -708,7 +706,7 @@ -- , text "spec_co:" <+> ppr spec_co -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ dflags <- getDynFlags - ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of { + ; 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 @@ -716,22 +714,16 @@ ; 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 Many spec_ty -- Specialised binding is toplevel, hence Many. + spec_id = mkLocalId spec_name ManyTy spec_ty -- Specialised binding is toplevel, hence Many. `setInlinePragma` inl_prag `setIdUnfolding` spec_unf - ; rule <- dsMkUserRule this_mod is_local_id - (mkFastString ("SPEC " ++ showPpr dflags poly_name)) - rule_act poly_name - rule_bndrs rule_lhs_args - (mkVarApps (Var spec_id) spec_bndrs) - - ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs) + 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) --- Commented out: see Note [SPECIALISE on INLINE functions] --- ; when (isInlinePragma id_inl) --- (diagnosticDs $ text "SPECIALISE pragma on INLINE function probably won't fire:" --- <+> quotes (ppr poly_name)) + ; dsWarnOrphanRule rule ; return (Just (unitOL (spec_id, spec_rhs), rule)) -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because @@ -774,13 +766,10 @@ | otherwise = spec_prag_act -- Specified by user -dsMkUserRule :: Module -> Bool -> RuleName -> Activation - -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule -dsMkUserRule this_mod is_local name act fn bndrs args rhs = do - let rule = mkRule this_mod False is_local name act fn bndrs args rhs - when (isOrphan (ru_orphan rule)) $ - diagnosticDs (DsOrphanRule rule) - return rule +dsWarnOrphanRule :: CoreRule -> DsM () +dsWarnOrphanRule rule + = when (isOrphan (ru_orphan rule)) $ + diagnosticDs (DsOrphanRule rule) {- Note [SPECIALISE on INLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -844,56 +833,73 @@ -} 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]) +-- 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 - | not (null unbound) -- Check for things unbound on LHS - -- See Note [Unused spec binders] - = Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2) +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] - | Just (fn_id, args) <- decompose fun2 args2 - , let extra_bndrs = mk_extra_bndrs fn_id args - = -- pprTrace "decomposeRuleLhs" (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]) $ - Right (orig_bndrs ++ extra_bndrs, fn_id, args) - | otherwise - = Left (DsRuleLhsTooComplicated orig_lhs lhs2) - where - simpl_opts = initSimpleOpts dflags - lhs1 = drop_dicts orig_lhs - lhs2 = simpleOptExpr simpl_opts lhs1 -- See Note [Simplify rule LHS] - (fun2,args2) = collectArgs lhs2 + | otherwise = case decompose fun2 args2 of + Nothing -> 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) - lhs_fvs = exprFreeVars lhs2 - unbound = filterOut (`elemVarSet` lhs_fvs) orig_bndrs + 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 - -- Add extra tyvar binders: Note [Free tyvars in rule LHS] - -- and extra dict binders: Note [Free dictionaries in rule LHS] - mk_extra_bndrs fn_id args - = scopedSort unbound_tvs ++ unbound_dicts - where - unbound_tvs = [ v | v <- unbound_vars, isTyVar v ] - unbound_dicts = [ mkLocalId (localiseName (idName d)) Many (idType d) - | d <- unbound_vars, isDictId d ] - unbound_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) + 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) @@ -935,12 +941,33 @@ 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] +* extra_dict_bndrs: see Note [Free dictionaries on rule LHS] Note [Free tyvars on rule LHS] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -965,6 +992,9 @@ 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, @@ -986,7 +1016,7 @@ 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 an InlineRule or something, which would be +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. @@ -997,7 +1027,7 @@ --> 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 (Note [Dead spec binders]). + 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. @@ -1105,6 +1135,21 @@ * * ************************************************************************ +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) @@ -1117,9 +1162,7 @@ dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1 ; w2 <- dsHsWrapper c2 ; return (w1 . w2) } - -- See comments on WpFun in GHC.Tc.Types.Evidence for an explanation of what - -- the specification of this clause is -dsHsWrapper (WpFun c1 c2 (Scaled w t1)) +dsHsWrapper (WpFun c1 c2 (Scaled w t1)) -- See Note [Desugaring WpFun] = do { x <- newSysLocalDs w t1 ; w1 <- dsHsWrapper c1 ; w2 <- dsHsWrapper c2 @@ -1208,8 +1251,7 @@ dsEvTypeable ty ev = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable ; let kind = typeKind ty - Just typeable_data_con - = tyConSingleDataCon_maybe tyCl -- "Data constructor" + typeable_data_con = tyConSingleDataCon tyCl -- "Data constructor" -- for Typeable ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a @@ -1266,7 +1308,7 @@ } ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2) - | Just (m,t1,t2) <- splitFunTy_maybe ty + | Just (_af,m,t1,t2) <- splitFunTy_maybe ty = do { e1 <- getRep ev1 t1 ; e2 <- getRep ev2 t2 ; em <- getRep evm m diff --git a/GHC/HsToCore/Breakpoints.hs b/GHC/HsToCore/Breakpoints.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Breakpoints.hs @@ -0,0 +1,54 @@ +module GHC.HsToCore.Breakpoints + ( mkModBreaks + ) where + +import GHC.Prelude + +import qualified GHC.Runtime.Interpreter as GHCi +import GHC.Runtime.Interpreter.Types +import GHCi.RemoteTypes +import GHC.ByteCode.Types +import GHC.Stack.CCS +import GHC.Unit + +import GHC.HsToCore.Ticks (Tick (..)) + +import GHC.Data.SizedSeq +import GHC.Utils.Outputable as Outputable + +import Data.List (intersperse) +import Data.Array + +mkModBreaks :: Interp -> Module -> SizedSeq Tick -> IO ModBreaks +mkModBreaks interp mod extendedMixEntries + = do + let count = fromIntegral $ sizeSS extendedMixEntries + entries = ssElts extendedMixEntries + + breakArray <- GHCi.newBreakArray interp count + ccs <- mkCCSArray interp mod count entries + 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 + } + +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 diff --git a/GHC/HsToCore/Coverage.hs b/GHC/HsToCore/Coverage.hs --- a/GHC/HsToCore/Coverage.hs +++ b/GHC/HsToCore/Coverage.hs @@ -1,1361 +1,132 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -{- -(c) Galois, 2006 -(c) University of Glasgow, 2007 --} - -module GHC.HsToCore.Coverage - ( CoverageConfig (..) - , addTicksToBinds - , hpcInitCode - ) where - -import GHC.Prelude as Prelude - -import GHC.Driver.Session -import GHC.Driver.Backend - -import qualified GHC.Runtime.Interpreter as GHCi -import GHCi.RemoteTypes -import GHC.ByteCode.Types -import GHC.Stack.CCS -import GHC.Hs -import GHC.Unit -import GHC.Cmm.CLabel - -import GHC.Core.Type -import GHC.Core.TyCon - -import GHC.Data.Maybe -import GHC.Data.FastString -import GHC.Data.Bag - -import GHC.Platform - -import GHC.Runtime.Interpreter.Types - -import GHC.Utils.Misc -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic -import GHC.Utils.Monad -import GHC.Utils.Logger - -import GHC.Types.SrcLoc -import GHC.Types.Basic -import GHC.Types.Id -import GHC.Types.Var.Set -import GHC.Types.Name.Set hiding (FreeVars) -import GHC.Types.Name -import GHC.Types.HpcInfo -import GHC.Types.CostCentre -import GHC.Types.CostCentre.State -import GHC.Types.ForeignStubs -import GHC.Types.Tickish - -import Control.Monad -import Data.List (isSuffixOf, intersperse) -import Data.Array -import Data.Time -import System.Directory - -import Trace.Hpc.Mix -import Trace.Hpc.Util - -import qualified Data.ByteString as BS -import Data.Set (Set) -import qualified Data.Set as Set - -{- -************************************************************************ -* * -* The main function: addTicksToBinds -* * -************************************************************************ --} - -data CoverageConfig = CoverageConfig - { coverageConfig_logger :: Logger - - -- FIXME: replace this with the specific fields of DynFlags we care about. - , coverageConfig_dynFlags :: DynFlags - - , coverageConfig_mInterp :: Maybe Interp - } - -addTicksToBinds - :: CoverageConfig - -> Module - -> ModLocation -- ... off the current module - -> NameSet -- Exported Ids. When we call addTicksToBinds, - -- isExportedId doesn't work yet (the desugarer - -- hasn't set it), so we have to work from this set. - -> [TyCon] -- Type constructor in this module - -> LHsBinds GhcTc - -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks) - -addTicksToBinds (CoverageConfig - { coverageConfig_logger = logger - , coverageConfig_dynFlags = dflags - , coverageConfig_mInterp = m_interp - }) - mod mod_loc exports tyCons binds - | let passes = coveragePasses dflags - , not (null passes) - , Just orig_file <- ml_hs_file mod_loc = do - - let orig_file2 = guessSourceFile binds orig_file - - tickPass tickish (binds,st) = - let env = TTE - { fileName = mkFastString orig_file2 - , declPath = [] - , tte_countEntries = gopt Opt_ProfCountEntries dflags - , exports = exports - , inlines = emptyVarSet - , inScope = emptyVarSet - , blackList = Set.fromList $ - mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of - RealSrcSpan l _ -> Just l - UnhelpfulSpan _ -> Nothing) - tyCons - , density = mkDensity tickish dflags - , this_mod = mod - , tickishType = tickish - } - (binds',_,st') = unTM (addTickLHsBinds binds) env st - in (binds', st') - - initState = TT { tickBoxCount = 0 - , mixEntries = [] - , ccIndices = newCostCentreState - } - - (binds1,st) = foldr tickPass (binds, initState) passes - - let tickCount = tickBoxCount st - entries = reverse $ mixEntries st - hashNo <- writeMixEntries dflags mod tickCount entries orig_file2 - modBreaks <- mkModBreaks m_interp dflags mod tickCount entries - - putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell - (pprLHsBinds binds1) - - return (binds1, HpcInfo tickCount hashNo, modBreaks) - - | otherwise = return (binds, emptyHpcInfo False, Nothing) - -guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath -guessSourceFile binds orig_file = - -- Try look for a file generated from a .hsc file to a - -- .hs file, by peeking ahead. - let top_pos = catMaybes $ foldr (\ (L pos _) rest -> - srcSpanFileName_maybe (locA pos) : rest) [] binds - in - case top_pos of - (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name - -> unpackFS file_name - _ -> orig_file - - -mkModBreaks :: Maybe Interp -> DynFlags -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks) -mkModBreaks m_interp dflags mod count entries - | Just interp <- m_interp - , breakpointsEnabled dflags = do - breakArray <- GHCi.newBreakArray interp (length entries) - ccs <- mkCCSArray interp mod count entries - let - locsTicks = listArray (0,count-1) [ span | (span,_,_,_) <- entries ] - varsTicks = listArray (0,count-1) [ vars | (_,_,vars,_) <- entries ] - declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ] - return $ Just $ emptyModBreaks - { modBreaks_flags = breakArray - , modBreaks_locs = locsTicks - , modBreaks_vars = varsTicks - , modBreaks_decls = declsTicks - , modBreaks_ccs = ccs - } - | otherwise = return Nothing - -mkCCSArray - :: Interp -> Module -> Int -> [MixEntry_] - -> 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 (srcspan, decl_path, _, _) = (name, src) - where name = concat (intersperse "." decl_path) - src = renderWithContext defaultSDocContext (ppr srcspan) - - -writeMixEntries - :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int -writeMixEntries dflags mod count entries filename - | not (gopt Opt_Hpc dflags) = return 0 - | otherwise = do - let - hpc_dir = hpcDir dflags - mod_name = moduleNameString (moduleName mod) - - hpc_mod_dir - | moduleUnit mod == mainUnit = hpc_dir - | otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod) - - tabStop = 8 -- counts as a normal char in GHC's - -- location ranges. - - createDirectoryIfMissing True hpc_mod_dir - modTime <- getModificationUTCTime filename - let entries' = [ (hpcPos, box) - | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] - when (entries' `lengthIsNot` count) $ - panic "the number of .mix entries are inconsistent" - let hashNo = mixHash filename modTime tabStop entries' - mixCreate hpc_mod_dir mod_name - $ Mix filename modTime (toHash hashNo) tabStop entries' - return hashNo - - --- ----------------------------------------------------------------------------- --- TickDensity: where to insert ticks - -data TickDensity - = TickForCoverage -- for Hpc - | TickForBreakPoints -- for GHCi - | TickAllFunctions -- for -prof-auto-all - | TickTopFunctions -- for -prof-auto-top - | TickExportedFunctions -- for -prof-auto-exported - | TickCallSites -- for stack tracing - deriving Eq - -mkDensity :: TickishType -> DynFlags -> TickDensity -mkDensity tickish dflags = case tickish of - HpcTicks -> TickForCoverage - SourceNotes -> TickForCoverage - Breakpoints -> TickForBreakPoints - ProfNotes -> - case profAuto dflags of - ProfAutoAll -> TickAllFunctions - ProfAutoTop -> TickTopFunctions - ProfAutoExports -> TickExportedFunctions - ProfAutoCalls -> TickCallSites - _other -> panic "mkDensity" - --- | Decide whether to add a tick to a binding or not. -shouldTickBind :: TickDensity - -> Bool -- top level? - -> Bool -- exported? - -> Bool -- simple pat bind? - -> Bool -- INLINE pragma? - -> Bool - -shouldTickBind density top_lev exported _simple_pat inline - = case density of - TickForBreakPoints -> False - -- we never add breakpoints to simple pattern bindings - -- (there's always a tick on the rhs anyway). - TickAllFunctions -> not inline - TickTopFunctions -> top_lev && not inline - TickExportedFunctions -> exported && not inline - TickForCoverage -> True - TickCallSites -> False - -shouldTickPatBind :: TickDensity -> Bool -> Bool -shouldTickPatBind density top_lev - = case density of - TickForBreakPoints -> False - TickAllFunctions -> True - TickTopFunctions -> top_lev - TickExportedFunctions -> False - TickForCoverage -> False - TickCallSites -> False - --- ----------------------------------------------------------------------------- --- Adding ticks to bindings - -addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc) -addTickLHsBinds = mapBagM addTickLHsBind - -addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) -addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds - , abs_exports = abs_exports - }))) = - withEnv add_exports $ - withEnv add_inlines $ do - binds' <- addTickLHsBinds binds - return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' } - where - -- in AbsBinds, the Id on each binding is not the actual top-level - -- Id that we are defining, they are related by the abs_exports - -- field of AbsBinds. So if we're doing TickExportedFunctions we need - -- to add the local Ids to the set of exported Names so that we know to - -- tick the right bindings. - add_exports env = - env{ exports = exports env `extendNameSetList` - [ idName mid - | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports - , idName pid `elemNameSet` (exports env) ] } - - -- See Note [inline sccs] - add_inlines env = - env{ inlines = inlines env `extendVarSetList` - [ mid - | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports - , isInlinePragma (idInlinePragma pid) ] } - -addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do - let name = getOccString id - decl_path <- getPathEntry - density <- getDensity - - inline_ids <- liftM inlines getEnv - -- See Note [inline sccs] - let inline = isInlinePragma (idInlinePragma id) - || id `elemVarSet` inline_ids - - -- See Note [inline sccs] - tickish <- tickishType `liftM` getEnv - if inline && tickish == ProfNotes then return (L pos funBind) else do - - (fvs, mg) <- - getFreeVars $ - addPathEntry name $ - addTickMatchGroup False (fun_matches funBind) - - blackListed <- isBlackListed (locA pos) - exported_names <- liftM exports getEnv - - -- We don't want to generate code for blacklisted positions - -- We don't want redundant ticks on simple pattern bindings - -- We don't want to tick non-exported bindings in TickExportedFunctions - let simple = isSimplePatBind funBind - toplev = null decl_path - exported = idName id `elemNameSet` exported_names - - tick <- if not blackListed && - shouldTickBind density toplev exported simple inline - then - bindTick density name (locA pos) fvs - else - return Nothing - - let mbCons = maybe Prelude.id (:) - return $ L pos $ funBind { fun_matches = mg - , fun_tick = tick `mbCons` fun_tick funBind } - - where - -- a binding is a simple pattern binding if it is a funbind with - -- zero patterns - isSimplePatBind :: HsBind GhcTc -> Bool - isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 - --- TODO: Revisit this -addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs - , pat_rhs = rhs }))) = do - - let simplePatId = isSimplePat lhs - - -- TODO: better name for rhs's for non-simple patterns? - let name = maybe "(...)" getOccString simplePatId - - (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs - let pat' = pat { pat_rhs = rhs'} - - -- Should create ticks here? - density <- getDensity - decl_path <- getPathEntry - let top_lev = null decl_path - if not (shouldTickPatBind density top_lev) - then return (L pos pat') - else do - - let mbCons = maybe id (:) - - let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat' - - -- Allocate the ticks - - rhs_tick <- bindTick density name (locA pos) fvs - let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks - - patvar_tickss <- case simplePatId of - Just{} -> return initial_patvar_tickss - Nothing -> do - let patvars = map getOccString (collectPatBinders CollNoDictBinders lhs) - patvar_ticks <- mapM (\v -> bindTick density v (locA pos) fvs) patvars - return - (zipWith mbCons patvar_ticks - (initial_patvar_tickss ++ repeat [])) - - return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) } - --- Only internal stuff, not from source, uses VarBind, so we ignore it. -addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind -addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind - -bindTick - :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish) -bindTick density name pos fvs = do - decl_path <- getPathEntry - let - toplev = null decl_path - count_entries = toplev || density == TickAllFunctions - top_only = density /= TickAllFunctions - box_label = if toplev then TopLevelBox [name] - else LocalBox (decl_path ++ [name]) - -- - allocATickBox box_label count_entries top_only pos fvs - - --- Note [inline sccs] --- ~~~~~~~~~~~~~~~~~~ --- The reason not to add ticks to INLINE functions is that this is --- sometimes handy for avoiding adding a tick to a particular function --- (see #6131) --- --- So for now we do not add any ticks to INLINE functions at all. --- --- We used to use isAnyInlinePragma to figure out whether to avoid adding --- ticks for this purpose. However, #12962 indicates that this contradicts --- the documentation on profiling (which only mentions INLINE pragmas). --- So now we're more careful about what we avoid adding ticks to. - --- ----------------------------------------------------------------------------- --- Decorate an LHsExpr with ticks - --- selectively add ticks to interesting expressions -addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExpr e@(L pos e0) = do - d <- getDensity - case d of - TickForBreakPoints | isGoodBreakExpr e0 -> tick_it - TickForCoverage -> tick_it - TickCallSites | isCallSite e0 -> tick_it - _other -> dont_tick_it - where - tick_it = allocTickBox (ExpBox False) False False (locA pos) - $ addTickHsExpr e0 - dont_tick_it = addTickLHsExprNever e - --- Add a tick to an expression which is the RHS of an equation or a binding. --- We always consider these to be breakpoints, unless the expression is a 'let' --- (because the body will definitely have a tick somewhere). ToDo: perhaps --- we should treat 'case' and 'if' the same way? -addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprRHS e@(L pos e0) = do - d <- getDensity - case d of - TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it - | otherwise -> tick_it - TickForCoverage -> tick_it - TickCallSites | isCallSite e0 -> tick_it - _other -> dont_tick_it - where - tick_it = allocTickBox (ExpBox False) False False (locA pos) - $ addTickHsExpr e0 - dont_tick_it = addTickLHsExprNever e - --- The inner expression of an evaluation context: --- let binds in [], ( [] ) --- we never tick these if we're doing HPC, but otherwise --- we treat it like an ordinary expression. -addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprEvalInner e = do - d <- getDensity - case d of - TickForCoverage -> addTickLHsExprNever e - _otherwise -> addTickLHsExpr e - --- | A let body is treated differently from addTickLHsExprEvalInner --- above with TickForBreakPoints, because for breakpoints we always --- want to tick the body, even if it is not a redex. See test --- break012. This gives the user the opportunity to inspect the --- values of the let-bound variables. -addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprLetBody e@(L pos e0) = do - d <- getDensity - case d of - TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it - | otherwise -> tick_it - _other -> addTickLHsExprEvalInner e - where - tick_it = allocTickBox (ExpBox False) False False (locA pos) - $ addTickHsExpr e0 - dont_tick_it = addTickLHsExprNever e - --- version of addTick that does not actually add a tick, --- because the scope of this tick is completely subsumed by --- another. -addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickLHsExprNever (L pos e0) = do - e1 <- addTickHsExpr e0 - return $ L pos e1 - --- General heuristic: expressions which are calls (do not denote --- values) are good break points. -isGoodBreakExpr :: HsExpr GhcTc -> Bool -isGoodBreakExpr e = isCallSite e - -isCallSite :: HsExpr GhcTc -> Bool -isCallSite HsApp{} = True -isCallSite HsAppType{} = True -isCallSite (XExpr (ExpansionExpr (HsExpanded _ 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) - = ifDensity TickForCoverage - (allocTickBox (ExpBox oneOfMany) False False (locA pos) - $ addTickHsExpr e0) - (addTickLHsExpr (L pos e0)) - -addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addBinTickLHsExpr boxLabel (L pos e0) - = ifDensity TickForCoverage - (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0) - (addTickLHsExpr (L pos e0)) - - --- ----------------------------------------------------------------------------- --- Decorate the body of an HsExpr with ticks. --- (Whether to put a tick around the whole expression was already decided, --- in the addTickLHsExpr family of functions.) - -addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) -addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e -addTickHsExpr e@(HsUnboundVar {}) = return e -addTickHsExpr e@(HsRecSel _ (FieldOcc id _)) = do freeVar id; return e - -addTickHsExpr e@(HsIPVar {}) = return e -addTickHsExpr e@(HsOverLit {}) = return e -addTickHsExpr e@(HsOverLabel{}) = return e -addTickHsExpr e@(HsLit {}) = return e -addTickHsExpr (HsLam x mg) = liftM (HsLam x) - (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 ty) = liftM3 HsAppType (return x) - (addTickLHsExprNever e) - (return ty) -addTickHsExpr (OpApp fix e1 e2 e3) = - liftM4 OpApp - (return fix) - (addTickLHsExpr e1) - (addTickLHsExprNever e2) - (addTickLHsExpr e3) -addTickHsExpr (NegApp x e neg) = - liftM2 (NegApp x) - (addTickLHsExpr e) - (addTickSyntaxExpr hpcSrcSpan neg) -addTickHsExpr (HsPar x lpar e rpar) = do - e' <- addTickLHsExprEvalInner e - return (HsPar x lpar e' rpar) -addTickHsExpr (SectionL x e1 e2) = - liftM2 (SectionL x) - (addTickLHsExpr e1) - (addTickLHsExprNever e2) -addTickHsExpr (SectionR x e1 e2) = - liftM2 (SectionR x) - (addTickLHsExprNever e1) - (addTickLHsExpr e2) -addTickHsExpr (ExplicitTuple x es boxity) = - liftM2 (ExplicitTuple x) - (mapM addTickTupArg es) - (return boxity) -addTickHsExpr (ExplicitSum ty tag arity e) = do - e' <- addTickLHsExpr e - return (ExplicitSum ty tag arity e') -addTickHsExpr (HsCase x e mgs) = - liftM2 (HsCase x) - (addTickLHsExpr e) -- not an EvalInner; e might not necessarily - -- be evaluated. - (addTickMatchGroup False mgs) -addTickHsExpr (HsIf x e1 e2 e3) = - liftM3 (HsIf x) - (addBinTickLHsExpr (BinBox CondBinBox) e1) - (addTickLHsExprOptAlt True e2) - (addTickLHsExprOptAlt True e3) -addTickHsExpr (HsMultiIf ty alts) - = do { let isOneOfMany = case alts of [_] -> False; _ -> True - ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts - ; return $ HsMultiIf ty alts' } -addTickHsExpr (HsLet x tkLet binds tkIn e) = - bindLocals (collectLocalBinders CollNoDictBinders 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 -addTickHsExpr (ExplicitList ty es) - = liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es) - -addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e - -addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds }) - = do { rec_binds' <- addTickHsRecordBinds rec_binds - ; return (expr { rcon_flds = rec_binds' }) } - -addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Left 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 }) - = do { e' <- addTickLHsExpr e - ; flds' <- mapM addTickHsRecField flds - ; return (expr { rupd_expr = e', rupd_flds = Right flds' }) } - -addTickHsExpr (ExprWithTySig x e ty) = - liftM3 ExprWithTySig - (return x) - (addTickLHsExprNever e) -- No need to tick the inner expression - -- for expressions with signatures - (return ty) -addTickHsExpr (ArithSeq ty wit arith_seq) = - liftM3 ArithSeq - (return ty) - (addTickWit wit) - (addTickArithSeqInfo arith_seq) - where addTickWit Nothing = return Nothing - addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl - return (Just fl') - -addTickHsExpr (HsPragE x p e) = - liftM (HsPragE x p) (addTickLHsExpr e) -addTickHsExpr e@(HsTypedBracket {}) = return e -addTickHsExpr e@(HsUntypedBracket{}) = return e -addTickHsExpr e@(HsSpliceE {}) = return e -addTickHsExpr e@(HsGetField {}) = return e -addTickHsExpr e@(HsProjection {}) = return e -addTickHsExpr (HsProc x pat cmdtop) = - liftM2 (HsProc x) - (addTickLPat pat) - (liftL (addTickHsCmdTop) cmdtop) -addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) = - liftM (XExpr . WrapExpr . HsWrap w) $ - (addTickHsExpr e) -- Explicitly no tick on inside -addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) = - liftM (XExpr . ExpansionExpr . HsExpanded a) $ - (addTickHsExpr b) - -addTickHsExpr e@(XExpr (ConLikeTc {})) = return e - -- We used to do a freeVar on a pat-syn builder, but actually - -- such builders are never in the inScope env, which - -- doesn't include top level bindings - --- We might encounter existing ticks (multiple Coverage passes) -addTickHsExpr (XExpr (HsTick t e)) = - liftM (XExpr . HsTick t) (addTickLHsExprNever e) -addTickHsExpr (XExpr (HsBinTick t0 t1 e)) = - liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e) - -addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) -addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e - ; return (Present x e') } -addTickTupArg (Missing ty) = return (Missing ty) - - -addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) - -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) -addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do - let isOneOfMany = matchesOneOfMany matches - matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches - return $ mg { mg_alts = L l matches' } - -addTickMatch :: Bool -> Bool -> 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 - return $ match { m_grhss = gRHSs' } - -addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) - -> TM (GRHSs GhcTc (LHsExpr GhcTc)) -addTickGRHSs isOneOfMany isLambda (GRHSs x guarded local_binds) = - bindLocals binders $ do - local_binds' <- addTickHsLocalBinds local_binds - guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded - return $ GRHSs x guarded' local_binds' - where - binders = collectLocalBinders CollNoDictBinders local_binds - -addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) - -> TM (GRHS GhcTc (LHsExpr GhcTc)) -addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do - (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts - (addTickGRHSBody isOneOfMany isLambda expr) - return $ GRHS x stmts' expr' - -addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do - d <- getDensity - case d of - TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr - TickAllFunctions | isLambda -> - addPathEntry "\\" $ - allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $ - addTickHsExpr e0 - _otherwise -> - addTickLHsExprRHS expr - -addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] - -> TM [ExprLStmt GhcTc] -addTickLStmts isGuard stmts = do - (stmts, _) <- addTickLStmts' isGuard stmts (return ()) - return stmts - -addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a - -> TM ([ExprLStmt GhcTc], a) -addTickLStmts' isGuard lstmts res - = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $ - do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts - ; a <- res - ; return (lstmts', a) } - -addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc) - -> TM (Stmt GhcTc (LHsExpr GhcTc)) -addTickStmt _isGuard (LastStmt x e noret ret) = - liftM3 (LastStmt x) - (addTickLHsExpr e) - (pure noret) - (addTickSyntaxExpr hpcSrcSpan ret) -addTickStmt _isGuard (BindStmt xbs pat e) = - liftM4 (\b f -> BindStmt $ XBindStmtTc - { xbstc_bindOp = b - , xbstc_boundResultType = xbstc_boundResultType xbs - , xbstc_boundResultMult = xbstc_boundResultMult xbs - , xbstc_failOp = f - }) - (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs)) - (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs)) - (addTickLPat pat) - (addTickLHsExprRHS e) -addTickStmt isGuard (BodyStmt x e bind' guard') = - liftM3 (BodyStmt x) - (addTick isGuard e) - (addTickSyntaxExpr hpcSrcSpan bind') - (addTickSyntaxExpr hpcSrcSpan guard') -addTickStmt _isGuard (LetStmt x binds) = - liftM (LetStmt x) - (addTickHsLocalBinds binds) -addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = - liftM3 (ParStmt x) - (mapM (addTickStmtAndBinders isGuard) pairs) - (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) mzipExpr)) - (addTickSyntaxExpr hpcSrcSpan bindExpr) -addTickStmt isGuard (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 - , trS_ret = returnExpr, trS_bind = bindExpr - , trS_fmap = liftMExpr }) = do - t_s <- addTickLStmts isGuard stmts - t_y <- fmapMaybeM addTickLHsExprRHS by - t_u <- addTickLHsExprRHS using - t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr - t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr - t_m <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) liftMExpr)) - return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u - , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } - -addTickStmt isGuard stmt@(RecStmt {}) - = do { stmts' <- addTickLStmts isGuard (unLoc $ recS_stmts stmt) - ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) - ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) - ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) - ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret' - , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } - -addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) -addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e - | otherwise = addTickLHsExprRHS e - -addTickApplicativeArg - :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) - -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -addTickApplicativeArg isGuard (op, arg) = - liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) - where - addTickArg (ApplicativeArgOne m_fail pat expr isBody) = - ApplicativeArgOne - <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail - <*> addTickLPat pat - <*> addTickLHsExpr expr - <*> pure isBody - addTickArg (ApplicativeArgMany x stmts ret pat ctxt) = - (ApplicativeArgMany x) - <$> addTickLStmts isGuard stmts - <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret)) - <*> addTickLPat pat - <*> pure ctxt - -addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc - -> TM (ParStmtBlock GhcTc GhcTc) -addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = - liftM3 (ParStmtBlock x) - (addTickLStmts isGuard stmts) - (return ids) - (addTickSyntaxExpr hpcSrcSpan returnExpr) - -addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) -addTickHsLocalBinds (HsValBinds x binds) = - liftM (HsValBinds x) - (addTickHsValBinds binds) -addTickHsLocalBinds (HsIPBinds x binds) = - liftM (HsIPBinds x) - (addTickHsIPBinds binds) -addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x) - -addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) - -> TM (HsValBindsLR GhcTc (GhcPass b)) -addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do - b <- liftM2 NValBinds - (mapM (\ (rec,binds') -> - liftM2 (,) - (return rec) - (addTickLHsBinds binds')) - binds) - (return sigs) - return $ XValBindsLR b -addTickHsValBinds _ = panic "addTickHsValBinds" - -addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) -addTickHsIPBinds (IPBinds dictbinds ipbinds) = - liftM2 IPBinds - (return dictbinds) - (mapM (liftL (addTickIPBind)) ipbinds) - -addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) -addTickIPBind (IPBind x nm e) = - liftM (IPBind x nm) - (addTickLHsExpr e) - --- There is no location here, so we might need to use a context location?? -addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) -addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do - x' <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan pos) x)) - return $ syn { syn_expr = x' } -addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc - --- we do not walk into patterns. -addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) -addTickLPat pat = return pat - -addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc) -addTickHsCmdTop (HsCmdTop x cmd) = - liftM2 HsCmdTop - (return x) - (addTickLHsCmd cmd) - -addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) -addTickLHsCmd (L pos c0) = do - c1 <- addTickHsCmd c0 - return $ L pos c1 - -addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) -addTickHsCmd (HsCmdLam x matchgroup) = - liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup) -addTickHsCmd (HsCmdApp x c e) = - liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e) -{- -addTickHsCmd (OpApp e1 c2 fix c3) = - liftM4 OpApp - (addTickLHsExpr e1) - (addTickLHsCmd c2) - (return fix) - (addTickLHsCmd c3) --} -addTickHsCmd (HsCmdPar x lpar e rpar) = do - e' <- addTickLHsCmd e - return (HsCmdPar x lpar e' rpar) -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 - binds' <- addTickHsLocalBinds binds -- to think about: !patterns. - c' <- addTickLHsCmd c - return (HsCmdLet x tkLet binds' tkIn c') -addTickHsCmd (HsCmdDo srcloc (L l stmts)) - = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) - ; return (HsCmdDo srcloc (L l stmts')) } - -addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = - liftM5 HsCmdArrApp - (return arr_ty) - (addTickLHsExpr e1) - (addTickLHsExpr e2) - (return ty1) - (return lr) -addTickHsCmd (HsCmdArrForm x e f fix cmdtop) = - liftM4 (HsCmdArrForm x) - (addTickLHsExpr e) - (return f) - (return fix) - (mapM (liftL (addTickHsCmdTop)) cmdtop) - -addTickHsCmd (XCmd (HsWrap w cmd)) = - liftM XCmd $ - liftM (HsWrap w) (addTickHsCmd cmd) - --- Others should never happen in a command context. ---addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) - -addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) - -> TM (MatchGroup GhcTc (LHsCmd GhcTc)) -addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do - matches' <- mapM (liftL addTickCmdMatch) matches - 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 - gRHSs' <- addTickCmdGRHSs gRHSs - return $ match { m_grhss = gRHSs' } - -addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) -addTickCmdGRHSs (GRHSs x guarded local_binds) = - bindLocals binders $ do - local_binds' <- addTickHsLocalBinds local_binds - guarded' <- mapM (liftL addTickCmdGRHS) guarded - return $ GRHSs x guarded' local_binds' - where - binders = collectLocalBinders CollNoDictBinders local_binds - -addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) --- The *guards* are *not* Cmds, although the body is --- C.f. addTickGRHS for the BinBox stuff -addTickCmdGRHS (GRHS x stmts cmd) - = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) - stmts (addTickLHsCmd cmd) - ; return $ GRHS x stmts' expr' } - -addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)] - -> TM [LStmt GhcTc (LHsCmd GhcTc)] -addTickLCmdStmts stmts = do - (stmts, _) <- addTickLCmdStmts' stmts (return ()) - return stmts - -addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a - -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a) -addTickLCmdStmts' lstmts res - = bindLocals binders $ do - lstmts' <- mapM (liftL addTickCmdStmt) lstmts - a <- res - return (lstmts', a) - where - binders = collectLStmtsBinders CollNoDictBinders lstmts - -addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) -addTickCmdStmt (BindStmt x pat c) = - liftM2 (BindStmt x) - (addTickLPat pat) - (addTickLHsCmd c) -addTickCmdStmt (LastStmt x c noret ret) = - liftM3 (LastStmt x) - (addTickLHsCmd c) - (pure noret) - (addTickSyntaxExpr hpcSrcSpan ret) -addTickCmdStmt (BodyStmt x c bind' guard') = - liftM3 (BodyStmt x) - (addTickLHsCmd c) - (addTickSyntaxExpr hpcSrcSpan bind') - (addTickSyntaxExpr hpcSrcSpan guard') -addTickCmdStmt (LetStmt x binds) = - liftM (LetStmt x) - (addTickHsLocalBinds binds) -addTickCmdStmt stmt@(RecStmt {}) - = do { stmts' <- addTickLCmdStmts (unLoc $ recS_stmts stmt) - ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) - ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) - ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) - ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret' - , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } -addTickCmdStmt 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) - = do { fields' <- mapM addTickHsRecField fields - ; return (HsRecFields fields' dd) } - -addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc) - -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc)) -addTickHsRecField (L l (HsFieldBind x id expr pun)) - = do { expr' <- addTickLHsExpr expr - ; return (L l (HsFieldBind x id expr' pun)) } - -addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) -addTickArithSeqInfo (From e1) = - liftM From - (addTickLHsExpr e1) -addTickArithSeqInfo (FromThen e1 e2) = - liftM2 FromThen - (addTickLHsExpr e1) - (addTickLHsExpr e2) -addTickArithSeqInfo (FromTo e1 e2) = - liftM2 FromTo - (addTickLHsExpr e1) - (addTickLHsExpr e2) -addTickArithSeqInfo (FromThenTo e1 e2 e3) = - liftM3 FromThenTo - (addTickLHsExpr e1) - (addTickLHsExpr e2) - (addTickLHsExpr e3) - -data TickTransState = TT { tickBoxCount:: !Int - , mixEntries :: [MixEntry_] - , ccIndices :: !CostCentreState - } - -addMixEntry :: MixEntry_ -> TM Int -addMixEntry ent = do - c <- tickBoxCount <$> getState - setState $ \st -> - st { tickBoxCount = c + 1 - , mixEntries = ent : mixEntries st - } - return c - -data TickTransEnv = TTE { fileName :: FastString - , density :: TickDensity - , tte_countEntries :: !Bool - -- ^ Whether the number of times functions are - -- entered should be counted. - , exports :: NameSet - , inlines :: VarSet - , declPath :: [String] - , inScope :: VarSet - , blackList :: Set RealSrcSpan - , this_mod :: Module - , tickishType :: TickishType - } - --- deriving Show - -data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes - deriving (Eq) - -coveragePasses :: DynFlags -> [TickishType] -coveragePasses dflags = - ifa (breakpointsEnabled dflags) Breakpoints $ - ifa (gopt Opt_Hpc dflags) HpcTicks $ - ifa (sccProfilingEnabled dflags && - profAuto dflags /= NoProfAuto) ProfNotes $ - ifa (needSourceNotes dflags) SourceNotes [] - where ifa f x xs | f = x:xs - | otherwise = xs - --- | Should we produce 'Breakpoint' ticks? -breakpointsEnabled :: DynFlags -> Bool -breakpointsEnabled dflags = backend dflags == Interpreter - --- | Tickishs that only make sense when their source code location --- refers to the current file. This might not always be true due to --- LINE pragmas in the code - which would confuse at least HPC. -tickSameFileOnly :: TickishType -> Bool -tickSameFileOnly HpcTicks = True -tickSameFileOnly _other = False - -type FreeVars = OccEnv Id -noFVs :: FreeVars -noFVs = emptyOccEnv - --- Note [freevars] --- ~~~~~~~~~~~~~~~ --- For breakpoints we want to collect the free variables of an --- expression for pinning on the HsTick. We don't want to collect --- *all* free variables though: in particular there's no point pinning --- on free variables that are will otherwise be in scope at the GHCi --- prompt, which means all top-level bindings. Unfortunately detecting --- top-level bindings isn't easy (collectHsBindsBinders on the top-level --- bindings doesn't do it), so we keep track of a set of "in-scope" --- variables in addition to the free variables, and the former is used --- to filter additions to the latter. This gives us complete control --- over what free variables we track. - -newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) } - deriving (Functor) - -- a combination of a state monad (TickTransState) and a writer - -- monad (FreeVars). - -instance Applicative TM where - pure a = TM $ \ _env st -> (a,noFVs,st) - (<*>) = ap - -instance Monad TM where - (TM m) >>= k = TM $ \ env st -> - case m env st of - (r1,fv1,st1) -> - case unTM (k r1) env st1 of - (r2,fv2,st2) -> - (r2, fv1 `plusOccEnv` fv2, st2) - --- | Get the next HPC cost centre index for a given centre name -getCCIndexM :: FastString -> TM CostCentreIndex -getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $ - ccIndices st - in (idx, noFVs, st { ccIndices = is' }) - -getState :: TM TickTransState -getState = TM $ \ _ st -> (st, noFVs, st) - -setState :: (TickTransState -> TickTransState) -> TM () -setState f = TM $ \ _ st -> ((), noFVs, f st) - -getEnv :: TM TickTransEnv -getEnv = TM $ \ env st -> (env, noFVs, st) - -withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a -withEnv f (TM m) = TM $ \ env st -> - case m (f env) st of - (a, fvs, st') -> (a, fvs, st') - -getDensity :: TM TickDensity -getDensity = TM $ \env st -> (density env, noFVs, st) - -ifDensity :: TickDensity -> TM a -> TM a -> TM a -ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el - -getFreeVars :: TM a -> TM (FreeVars, a) -getFreeVars (TM m) - = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st') - -freeVar :: Id -> TM () -freeVar id = TM $ \ env st -> - if id `elemVarSet` inScope env - then ((), unitOccEnv (nameOccName (idName id)) id, st) - else ((), noFVs, st) - -addPathEntry :: String -> TM a -> TM a -addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] }) - -getPathEntry :: TM [String] -getPathEntry = declPath `liftM` getEnv - -getFileName :: TM FastString -getFileName = fileName `liftM` getEnv - -isGoodSrcSpan' :: SrcSpan -> Bool -isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos -isGoodSrcSpan' (UnhelpfulSpan _) = False - -isGoodTickSrcSpan :: SrcSpan -> TM Bool -isGoodTickSrcSpan pos = do - file_name <- getFileName - tickish <- tickishType `liftM` getEnv - let need_same_file = tickSameFileOnly tickish - same_file = Just file_name == srcSpanFileName_maybe pos - return (isGoodSrcSpan' pos && (not need_same_file || same_file)) - -ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a -ifGoodTickSrcSpan pos then_code else_code = do - good <- isGoodTickSrcSpan pos - if good then then_code else else_code - -bindLocals :: [Id] -> TM a -> TM a -bindLocals new_ids (TM m) - = TM $ \ env st -> - case m env{ inScope = inScope env `extendVarSetList` new_ids } st of - (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') - where occs = [ nameOccName (idName id) | id <- new_ids ] - -isBlackListed :: SrcSpan -> TM Bool -isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st) -isBlackListed (UnhelpfulSpan _) = return False - --- the tick application inherits the source position of its --- expression argument to support nested box allocations -allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) - -> TM (LHsExpr GhcTc) -allocTickBox boxLabel countEntries topOnly pos m = - ifGoodTickSrcSpan pos (do - (fvs, e) <- getFreeVars m - env <- getEnv - tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) - return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e)) - ) (do - e <- m - return (L (noAnnSrcSpan pos) e) - ) - --- the tick application inherits the source position of its --- expression argument to support nested box allocations -allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars - -> TM (Maybe CoreTickish) -allocATickBox boxLabel countEntries topOnly pos fvs = - ifGoodTickSrcSpan pos (do - let - mydecl_path = case boxLabel of - TopLevelBox x -> x - LocalBox xs -> xs - _ -> panic "allocATickBox" - tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path - return (Just tickish) - ) (return Nothing) - - -mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String] - -> TM CoreTickish -mkTickish boxLabel countEntries topOnly pos fvs decl_path = do - - let ids = filter (not . mightBeUnliftedType . idType) $ nonDetOccEnvElts fvs - -- unlifted types cause two problems here: - -- * we can't bind them at the GHCi prompt - -- (bindLocalsAtBreakpoint already filters them out), - -- * the simplifier might try to substitute a literal for - -- the Id, and we can't handle that. - - me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel) - - cc_name | topOnly = head decl_path - | otherwise = 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 <- HpcCC <$> getCCIndexM nm - let cc = mkUserCC nm (this_mod env) pos flavour - count = countEntries && tte_countEntries env - return $ ProfNote cc count True{-scopes-} - - Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids - - SourceNotes | RealSrcSpan pos' _ <- pos -> - return $ SourceNote pos' cc_name - - _otherwise -> panic "mkTickish: bad source span!" - - -allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc) - -> TM (LHsExpr GhcTc) -allocBinTickBox boxLabel pos m = do - env <- getEnv - case tickishType env of - HpcTicks -> do e <- liftM (L (noAnnSrcSpan pos)) m - ifGoodTickSrcSpan pos - (mkBinTickBoxHpc boxLabel pos e) - (return e) - _other -> allocTickBox (ExpBox False) False False pos m - -mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc - -> TM (LHsExpr GhcTc) -mkBinTickBoxHpc boxLabel pos e = do - env <- getEnv - binTick <- HsBinTick - <$> addMixEntry (pos,declPath env, [],boxLabel True) - <*> addMixEntry (pos,declPath env, [],boxLabel False) - <*> pure e - tick <- HpcTick (this_mod env) - <$> addMixEntry (pos,declPath env, [],ExpBox False) - let pos' = noAnnSrcSpan pos - return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick)) - -mkHpcPos :: SrcSpan -> HpcPos -mkHpcPos pos@(RealSrcSpan s _) - | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s, - srcSpanStartCol s, - srcSpanEndLine s, - srcSpanEndCol s - 1) - -- the end column of a SrcSpan is one - -- greater than the last column of the - -- span (see SrcLoc), whereas HPC - -- expects to the column range to be - -- inclusive, hence we subtract one above. -mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" - -hpcSrcSpan :: SrcSpan -hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") - -matchesOneOfMany :: [LMatch GhcTc body] -> Bool -matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 - where - matchCount :: LMatch GhcTc body -> Int - matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) - = length grhss - -type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) - --- For the hash value, we hash everything: the file name, --- the timestamp of the original source file, the tab stop, --- and the mix entries. We cheat, and hash the show'd string. --- This hash only has to be hashed at Mix creation time, --- and is for sanity checking only. - -mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int -mixHash file tm tabstop entries = fromIntegral $ hashString - (show $ Mix file tm 0 tabstop entries) - -{- -************************************************************************ -* * -* initialisation -* * -************************************************************************ - -Each module compiled with -fhpc declares an initialisation function of -the form `hpc_init_()`, which is emitted into the _stub.c file -and annotated with __attribute__((constructor)) so that it gets -executed at startup time. - -The function's purpose is to call hs_hpc_module to register this -module with the RTS, and it looks something like this: - -static void hpc_init_Main(void) __attribute__((constructor)); -static void hpc_init_Main(void) -{extern StgWord64 _hpc_tickboxes_Main_hpc[]; - hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} --} - -hpcInitCode :: Platform -> Module -> HpcInfo -> CStub -hpcInitCode _ _ (NoHpcInfo {}) = mempty -hpcInitCode platform this_mod (HpcInfo tickCount hashNo) - = initializerCStub platform fn_name decls body - where - fn_name = mkInitializerStubLabel this_mod "hpc" - decls = text "extern StgWord64 " <> tickboxes <> text "[]" <> semi - body = text "hs_hpc_module" <> - parens (hcat (punctuate comma [ - doubleQuotes full_name_str, - int tickCount, -- really StgWord32 - int hashNo, -- really StgWord32 - tickboxes - ])) <> semi - - tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod) +{- +(c) Galois, 2006 +(c) University of Glasgow, 2007 +-} + +module GHC.HsToCore.Coverage + ( writeMixEntries + , hpcInitCode + ) where + +import GHC.Prelude as Prelude + +import GHC.Unit + +import GHC.HsToCore.Ticks + +import GHC.Platform + +import GHC.Data.FastString +import GHC.Data.SizedSeq + +import GHC.Cmm.CLabel + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Types.ForeignStubs +import GHC.Types.HpcInfo +import GHC.Types.SrcLoc + +import Control.Monad +import Data.Time +import System.Directory + +import Trace.Hpc.Mix +import Trace.Hpc.Util + +import qualified Data.ByteString as BS + +writeMixEntries + :: FilePath -> Module -> SizedSeq Tick -> FilePath -> IO Int +writeMixEntries hpc_dir mod extendedMixEntries filename + = do + let count = fromIntegral $ sizeSS extendedMixEntries + entries = ssElts extendedMixEntries + + mod_name = moduleNameString (moduleName mod) + + hpc_mod_dir + | moduleUnit mod == mainUnit = hpc_dir + | otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod) + + tabStop = 8 -- counts as a normal char in GHC's + -- location ranges. + + createDirectoryIfMissing True hpc_mod_dir + modTime <- getModificationUTCTime filename + let entries' = [ (hpcPos, tick_label t) + | t <- entries, hpcPos <- [mkHpcPos $ tick_loc t] ] + when (entries' `lengthIsNot` count) $ + panic "the number of .mix entries are inconsistent" + let hashNo = mixHash filename modTime tabStop entries' + mixCreate hpc_mod_dir mod_name + $ Mix filename modTime (toHash hashNo) tabStop entries' + return hashNo + +mkHpcPos :: SrcSpan -> HpcPos +mkHpcPos pos@(RealSrcSpan s _) + | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s, + srcSpanStartCol s, + srcSpanEndLine s, + srcSpanEndCol s - 1) + -- the end column of a SrcSpan is one + -- greater than the last column of the + -- span (see SrcLoc), whereas HPC + -- expects to the column range to be + -- inclusive, hence we subtract one above. +mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" + +-- For the hash value, we hash everything: the file name, +-- the timestamp of the original source file, the tab stop, +-- and the mix entries. We cheat, and hash the show'd string. +-- This hash only has to be hashed at Mix creation time, +-- and is for sanity checking only. +mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int +mixHash file tm tabstop entries = fromIntegral $ hashString + (show $ Mix file tm 0 tabstop entries) + +{- +************************************************************************ +* * +* initialisation +* * +************************************************************************ +-} + +{- | Create HPC initialization C code for a module + +Each module compiled with -fhpc declares an initialisation function of +the form `hpc_init_()`, which is emitted into the _stub.c file +and annotated with __attribute__((constructor)) so that it gets +executed at startup time. + +The function's purpose is to call hs_hpc_module to register this +module with the RTS, and it looks something like this: + +> static void hpc_init_Main(void) __attribute__((constructor)); +> static void hpc_init_Main(void) +> { +> extern StgWord64 _hpc_tickboxes_Main_hpc[]; +> hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc); +> } +-} +hpcInitCode :: Platform -> Module -> HpcInfo -> CStub +hpcInitCode _ _ (NoHpcInfo {}) = mempty +hpcInitCode platform this_mod (HpcInfo tickCount hashNo) + = initializerCStub platform fn_name decls body + where + fn_name = mkInitializerStubLabel this_mod (fsLit "hpc") + decls = text "extern StgWord64 " <> tickboxes <> text "[]" <> semi + body = text "hs_hpc_module" <> + parens (hcat (punctuate comma [ + doubleQuotes full_name_str, + int tickCount, -- really StgWord32 + int hashNo, -- really StgWord32 + tickboxes + ])) <> semi + + tickboxes = pprCLabel platform (mkHpcTicksLabel $ this_mod) module_name = hcat (map (text.charToC) $ BS.unpack $ bytesFS (moduleNameFS (moduleName this_mod))) diff --git a/GHC/HsToCore/Docs.hs b/GHC/HsToCore/Docs.hs --- a/GHC/HsToCore/Docs.hs +++ b/GHC/HsToCore/Docs.hs @@ -28,6 +28,7 @@ import Control.Applicative import Control.Monad.IO.Class import Data.Bifunctor (first) +import Data.Foldable (toList) import Data.IntMap (IntMap) import qualified Data.IntMap as IM import Data.Map.Strict (Map) @@ -273,8 +274,8 @@ names _ decl = getMainDeclBinder env decl {- -Note [1]: ---------- +Note [1] +~~~~~~~~ We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried inside them. That should work for normal user-written instances (from looking at GHC sources). We can assume that commented instances are @@ -366,13 +367,13 @@ -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))] dataSubs dd = constrs ++ fields ++ derivs where - cons = map unLoc $ (dd_cons dd) + cons = unLoc <$> dd_cons dd constrs = [ ( unLoc cname , maybeToList $ fmap unLoc $ con_doc c , conArgDocs c) - | c <- cons, cname <- getConNames c ] + | c <- toList cons, cname <- getConNames c ] fields = [ (foExt n, maybeToList $ fmap unLoc doc, IM.empty) - | Just flds <- map getRecConArgs_maybe cons + | Just flds <- toList $ fmap getRecConArgs_maybe cons , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) , (L _ n) <- ns ] derivs = [ (instName, [unLoc doc], IM.empty) @@ -534,7 +535,7 @@ -- | Go through all class declarations and filter their sub-declarations filterClasses :: forall p doc. (IsPass p) => [(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)] -filterClasses = map (first (mapLoc filterClass)) +filterClasses = map (first (fmap filterClass)) where filterClass (TyClD x c@(ClassDecl {})) = TyClD x $ c { tcdSigs = @@ -554,7 +555,7 @@ -> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl] -mkDecls field con = map (mapLoc con) . field +mkDecls field con = map (fmap con) . field -- | 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 @@ -1,4 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage module GHC.HsToCore.Errors.Ppr where @@ -11,6 +15,7 @@ import GHC.Prelude import GHC.Types.Basic (pprRuleName) import GHC.Types.Error +import GHC.Types.Error.Codes ( constructorCode ) import GHC.Types.Id (idType) import GHC.Types.SrcLoc import GHC.Utils.Misc @@ -20,9 +25,11 @@ instance Diagnostic DsMessage where - diagnosticMessage = \case - DsUnknownMessage m - -> diagnosticMessage m + type DiagnosticOpts DsMessage = NoDiagnosticOpts + defaultDiagnosticOpts = NoDiagnosticOpts + diagnosticMessage _ = \case + DsUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m DsEmptyEnumeration -> mkSimpleDecorated $ text "Enumeration is empty" DsIdentitiesFound conv_fn type_of_conv @@ -79,7 +86,7 @@ hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind) DsUselessSpecialiseForClassMethodSelector poly_id -> mkSimpleDecorated $ - text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id) + 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) @@ -111,8 +118,6 @@ | isTyVar b = text "type variable" <+> quotes (ppr b) | isEvVar b = text "constraint" <+> quotes (ppr (varType b)) | otherwise = text "variable" <+> quotes (ppr b) - DsMultipleConForNewtype names - -> mkSimpleDecorated $ text "Multiple constructors for newtype:" <+> pprQuotedList names DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs -> mkSimpleDecorated $ hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ @@ -223,7 +228,6 @@ DsRuleLhsTooComplicated{} -> WarningWithoutFlag DsRuleIgnoredDueToConstructor{} -> WarningWithoutFlag DsRuleBindersNotBound{} -> WarningWithoutFlag - DsMultipleConForNewtype{} -> ErrorWithoutFlag DsLazyPatCantBindVarsOfUnliftedType{} -> ErrorWithoutFlag DsNotYetHandledByTH{} -> ErrorWithoutFlag DsAggregatedViewExpressions{} -> WarningWithoutFlag @@ -235,7 +239,7 @@ DsRuleMightInlineFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing DsAnotherRuleMightFireFirst{} -> WarningWithFlag Opt_WarnInlineRuleShadowing - diagnosticHints = \case + diagnosticHints = \case DsUnknownMessage m -> diagnosticHints m DsEmptyEnumeration -> noHints DsIdentitiesFound{} -> noHints @@ -260,7 +264,6 @@ DsRuleLhsTooComplicated{} -> noHints DsRuleIgnoredDueToConstructor{} -> noHints DsRuleBindersNotBound{} -> noHints - DsMultipleConForNewtype{} -> noHints DsLazyPatCantBindVarsOfUnliftedType{} -> noHints DsNotYetHandledByTH{} -> noHints DsAggregatedViewExpressions{} -> noHints @@ -271,6 +274,8 @@ DsRecBindsNotAllowedForUnliftedTys{} -> noHints DsRuleMightInlineFirst _ lhs_id rule_act -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act] DsAnotherRuleMightFireFirst _ bad_rule _ -> [SuggestAddPhaseToCompetingRule bad_rule] + + diagnosticCode = constructorCode {- Note [Suggest NegativeLiterals] 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,9 +1,9 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} module GHC.HsToCore.Errors.Types where -import Data.Typeable - import GHC.Prelude import GHC.Core (CoreRule, CoreExpr, RuleName) @@ -19,6 +19,8 @@ import GHC.Types.Name (Name) import qualified GHC.LanguageExtensions as LangExt +import GHC.Generics (Generic) + newtype MinBound = MinBound Integer newtype MaxBound = MaxBound Integer type MaxUncoveredPatterns = Int @@ -27,7 +29,7 @@ -- | Diagnostics messages emitted during desugaring. data DsMessage -- | Simply wraps a generic 'Diagnostic' message. - = forall a. (Diagnostic a, Typeable a) => DsUnknownMessage a + = DsUnknownMessage UnknownDiagnostic {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is emitted if an enumeration is empty. @@ -122,8 +124,6 @@ !CoreExpr -- ^ The optimised LHS - | DsMultipleConForNewtype [LocatedN Name] - | DsLazyPatCantBindVarsOfUnliftedType [Var] | DsNotYetHandledByTH !ThRejectionReason @@ -145,6 +145,8 @@ | DsAnotherRuleMightFireFirst !RuleName !RuleName -- the \"bad\" rule !Var + + deriving Generic -- The positional number of the argument for an expression (first, second, third, etc) newtype DsArgNum = DsArgNum Int 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,8 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The University of Glasgow 2006 @@ -32,7 +32,6 @@ import GHC.HsToCore.Errors.Types import GHC.Types.SourceText import GHC.Types.Name -import GHC.Types.Name.Env import GHC.Core.FamInstEnv( topNormaliseType ) import GHC.HsToCore.Quote import GHC.Hs @@ -44,7 +43,6 @@ import GHC.Tc.Utils.Monad import GHC.Core.Type import GHC.Core.TyCo.Rep -import GHC.Core.Multiplicity import GHC.Core import GHC.Core.Utils import GHC.Core.Make @@ -53,14 +51,12 @@ import GHC.Types.CostCentre import GHC.Types.Id import GHC.Types.Id.Make -import GHC.Types.Var.Env 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.Data.Maybe import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc @@ -70,6 +66,7 @@ import GHC.Utils.Panic.Plain import GHC.Core.PatSyn import Control.Monad +import GHC.HsToCore.Ticks (stripTicksTopHsExpr) {- ************************************************************************ @@ -190,8 +187,8 @@ dsUnliftedBind (FunBind { fun_id = L l fun , fun_matches = matches - , fun_ext = co_fn - , fun_tick = tick }) body + , fun_ext = (co_fn, tick) + }) 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 @@ -201,7 +198,7 @@ ; return (bindNonRec fun rhs' body) } dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss - , pat_ext = ty }) body + , pat_ext = (ty, _) }) body = -- let C x# y# = rhs in body -- ==> case rhs of C x# y# -> body do { match_nablas <- pmcGRHSs PatBindGuards grhss @@ -210,7 +207,7 @@ eqn = EqnInfo { eqn_pats = [upat], eqn_orig = FromSource, eqn_rhs = cantFailMatchResult body } - ; var <- selectMatchVar Many upat + ; var <- selectMatchVar ManyTy upat -- `var` will end up in a let binder, so the multiplicity -- doesn't matter. ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body) @@ -284,14 +281,18 @@ 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 - (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))) - neg_expr) + (stripTicksTopHsExpr -> (ts, (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i}))))) + neg_expr) = do { expr' <- putSrcSpanDsA loc $ do { warnAboutOverflowedOverLit + -- See Note [Checking "negative literals"] (lit { ol_val = HsIntegral (negateIntegralLit i) }) ; dsOverLit lit } - ; dsSyntaxExpr neg_expr [expr'] } + ; + ; dsSyntaxExpr neg_expr [mkTicks ts expr'] } dsExpr (NegApp _ expr neg_expr) = do { expr' <- dsLExpr expr @@ -311,6 +312,27 @@ dsExpr e@(HsAppType {}) = dsHsWrapped e {- +Note [Checking "negative literals"] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +As observed in #13257 it's desirable to warn about overflowing negative literals +in some situations where the user thinks they are writing a negative literal (ie -1) +but without `-XNegativeLiterals` enabled. + +This catches cases such as (-1 :: Word8) which overflow, because (negate 1 == 255) but +which we desugar to `negate (fromIntegral 1)`. + +Notice it's crucial we still desugar to the correct (negate (fromIntegral ...)) despite +performing the negation in order to check whether the application of negate will overflow. +For a user written Integer instance we can't predict the interaction of negate and fromIntegral. + +Also note that this works for detecting the right result for `-128 :: Int8`.. which is +in-range for Int8 but the correct result is achieved via two overflows. + +negate (fromIntegral 128 :: Int8) += negate (-128 :: Int8) += -128 :: Int8 + Note [Desugaring vars] ~~~~~~~~~~~~~~~~~~~~~~ In one situation we can get a *coercion* variable in a HsVar, namely @@ -346,7 +368,7 @@ -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make dsExpr (ExplicitSum types alt arity expr) - = mkCoreUbxSum arity alt types <$> dsLExpr expr + = mkCoreUnboxedSum arity alt types <$> dsLExpr expr dsExpr (HsPragE _ prag expr) = ds_prag_expr prag expr @@ -445,12 +467,12 @@ \begin{verbatim} T { op2 = e } ==> - let err = /\a -> recConErr a - T (recConErr t1 "M.hs/230/op1") + let err = /\a -> recConError a + T (recConError t1 "M.hs/230/op1") e - (recConErr t1 "M.hs/230/op3") + (recConError t1 "M.hs/230/op3") \end{verbatim} -@recConErr@ then converts its argument string into a proper message +@recConError@ then converts its argument string into a proper message before printing it as \begin{verbatim} M.hs, line 230: missing field op1 was evaluated @@ -484,270 +506,17 @@ ; return (mkCoreApps con_expr' con_args) } -{- -Record update is a little harder. Suppose we have the decl: -\begin{verbatim} - data T = T1 {op1, op2, op3 :: Int} - | T2 {op4, op2 :: Int} - | T3 -\end{verbatim} -Then we translate as follows: -\begin{verbatim} - r { op2 = e } -===> - let op2 = e in - case r of - T1 op1 _ op3 -> T1 op1 op2 op3 - T2 op4 _ -> T2 op4 op2 - other -> recUpdError "M.hs/230" -\end{verbatim} -It's important that we use the constructor Ids for @T1@, @T2@ etc on the -RHSs, and do not generate a Core constructor application directly, because the constructor -might do some argument-evaluation first; and may have to throw away some -dictionaries. - -Note [Update for GADTs] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data T a b where - MkT :: { foo :: a } -> T a Int - - upd :: T s t -> s -> T s t - upd z y = z { foo = y} - -We need to get this: - $WMkT :: a -> T a Int - MkT :: (b ~# Int) => a -> T a b - - upd = /\s t. \(z::T s t) (y::s) -> - case z of - MkT (co :: t ~# Int) _ -> $WMkT @s y |> T (Refl s) (Sym co) - -Note the final cast - T (Refl s) (Sym co) :: T s Int ~ T s t -which uses co, bound by the GADT match. This is the wrap_co coercion -in wrapped_rhs. How do we produce it? - -* Start with raw materials - tc, the tycon: T - univ_tvs, the universally quantified tyvars of MkT: a,b - NB: these are in 1-1 correspondence with the tyvars of tc - -* Form univ_cos, a coercion for each of tc's args: (Refl s) (Sym co) - We replaced - a by (Refl s) since 's' instantiates 'a' - b by (Sym co) since 'b' is in the data-con's EqSpec - -* Then form the coercion T (Refl s) (Sym co) - -It gets more complicated when data families are involved (#18809). -Consider - data family F x - data instance F (a,b) where - MkF :: { foo :: Int } -> F (Int,b) - - bar :: F (s,t) -> Int -> F (s,t) - bar z y = z { foo = y} - -We have - data R:FPair a b where - MkF :: { foo :: Int } -> R:FPair Int b - - $WMkF :: Int -> F (Int,b) - MkF :: forall a b. (a ~# Int) => Int -> R:FPair a b - - bar :: F (s,t) -> Int -> F (s,t) - bar = /\s t. \(z::F (s,t)) \(y::Int) -> - case z |> co1 of - MkF (co2::s ~# Int) _ -> $WMkF @t y |> co3 - -(Side note: here (z |> co1) is built by typechecking the scrutinee, so -we ignore it here. In general the scrutinee is an arbitrary expression.) - -The question is: what is co3, the cast for the RHS? - co3 :: F (Int,t) ~ F (s,t) -Again, we can construct it using co2, bound by the GADT match. -We do /exactly/ the same as the non-family case up to building -univ_cos. But that gives us - rep_tc: R:FPair - univ_cos: (Sym co2) (Refl t) -But then we use mkTcFamilyTyConAppCo to "lift" this to the coercion -we want, namely - F (Sym co2, Refl t) :: F (Int,t) ~ F (s,t) - --} - -dsExpr RecordUpd { rupd_flds = Right _} = - -- Not possible due to elimination in the renamer. See Note - -- [Handling overloaded and rebindable constructs] - panic "The impossible happened" -dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields - , rupd_ext = RecordUpdTc - { rupd_cons = cons_to_upd - , rupd_in_tys = in_inst_tys - , rupd_out_tys = out_inst_tys - , rupd_wrap = dict_req_wrap }} ) - | null fields - = dsLExpr record_expr - | otherwise - = assertPpr (notNull cons_to_upd) (ppr expr) $ - - do { record_expr' <- dsLExpr record_expr - ; field_binds' <- mapM ds_field fields - ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding - upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds'] - - -- It's important to generate the match with matchWrapper, - -- and the right hand sides with applications of the wrapper Id - -- so that everything works when we are doing fancy unboxing on the - -- constructor arguments. - ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd - ; ([discrim_var], matching_code) - <- matchWrapper RecUpd (Just [record_expr]) -- See Note [Scrutinee in Record updates] - (MG { mg_alts = noLocA alts - , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty - , mg_origin = FromSource - }) - -- FromSource is not strictly right, but we - -- want incomplete pattern-match warnings - - ; return (add_field_binds field_binds' $ - bindNonRec discrim_var record_expr' matching_code) } - where - ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr) - -- Clone the Id in the HsRecField, because its Name is that - -- of the record selector, and we must not make that a local binder - -- else we shadow other uses of the record selector - -- Hence 'lcl_id'. Cf #2735 - ds_field (L _ rec_field) - = do { rhs <- dsLExpr (hfbRHS rec_field) - ; let fld_id = unLoc (hsRecUpdFieldId rec_field) - ; lcl_id <- newSysLocalDs (idMult fld_id) (idType fld_id) - ; return (idName fld_id, lcl_id, rhs) } - - add_field_binds [] expr = expr - add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr) - - -- Awkwardly, for families, the match goes - -- from instance type to family type - (in_ty, out_ty) = - case (head cons_to_upd) of - RealDataCon data_con -> - let tycon = dataConTyCon data_con in - (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys) - PatSynCon pat_syn -> - ( patSynInstResTy pat_syn in_inst_tys - , patSynInstResTy pat_syn out_inst_tys) - mk_alt upd_fld_env con - = do { let (univ_tvs, ex_tvs, eq_spec, - prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con - arg_tys' = map (scaleScaled Many) arg_tys - -- Record updates consume the source record with multiplicity - -- Many. Therefore all the fields need to be scaled thus. - user_tvs = binderVars $ conLikeUserTyVarBinders con - - in_subst :: TCvSubst - in_subst = extendTCvInScopeList (zipTvSubst univ_tvs in_inst_tys) ex_tvs - -- The in_subst clones the universally quantified type - -- variables. It will be used to substitute into types that - -- contain existentials, however, so make sure to extend the - -- in-scope set with ex_tvs (#20278). - - out_tv_env :: TvSubstEnv - out_tv_env = zipTyEnv univ_tvs out_inst_tys - - -- I'm not bothering to clone the ex_tvs - ; eqs_vars <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec)) - ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta) - ; arg_ids <- newSysLocalsDs (substScaledTysUnchecked in_subst arg_tys') - ; let field_labels = conLikeFieldLabels con - val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg - field_labels arg_ids - mk_val_arg fl pat_arg_id - = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - - inst_con = noLocA $ mkHsWrap wrap (mkConLikeTc con) - -- Reconstruct with the WrapId so that unpacking happens - wrap = mkWpEvVarApps theta_vars <.> - dict_req_wrap <.> - mkWpTyApps [ lookupVarEnv out_tv_env tv - `orElse` mkTyVarTy tv - | tv <- user_tvs ] - -- Be sure to use user_tvs (which may be ordered - -- differently than `univ_tvs ++ ex_tvs) above. - -- See Note [DataCon user type variable binders] - -- in GHC.Core.DataCon. - rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args - - -- Tediously wrap the application in a cast - -- Note [Update for GADTs] - wrapped_rhs = - case con of - RealDataCon data_con - | null eq_spec -> rhs - | otherwise -> mkLHsWrap (mkWpCastN wrap_co) rhs - -- This wrap is the punchline: Note [Update for GADTs] - where - rep_tc = dataConTyCon data_con - wrap_co = mkTcFamilyTyConAppCo rep_tc univ_cos - univ_cos = zipWithEqual "dsExpr:upd" mk_univ_co univ_tvs out_inst_tys - - mk_univ_co :: TyVar -- Universal tyvar from the DataCon - -> Type -- Corresponding instantiating type - -> Coercion - mk_univ_co univ_tv inst_ty - = case lookupVarEnv eq_spec_env univ_tv of - Just co -> co - Nothing -> mkTcNomReflCo inst_ty - - eq_spec_env :: VarEnv Coercion - eq_spec_env = mkVarEnv [ (eqSpecTyVar spec, mkTcSymCo (mkTcCoVarCo eqs_var)) - | (spec,eqs_var) <- zipEqual "dsExpr:upd2" eq_spec eqs_vars ] - - -- eq_spec is always null for a PatSynCon - PatSynCon _ -> rhs - - - req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys - - pat = noLocA $ ConPat { pat_con = noLocA con - , pat_args = PrefixCon [] $ map nlVarPat arg_ids - , pat_con_ext = ConPatTc - { cpt_tvs = ex_tvs - , cpt_dicts = eqs_vars ++ theta_vars - , cpt_binds = emptyTcEvBinds - , cpt_arg_tys = in_inst_tys - , cpt_wrap = req_wrap - } - } - ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) } - -{- Note [Scrutinee in Record updates] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider #17783: - - data PartialRec = No - | Yes { a :: Int, b :: Bool } - update No = No - update r@(Yes {}) = r { b = False } - -In the context of pattern-match checking, the occurrence of @r@ in -@r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by -the following desugaring: - - r { b = False } ==> case r of Yes a b -> Yes a False - -Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above. --} +dsExpr (RecordUpd x _ _) = dataConCantHappen x -- Here is where we desugar the Template Haskell brackets and escapes -- Template Haskell stuff -- See Note [The life cycle of a TH quotation] -dsExpr (HsTypedBracket (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps -dsExpr (HsUntypedBracket (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps -dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s) +dsExpr (HsTypedBracket bracket_tc _) = dsBracket bracket_tc +dsExpr (HsUntypedBracket bracket_tc _) = dsBracket bracket_tc +dsExpr (HsTypedSplice _ s) = pprPanic "dsExpr:typed splice" (pprTypedSplice Nothing s) +dsExpr (HsUntypedSplice ext _) = dataConCantHappen ext -- Arrow notation extension dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd @@ -756,20 +525,20 @@ -- HsSyn constructs that just shouldn't be here, because -- the renamer removed them. See GHC.Rename.Expr. -- Note [Handling overloaded and rebindable constructs] -dsExpr (HsOverLabel x _) = dataConCantHappen x -dsExpr (OpApp x _ _ _) = dataConCantHappen x -dsExpr (SectionL x _ _) = dataConCantHappen x -dsExpr (SectionR 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 +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 <- ExprCC <$> getCCIndexDsM nm + flavour <- mkExprCCFlavour <$> getCCIndexDsM nm Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True) <$> dsLExpr expr else dsLExpr expr @@ -822,7 +591,7 @@ At the moment we use a simple heuristic to determine whether build will be fruitful: for small lists we assume the benefits of fusion will be worthwhile; -for long lists we assume that the benefits will be outweighted by the cost of +for long lists we assume that the benefits will be outweighed by the cost of code duplication. This magic length threshold is @maxBuildLength@. Also, fusion won't work at all if rewrite rules are disabled, so we don't use the build-based desugaring in this case. @@ -946,7 +715,7 @@ ; let match_args (pat, fail_op) (vs,body) = putSrcSpanDs (getLocA pat) $ - do { var <- selectSimpleMatchVarL Many 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 @@ -972,10 +741,10 @@ where new_bind_stmt = L loc $ BindStmt XBindStmtTc - { xbstc_bindOp = bind_op + { xbstc_bindOp = bind_op , xbstc_boundResultType = bind_ty - , xbstc_boundResultMult = Many - , xbstc_failOp = Nothing -- Tuple cannot fail + , xbstc_boundResultMult = ManyTy + , xbstc_failOp = Nothing -- Tuple cannot fail } (mkBigLHsPatTupId later_pats) mfix_app @@ -990,8 +759,8 @@ (MG { mg_alts = noLocA [mkSimpleMatch LambdaExpr [mfix_pat] body] - , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty - , mg_origin = Generated }) + , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty Generated + }) mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats body = noLocA $ HsDo body_ty ctx (noLocA (rec_stmts ++ [ret_stmt])) @@ -1026,28 +795,26 @@ = do { builder_id <- dsLookupGlobalId builder_name ; return (if add_void then mkCoreApp (text "dsConLike" <+> ppr ps) - (Var builder_id) (Var voidPrimId) + (Var builder_id) unboxedUnitExpr else Var builder_id) } | otherwise = pprPanic "dsConLike" (ppr ps) -dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr --- This function desugars ConLikeTc +-- | This function desugars 'ConLikeTc': it eta-expands +-- data constructors to make linear types work. +-- -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head --- for what is going on here +dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr dsConLike con tvs tys = do { ds_con <- dsHsConLike con ; ids <- newSysLocalsDs tys - -- newSysLocalDs: /can/ be lev-poly; see + -- 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` drop_stupid ids) } - where - - drop_stupid = dropList (conLikeStupidTheta con) - -- drop_stupid: see Note [Instantiating stupid theta] - -- in GHC.Tc.Gen.Head + `mkVarApps` ids) } {- ************************************************************************ @@ -1101,7 +868,7 @@ = 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 (HsAppType ty (L _ hs_e) _ _) = go (wrap <.> WpTyApp ty) hs_e go wrap (HsVar _ (L _ var)) diff --git a/GHC/HsToCore/Foreign/C.hs b/GHC/HsToCore/Foreign/C.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/C.hs @@ -0,0 +1,632 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Handling of C foreign imports/exports +module GHC.HsToCore.Foreign.C + ( dsCImport + , dsCFExport + , dsCFExportDynamic + ) +where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Tc.Utils.Monad -- temp +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcType + +import GHC.Core +import GHC.Core.Unfold.Make +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Multiplicity + +import GHC.HsToCore.Foreign.Call +import GHC.HsToCore.Foreign.Prim +import GHC.HsToCore.Foreign.Utils +import GHC.HsToCore.Monad +import GHC.HsToCore.Types (ds_next_wrapper_num) + +import GHC.Hs + +import GHC.Types.Id +import GHC.Types.Literal +import GHC.Types.ForeignStubs +import GHC.Types.SourceText +import GHC.Types.Name +import GHC.Types.RepType +import GHC.Types.ForeignCall +import GHC.Types.Basic + +import GHC.Unit.Module + +import GHC.Driver.Session +import GHC.Driver.Config + +import GHC.Cmm.Expr +import GHC.Cmm.Utils + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names + +import GHC.Data.FastString + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Utils.Encoding + +import Data.Maybe +import Data.List (nub) + +dsCFExport:: Id -- Either the exported Id, + -- or the foreign-export-dynamic constructor + -> Coercion -- Coercion between the Haskell type callable + -- from C, and its representation type + -> CLabelString -- The name to export to C land + -> CCallConv + -> Bool -- True => foreign export dynamic + -- so invoke IO action that's hanging off + -- the first argument's stable pointer + -> 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 + let + ty = coercionRKind co + (bndrs, orig_res_ty) = tcSplitPiTys ty + fe_arg_tys' = mapMaybe anonPiTyBinderType_maybe bndrs + -- We must use tcSplits here, because we want to see + -- the (IO t) in the corner of the type! + fe_arg_tys | isDyn = tail fe_arg_tys' + | otherwise = fe_arg_tys' + + -- Look at the result type of the exported function, orig_res_ty + -- If it's IO t, return (t, True) + -- If it's plain t, return (t, False) + (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of + -- The function already returns IO t + Just (_ioTyCon, res_ty) -> (res_ty, True) + -- The function returns t + Nothing -> (orig_res_ty, False) + + dflags <- getDynFlags + return $ + mkFExportCBits dflags ext_name + (if isDyn then Nothing else Just fn_id) + fe_arg_tys res_ty is_IO_res_ty cconv + +dsCImport :: Id + -> Coercion + -> CImportSpec + -> CCallConv + -> Safety + -> Maybe Header + -> DsM ([Binding], CHeader, CStub) +dsCImport id co (CLabel cid) cconv _ _ = do + dflags <- getDynFlags + let ty = coercionLKind co + platform = targetPlatform dflags + fod = case tyConAppTyCon_maybe (dropForAlls ty) of + Just tycon + | tyConUnique tycon == funPtrTyConKey -> + IsFunction + _ -> IsData + (resTy, foRhs) <- resultWrapper ty + assert (fromJust resTy `eqType` addrPrimTy) $ -- typechecker ensures this + let + rhs = foRhs (Lit (LitLabel cid stdcall_info fod)) + rhs' = Cast rhs co + stdcall_info = fun_type_arg_stdcall_info platform cconv ty + in + return ([(id, rhs')], mempty, mempty) + +dsCImport id co (CFunction target) cconv@PrimCallConv safety _ + = dsPrimCall id co (CCall (CCallSpec target cconv safety)) +dsCImport id co (CFunction target) cconv safety mHeader + = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader +dsCImport id co CWrapper cconv _ _ + = dsCFExportDynamic id co cconv + + +{- +@foreign import "wrapper"@ (previously "foreign export dynamic") lets +you dress up Haskell IO actions of some fixed type behind an +externally callable interface (i.e., as a C function pointer). Useful +for callbacks and stuff. + +\begin{verbatim} +type Fun = Bool -> Int -> IO Int +foreign import "wrapper" f :: Fun -> IO (FunPtr Fun) + +-- Haskell-visible constructor, which is generated from the above: +-- SUP: No check for NULL from createAdjustor anymore??? + +f :: Fun -> IO (FunPtr Fun) +f cback = + bindIO (newStablePtr cback) + (\StablePtr sp# -> IO (\s1# -> + case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of + (# s2#, a# #) -> (# s2#, A# a# #))) + +foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun) + +-- and the helper in C: (approximately; see `mkFExportCBits` below) + +f_helper(StablePtr s, HsBool b, HsInt i) +{ + Capability *cap; + cap = rts_lock(); + rts_inCall(&cap, + rts_apply(rts_apply(deRefStablePtr(s), + rts_mkBool(b)), rts_mkInt(i))); + rts_unlock(cap); +} +\end{verbatim} +-} +dsCFExportDynamic :: Id + -> Coercion + -> CCallConv + -> 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 + 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 + 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). + -} + adj_args = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv)) + , Var stbl_value + , Lit (LitLabel fe_nm mb_sz_args 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 + + let io_app = mkLams tvs $ + Lam cback $ + mkApps (Var bindIOId) + [ Type stable_ptr_ty + , Type res_ty + , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] + , Lam stbl_value ccall_adj + ] + + fed = (id `setInlineActivation` NeverActive, Cast io_app co0) + -- Never inline the f.e.d. function, because the litlit + -- might not be in scope in other modules. + + 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 + -- Must have an IO type; hence Just + + +-- | Foreign calls +dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header + -> DsM ([(Id, Expr TyVar)], CHeader, CStub) +dsFCall fn_id co fcall mDeclHeader = do + let + (ty,ty1) = (coercionLKind co, coercionRKind co) + (tv_bndrs, rho) = tcSplitForAllTyVarBinders ty + (arg_tys, io_res_ty) = tcSplitFunTys rho + + let constQual -- provide 'const' qualifier (#22043) + | (_, res_ty1) <- tcSplitFunTys ty1 + , newty <- maybe res_ty1 snd (tcSplitIOType_maybe res_ty1) + , Just (ptr, _) <- splitTyConApp_maybe newty + , tyConName ptr == constPtrConName + = text "const" + | otherwise = empty + + args <- newSysLocalsDs arg_tys -- no FFI representation polymorphism + (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) + + let + work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars + + (ccall_result_ty, res_wrapper) <- boxResult io_res_ty + + ccall_uniq <- newUnique + work_uniq <- newUnique + + (fcall', cDoc) <- + case fcall of + CCall (CCallSpec (StaticTarget _ cName mUnitId isFun) + CApiConv safety) -> + do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv + wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName) + let fcall' = CCall (CCallSpec + (StaticTarget NoSourceText + wrapperName mUnitId + True) + CApiConv safety) + c = includes + $$ fun_proto <+> braces (cRet <> semi) + includes = vcat [ text "#include \"" <> ftext h + <> text "\"" + | Header _ h <- nub headers ] + fun_proto = constQual <+> cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes + cRet + | isVoidRes = cCall + | otherwise = text "return" <+> cCall + cCall + | isFun = ppr cName <> parens argVals + | null arg_tys = ppr cName + | otherwise = panic "dsFCall: Unexpected arguments to FFI value import" + raw_res_ty = case tcSplitIOType_maybe io_res_ty of + Just (_ioTyCon, res_ty) -> res_ty + Nothing -> io_res_ty + isVoidRes = raw_res_ty `eqType` unitTy + (mHeader, cResType) + | isVoidRes = (Nothing, text "void") + | otherwise = toCType raw_res_ty + pprCconv = ccallConvAttribute CApiConv + mHeadersArgTypeList + = [ (header, cType <+> char 'a' <> int n) + | (t, n) <- zip arg_tys [1..] + , let (header, cType) = toCType (scaledThing t) ] + (mHeaders, argTypeList) = unzip mHeadersArgTypeList + argTypes = if null argTypeList + then text "void" + else hsep $ punctuate comma argTypeList + mHeaders' = mDeclHeader : mHeader : mHeaders + headers = catMaybes mHeaders' + argVals = hsep $ punctuate comma + [ char 'a' <> int n + | (_, n) <- zip arg_tys [1..] ] + return (fcall', c) + _ -> + return (fcall, empty) + dflags <- getDynFlags + let + -- Build the worker + worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty) + tvs = map binderVar tv_bndrs + the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty + work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) + work_id = mkSysLocal (fsLit "$wccall") work_uniq ManyTy worker_ty + + -- Build the wrapper + work_app = mkApps (mkVarApps (Var work_id) tvs) val_args + wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers + wrap_rhs = mkLams (tvs ++ args) wrapper_body + wrap_rhs' = Cast wrap_rhs co + simpl_opts = initSimpleOpts dflags + fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts + StableSystemSrc (length args) + wrap_rhs' + + return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] []) + + +toCName :: Id -> String +toCName i = showSDocOneLine defaultSDocContext (pprCode (ppr (idName i))) + +toCType :: Type -> (Maybe Header, SDoc) +toCType = f False + where f voidOK t + -- First, if we have (Ptr t) of (FunPtr t), then we need to + -- convert t to a C type and put a * after it. If we don't + -- know a type for t, then "void" is fine, though. + | Just (ptr, [t']) <- splitTyConApp_maybe t + , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] + = case f True t' of + (mh, cType') -> + (mh, cType' <> char '*') + -- Otherwise, if we have a type constructor application, then + -- see if there is a C type associated with that constructor. + -- Note that we aren't looking through type synonyms or + -- anything, as it may be the synonym that is annotated. + | Just tycon <- tyConAppTyConPicky_maybe t + , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon + = (mHeader, ftext cType) + -- If we don't know a C type for this type, then try looking + -- through one layer of type synonym etc. + | Just t' <- coreView t + = f voidOK t' + -- Handle 'UnliftedFFITypes' argument + | Just tyCon <- tyConAppTyConPicky_maybe t + , isPrimTyCon tyCon + , Just cType <- ppPrimTyConStgType tyCon + = (Nothing, text cType) + + -- Otherwise we don't know the C type. If we are allowing + -- void then return that; otherwise something has gone wrong. + | voidOK = (Nothing, text "void") + | otherwise + = pprPanic "toCType" (ppr t) + +{- +* + +\subsection{Generating @foreign export@ stubs} + +* + +For each @foreign export@ function, a C stub function is generated. +The C stub constructs the application of the exported Haskell function +using the hugs/ghc rts invocation API. +-} + +mkFExportCBits :: DynFlags + -> FastString + -> Maybe Id -- Just==static, Nothing==dynamic + -> [Type] + -> Type + -> Bool -- True <=> returns an IO type + -> CCallConv + -> (CHeader, + CStub, + String, -- the argument reps + Int -- total size of arguments + ) +mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc + = ( header_bits + , CStub body [] [] + , type_string, + sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_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 + ) + where + platform = targetPlatform dflags + + -- list the arguments to the C function + arg_info :: [(SDoc, -- arg name + SDoc, -- C type + Type, -- Haskell type + CmmType)] -- the CmmType + arg_info = [ let stg_type = showStgType ty in + (arg_cname n stg_type, + stg_type, + ty, + typeCmmType platform (getPrimTyOf ty)) + | (ty,n) <- zip arg_htys [1::Int ..] ] + + arg_cname n stg_ty + | libffi = char '*' <> parens (stg_ty <> char '*') <> + text "args" <> brackets (int (n-1)) + | otherwise = char 'a' <> int n + + -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled + libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target + + type_string + -- libffi needs to know the result type too: + | libffi = primTyDescChar platform res_hty : arg_type_string + | otherwise = arg_type_string + + arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info] + -- just the real args + + -- add some auxiliary args; the stable ptr in the wrapper case, and + -- a slot for the dummy return address in the wrapper + ccall case + aug_arg_info + | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info + | otherwise = arg_info + + stable_ptr_arg = + (text "the_stableptr", text "StgStablePtr", undefined, + typeCmmType platform (mkStablePtrPrimTy alphaTy)) + + -- stuff to do with the return type of the C function + res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes + + cResType | res_hty_is_unit = text "void" + | otherwise = showStgType res_hty + + -- when the return type is integral and word-sized or smaller, it + -- must be assigned as type ffi_arg (#3516). To see what type + -- libffi is expecting here, take a look in its own testsuite, e.g. + -- libffi/testsuite/libffi.call/cls_align_ulonglong.c + ffi_cResType + | is_ffi_arg_type = text "ffi_arg" + | otherwise = cResType + where + res_ty_key = getUnique (getName (typeTyCon res_hty)) + is_ffi_arg_type = res_ty_key `notElem` + [floatTyConKey, doubleTyConKey, + int64TyConKey, word64TyConKey] + + -- Now we can cook up the prototype for the exported function. + pprCconv = ccallConvAttribute cc + + header_bits = CHeader (text "extern" <+> fun_proto <> semi) + + fun_args + | null aug_arg_info = text "void" + | otherwise = hsep $ punctuate comma + $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info + + fun_proto + | libffi + = text "void" <+> ftext c_nm <> + parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr") + | otherwise + = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args + + -- the target which will form the root of what we ask rts_inCall to run + the_cfun + = case maybe_target of + Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)" + Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure" + + cap = text "cap" <> comma + + -- the expression we give to rts_inCall + expr_to_run + = foldl' appArg the_cfun arg_info -- NOT aug_arg_info + where + appArg acc (arg_cname, _, arg_hty, _) + = text "rts_apply" + <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname)) + + -- various other bits for inside the fn + declareResult = text "HaskellObj ret;" + declareCResult | res_hty_is_unit = empty + | otherwise = cResType <+> text "cret;" + + assignCResult | res_hty_is_unit = empty + | otherwise = + text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi + + -- an extern decl for the fn being called + extern_decl + = case maybe_target of + Nothing -> empty + Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi + + + -- finally, the whole darn thing + body = + space $$ + extern_decl $$ + fun_proto $$ + vcat + [ lbrace + , text "Capability *cap;" + , declareResult + , declareCResult + , text "cap = rts_lock();" + -- create the application + perform it. + , text "rts_inCall" <> parens ( + char '&' <> cap <> + text "rts_apply" <> parens ( + cap <> + text "(HaskellObj)" + <> (if is_IO_res_ty + then text "runIO_closure" + else text "runNonIO_closure") + <> comma + <> expr_to_run + ) <+> comma + <> text "&ret" + ) <> semi + , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm) + <> comma <> text "cap") <> semi + , assignCResult + , text "rts_unlock(cap);" + , ppUnless res_hty_is_unit $ + if libffi + then char '*' <> parens (ffi_cResType <> char '*') <> + text "resp = cret;" + else text "return cret;" + , rbrace + ] + +mkHObj :: Type -> SDoc +mkHObj t = text "rts_mk" <> showFFIType t + +unpackHObj :: Type -> SDoc +unpackHObj t = text "rts_get" <> showFFIType t + +showStgType :: Type -> SDoc +showStgType t = text "Hs" <> showFFIType t + +showFFIType :: Type -> SDoc +showFFIType t = ftext (occNameFS (getOccName (typeTyCon t))) + +typeTyCon :: Type -> TyCon +typeTyCon ty + | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) + = tc + | otherwise + = pprPanic "GHC.HsToCore.Foreign.C.typeTyCon" (ppr ty) + + +insertRetAddr :: Platform -> CCallConv + -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] +insertRetAddr platform CCallConv args + = case platformArch platform of + ArchX86_64 + | platformOS platform == OSMinGW32 -> + -- On other Windows x86_64 we insert the return address + -- after the 4th argument, because this is the point + -- at which we need to flush a register argument to the stack + -- (See rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 4 args = ret_addr_arg platform : args + go n (arg:args) = arg : go (n+1) args + go _ [] = [] + in go 0 args + | otherwise -> + -- On other x86_64 platforms we insert the return address + -- after the 6th integer argument, because this is the point + -- at which we need to flush a register argument to the stack + -- (See rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 6 args = ret_addr_arg platform : args + go n (arg@(_,_,_,rep):args) + | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args + | otherwise = arg : go n args + go _ [] = [] + in go 0 args + _ -> + ret_addr_arg platform : args +insertRetAddr _ _ args = args + +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 @@ -150,7 +150,7 @@ tc `hasKey` boolTyConKey = do dflags <- getDynFlags let platform = targetPlatform dflags - prim_arg <- newSysLocalDs Many intPrimTy + prim_arg <- newSysLocalDs ManyTy intPrimTy return (Var prim_arg, \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0)) prim_arg @@ -162,8 +162,8 @@ | is_product_type && data_con_arity == 1 = assertPpr (isUnliftedType data_con_arg_ty1) (pprType arg_ty) $ -- Typechecker ensures this - do case_bndr <- newSysLocalDs Many arg_ty - prim_arg <- newSysLocalDs Many data_con_arg_ty1 + do case_bndr <- newSysLocalDs ManyTy arg_ty + prim_arg <- newSysLocalDs ManyTy data_con_arg_ty1 return (Var prim_arg, \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body] ) @@ -177,7 +177,7 @@ isJust maybe_arg3_tycon && (arg3_tycon == byteArrayPrimTyCon || arg3_tycon == mutableByteArrayPrimTyCon) - = do case_bndr <- newSysLocalDs Many arg_ty + = do case_bndr <- newSysLocalDs ManyTy 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] @@ -223,14 +223,11 @@ -- another case, and a coercion.) -- The result is IO t, so wrap the result in an IO constructor = do { res <- resultWrapper io_res_ty - ; let return_result state anss - = mkCoreUbxTup - [realWorldStatePrimTy, io_res_ty] - [state, anss] + ; let return_result state anss = mkCoreUnboxedTuple [state, anss] ; (ccall_res_ty, the_alt) <- mk_alt return_result res - ; state_id <- newSysLocalDs Many realWorldStatePrimTy + ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy ; let io_data_con = head (tyConDataCons io_tycon) toIOCon = dataConWrapId io_data_con @@ -266,7 +263,7 @@ -> DsM (Type, CoreAlt) mk_alt return_result (Nothing, wrap_result) = do -- The ccall returns () - state_id <- newSysLocalDs Many realWorldStatePrimTy + state_id <- newSysLocalDs ManyTy realWorldStatePrimTy let the_rhs = return_result (Var state_id) (wrap_result (panic "boxResult")) @@ -280,8 +277,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 Many prim_res_ty - ; state_id <- newSysLocalDs Many realWorldStatePrimTy + do { result_id <- newSysLocalDs ManyTy prim_res_ty + ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy ; let the_rhs = return_result (Var state_id) (wrap_result (Var result_id)) ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] 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 @@ -2,68 +2,43 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1998 - - -Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call). -} -module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where +-- | Desugaring foreign declarations +module GHC.HsToCore.Foreign.Decl + ( dsForeigns + ) +where import GHC.Prelude +import GHC.Data.FastString import GHC.Tc.Utils.Monad -- temp -import GHC.Core - -import GHC.HsToCore.Foreign.Call +import GHC.HsToCore.Foreign.C +import GHC.HsToCore.Foreign.JavaScript +import GHC.HsToCore.Foreign.Utils import GHC.HsToCore.Monad -import GHC.HsToCore.Types (ds_next_wrapper_num) import GHC.Hs -import GHC.Core.DataCon -import GHC.Core.Unfold.Make import GHC.Types.Id -import GHC.Types.Literal import GHC.Types.ForeignStubs -import GHC.Types.SourceText import GHC.Unit.Module -import GHC.Types.Name -import GHC.Core.Type -import GHC.Types.RepType -import GHC.Core.TyCon import GHC.Core.Coercion -import GHC.Core.Multiplicity -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.TcType -import GHC.Cmm.Expr -import GHC.Cmm.Utils import GHC.Cmm.CLabel -import GHC.Driver.Ppr import GHC.Types.ForeignCall -import GHC.Builtin.Types -import GHC.Builtin.Types.Prim -import GHC.Builtin.Names -import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Utils.Outputable -import GHC.Data.FastString import GHC.Driver.Session -import GHC.Driver.Config import GHC.Platform import GHC.Data.OrdList -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Driver.Hooks -import GHC.Utils.Encoding -import Data.Maybe -import Data.List (unzip4, nub) +import Data.List (unzip4) {- Desugaring of @foreign@ declarations is naturally split up into @@ -80,9 +55,6 @@ so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these. -} -type Binding = (Id, CoreExpr) -- No rec/nonrec structure; - -- the occurrence analyser will sort it all out - dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding) dsForeigns fos = do hooks <- getHooks @@ -120,8 +92,8 @@ do_decl (ForeignExport { fd_name = L _ id , fd_e_ext = co - , fd_fe = CExport - (L _ (CExportStatic _ ext_nm cconv)) _ }) = do + , fd_fe = CExport _ + (L _ (CExportStatic _ ext_nm cconv)) }) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], []) @@ -153,186 +125,13 @@ dsFImport :: Id -> Coercion - -> ForeignImport - -> DsM ([Binding], CHeader, CStub) -dsFImport id co (CImport cconv safety mHeader spec _) = - dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader - -dsCImport :: Id - -> Coercion - -> CImportSpec - -> CCallConv - -> Safety - -> Maybe Header + -> ForeignImport (GhcPass p) -> DsM ([Binding], CHeader, CStub) -dsCImport id co (CLabel cid) cconv _ _ = do - dflags <- getDynFlags - let ty = coercionLKind co - platform = targetPlatform dflags - fod = case tyConAppTyCon_maybe (dropForAlls ty) of - Just tycon - | tyConUnique tycon == funPtrTyConKey -> - IsFunction - _ -> IsData - (resTy, foRhs) <- resultWrapper ty - assert (fromJust resTy `eqType` addrPrimTy) $ -- typechecker ensures this - let - rhs = foRhs (Lit (LitLabel cid stdcall_info fod)) - rhs' = Cast rhs co - stdcall_info = fun_type_arg_stdcall_info platform cconv ty - in - return ([(id, rhs')], mempty, mempty) - -dsCImport id co (CFunction target) cconv@PrimCallConv safety _ - = dsPrimCall id co (CCall (CCallSpec target cconv safety)) -dsCImport id co (CFunction target) cconv safety mHeader - = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader -dsCImport id co CWrapper cconv _ _ - = dsFExportDynamic id co cconv - --- 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 binderRelevantType_maybe bndrs - in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys) -fun_type_arg_stdcall_info _ _other_conv _ - = Nothing - -{- -************************************************************************ -* * -\subsection{Foreign calls} -* * -************************************************************************ --} - -dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header - -> DsM ([(Id, Expr TyVar)], CHeader, CStub) -dsFCall fn_id co fcall mDeclHeader = do - let - ty = coercionLKind co - (tv_bndrs, rho) = tcSplitForAllTyVarBinders ty - (arg_tys, io_res_ty) = tcSplitFunTys rho - - args <- newSysLocalsDs arg_tys -- no FFI representation polymorphism - (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) - - let - work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars - - (ccall_result_ty, res_wrapper) <- boxResult io_res_ty - - ccall_uniq <- newUnique - work_uniq <- newUnique - - (fcall', cDoc) <- - case fcall of - CCall (CCallSpec (StaticTarget _ cName mUnitId isFun) - CApiConv safety) -> - do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv - wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName) - let fcall' = CCall (CCallSpec - (StaticTarget NoSourceText - wrapperName mUnitId - True) - CApiConv safety) - c = includes - $$ fun_proto <+> braces (cRet <> semi) - includes = vcat [ text "#include \"" <> ftext h - <> text "\"" - | Header _ h <- nub headers ] - fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes - cRet - | isVoidRes = cCall - | otherwise = text "return" <+> cCall - cCall = if isFun - then ppr cName <> parens argVals - else if null arg_tys - then ppr cName - else panic "dsFCall: Unexpected arguments to FFI value import" - raw_res_ty = case tcSplitIOType_maybe io_res_ty of - Just (_ioTyCon, res_ty) -> res_ty - Nothing -> io_res_ty - isVoidRes = raw_res_ty `eqType` unitTy - (mHeader, cResType) - | isVoidRes = (Nothing, text "void") - | otherwise = toCType raw_res_ty - pprCconv = ccallConvAttribute CApiConv - mHeadersArgTypeList - = [ (header, cType <+> char 'a' <> int n) - | (t, n) <- zip arg_tys [1..] - , let (header, cType) = toCType (scaledThing t) ] - (mHeaders, argTypeList) = unzip mHeadersArgTypeList - argTypes = if null argTypeList - then text "void" - else hsep $ punctuate comma argTypeList - mHeaders' = mDeclHeader : mHeader : mHeaders - headers = catMaybes mHeaders' - argVals = hsep $ punctuate comma - [ char 'a' <> int n - | (_, n) <- zip arg_tys [1..] ] - return (fcall', c) - _ -> - return (fcall, empty) - dflags <- getDynFlags - let - -- Build the worker - worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty) - tvs = map binderVar tv_bndrs - the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty - work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) - work_id = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty - - -- Build the wrapper - work_app = mkApps (mkVarApps (Var work_id) tvs) val_args - wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers - wrap_rhs = mkLams (tvs ++ args) wrapper_body - wrap_rhs' = Cast wrap_rhs co - simpl_opts = initSimpleOpts dflags - fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity - (length args) - simpl_opts - wrap_rhs' - - return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] []) - -{- -************************************************************************ -* * -\subsection{Primitive calls} -* * -************************************************************************ - -This is for `@foreign import prim@' declarations. - -Currently, at the core level we pretend that these primitive calls are -foreign calls. It may make more sense in future to have them as a distinct -kind of Id, or perhaps to bundle them with PrimOps since semantically and -for calling convention they are really prim ops. --} - -dsPrimCall :: Id -> Coercion -> ForeignCall - -> DsM ([(Id, Expr TyVar)], CHeader, CStub) -dsPrimCall fn_id co fcall = do - let - ty = coercionLKind co - (tvs, fun_ty) = tcSplitForAllInvisTyVars ty - (arg_tys, io_res_ty) = tcSplitFunTys fun_ty - - args <- newSysLocalsDs arg_tys -- no FFI representation polymorphism - - ccall_uniq <- newUnique - let - call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty - rhs = mkLams tvs (mkLams args call_app) - rhs' = Cast rhs co - return ([(fn_id, rhs')], mempty, mempty) +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 {- ************************************************************************ @@ -367,325 +166,13 @@ , String -- string describing type to pass to createAdj. , Int -- size of args to stub function ) - -dsFExport fn_id co ext_name cconv isDyn = do - let - ty = coercionRKind co - (bndrs, orig_res_ty) = tcSplitPiTys ty - fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs - -- We must use tcSplits here, because we want to see - -- the (IO t) in the corner of the type! - fe_arg_tys | isDyn = tail fe_arg_tys' - | otherwise = fe_arg_tys' - - -- Look at the result type of the exported function, orig_res_ty - -- If it's IO t, return (t, True) - -- If it's plain t, return (t, False) - (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of - -- The function already returns IO t - Just (_ioTyCon, res_ty) -> (res_ty, True) - -- The function returns t - Nothing -> (orig_res_ty, False) - - dflags <- getDynFlags - return $ - mkFExportCBits dflags ext_name - (if isDyn then Nothing else Just fn_id) - fe_arg_tys res_ty is_IO_res_ty cconv - -{- -@foreign import "wrapper"@ (previously "foreign export dynamic") lets -you dress up Haskell IO actions of some fixed type behind an -externally callable interface (i.e., as a C function pointer). Useful -for callbacks and stuff. - -\begin{verbatim} -type Fun = Bool -> Int -> IO Int -foreign import "wrapper" f :: Fun -> IO (FunPtr Fun) - --- Haskell-visible constructor, which is generated from the above: --- SUP: No check for NULL from createAdjustor anymore??? - -f :: Fun -> IO (FunPtr Fun) -f cback = - bindIO (newStablePtr cback) - (\StablePtr sp# -> IO (\s1# -> - case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of - (# s2#, a# #) -> (# s2#, A# a# #))) - -foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun) - --- and the helper in C: (approximately; see `mkFExportCBits` below) - -f_helper(StablePtr s, HsBool b, HsInt i) -{ - Capability *cap; - cap = rts_lock(); - rts_inCall(&cap, - rts_apply(rts_apply(deRefStablePtr(s), - rts_mkBool(b)), rts_mkInt(i))); - rts_unlock(cap); -} -\end{verbatim} --} - -dsFExportDynamic :: Id - -> Coercion - -> CCallConv - -> DsM ([Binding], CHeader, CStub) -dsFExportDynamic id co0 cconv = do - mod <- getModule - dflags <- getDynFlags - let platform = targetPlatform dflags - let fe_nm = mkFastString $ zEncodeString - (moduleStableString mod ++ "$" ++ toCName dflags 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 - 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 Many stable_ptr_ty - (h_code, c_code, typestring, args_size) <- dsFExport 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). - -} - adj_args = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv)) - , Var stbl_value - , Lit (LitLabel fe_nm mb_sz_args 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 - - let io_app = mkLams tvs $ - Lam cback $ - mkApps (Var bindIOId) - [ Type stable_ptr_ty - , Type res_ty - , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] - , Lam stbl_value ccall_adj - ] - - fed = (id `setInlineActivation` NeverActive, Cast io_app co0) - -- Never inline the f.e.d. function, because the litlit - -- might not be in scope in other modules. - - 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 - -- Must have an IO type; hence Just - - -toCName :: DynFlags -> Id -> String -toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i))) - -{- -* - -\subsection{Generating @foreign export@ stubs} - -* - -For each @foreign export@ function, a C stub function is generated. -The C stub constructs the application of the exported Haskell function -using the hugs/ghc rts invocation API. --} - -mkFExportCBits :: DynFlags - -> FastString - -> Maybe Id -- Just==static, Nothing==dynamic - -> [Type] - -> Type - -> Bool -- True <=> returns an IO type - -> CCallConv - -> (CHeader, - CStub, - String, -- the argument reps - Int -- total size of arguments - ) -mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc - = ( header_bits - , CStub body [] [] - , type_string, - sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_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 - ) - where - platform = targetPlatform dflags - - -- list the arguments to the C function - arg_info :: [(SDoc, -- arg name - SDoc, -- C type - Type, -- Haskell type - CmmType)] -- the CmmType - arg_info = [ let stg_type = showStgType ty in - (arg_cname n stg_type, - stg_type, - ty, - typeCmmType platform (getPrimTyOf ty)) - | (ty,n) <- zip arg_htys [1::Int ..] ] - - arg_cname n stg_ty - | libffi = char '*' <> parens (stg_ty <> char '*') <> - text "args" <> brackets (int (n-1)) - | otherwise = text ('a':show n) - - -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled - libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target - - type_string - -- libffi needs to know the result type too: - | libffi = primTyDescChar platform res_hty : arg_type_string - | otherwise = arg_type_string - - arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info] - -- just the real args - - -- add some auxiliary args; the stable ptr in the wrapper case, and - -- a slot for the dummy return address in the wrapper + ccall case - aug_arg_info - | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info - | otherwise = arg_info - - stable_ptr_arg = - (text "the_stableptr", text "StgStablePtr", undefined, - typeCmmType platform (mkStablePtrPrimTy alphaTy)) - - -- stuff to do with the return type of the C function - res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes - - cResType | res_hty_is_unit = text "void" - | otherwise = showStgType res_hty - - -- when the return type is integral and word-sized or smaller, it - -- must be assigned as type ffi_arg (#3516). To see what type - -- libffi is expecting here, take a look in its own testsuite, e.g. - -- libffi/testsuite/libffi.call/cls_align_ulonglong.c - ffi_cResType - | is_ffi_arg_type = text "ffi_arg" - | otherwise = cResType - where - res_ty_key = getUnique (getName (typeTyCon res_hty)) - is_ffi_arg_type = res_ty_key `notElem` - [floatTyConKey, doubleTyConKey, - int64TyConKey, word64TyConKey] - - -- Now we can cook up the prototype for the exported function. - pprCconv = ccallConvAttribute cc - - header_bits = CHeader (text "extern" <+> fun_proto <> semi) - - fun_args - | null aug_arg_info = text "void" - | otherwise = hsep $ punctuate comma - $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info - - fun_proto - | libffi - = text "void" <+> ftext c_nm <> - parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr") - | otherwise - = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args - - -- the target which will form the root of what we ask rts_inCall to run - the_cfun - = case maybe_target of - Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)" - Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure" - - cap = text "cap" <> comma - - -- the expression we give to rts_inCall - expr_to_run - = foldl' appArg the_cfun arg_info -- NOT aug_arg_info - where - appArg acc (arg_cname, _, arg_hty, _) - = text "rts_apply" - <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname)) - - -- various other bits for inside the fn - declareResult = text "HaskellObj ret;" - declareCResult | res_hty_is_unit = empty - | otherwise = cResType <+> text "cret;" - - assignCResult | res_hty_is_unit = empty - | otherwise = - text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi - - -- an extern decl for the fn being called - extern_decl - = case maybe_target of - Nothing -> empty - Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi +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 - -- finally, the whole darn thing - body = - space $$ - extern_decl $$ - fun_proto $$ - vcat - [ lbrace - , text "Capability *cap;" - , declareResult - , declareCResult - , text "cap = rts_lock();" - -- create the application + perform it. - , text "rts_inCall" <> parens ( - char '&' <> cap <> - text "rts_apply" <> parens ( - cap <> - text "(HaskellObj)" - <> (if is_IO_res_ty - then text "runIO_closure" - else text "runNonIO_closure") - <> comma - <> expr_to_run - ) <+> comma - <> text "&ret" - ) <> semi - , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm) - <> comma <> text "cap") <> semi - , assignCResult - , text "rts_unlock(cap);" - , ppUnless res_hty_is_unit $ - if libffi - then char '*' <> parens (ffi_cResType <> char '*') <> - text "resp = cret;" - else text "return cret;" - , rbrace - ] - foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub foreignExportsInitialiser _ _ [] = mempty foreignExportsInitialiser platform mod hs_fns = @@ -701,7 +188,7 @@ -- See Note [Tracking foreign exports] in rts/ForeignExports.c initializerCStub platform fn_nm list_decl fn_body where - fn_nm = mkInitializerStubLabel mod "fexports" + fn_nm = mkInitializerStubLabel mod (fsLit "fexports") mod_str = pprModuleName (moduleName mod) fn_body = text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi list_symbol = text "stg_exports_" <> mod_str @@ -716,140 +203,3 @@ closure_ptr :: Id -> SDoc closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure" - -mkHObj :: Type -> SDoc -mkHObj t = text "rts_mk" <> text (showFFIType t) - -unpackHObj :: Type -> SDoc -unpackHObj t = text "rts_get" <> text (showFFIType t) - -showStgType :: Type -> SDoc -showStgType t = text "Hs" <> text (showFFIType t) - -showFFIType :: Type -> String -showFFIType t = getOccString (getName (typeTyCon t)) - -toCType :: Type -> (Maybe Header, SDoc) -toCType = f False - where f voidOK t - -- First, if we have (Ptr t) of (FunPtr t), then we need to - -- convert t to a C type and put a * after it. If we don't - -- know a type for t, then "void" is fine, though. - | Just (ptr, [t']) <- splitTyConApp_maybe t - , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] - = case f True t' of - (mh, cType') -> - (mh, cType' <> char '*') - -- Otherwise, if we have a type constructor application, then - -- see if there is a C type associated with that constructor. - -- Note that we aren't looking through type synonyms or - -- anything, as it may be the synonym that is annotated. - | Just tycon <- tyConAppTyConPicky_maybe t - , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon - = (mHeader, ftext cType) - -- If we don't know a C type for this type, then try looking - -- through one layer of type synonym etc. - | Just t' <- coreView t - = f voidOK t' - -- This may be an 'UnliftedFFITypes'-style ByteArray# argument - -- (which is marshalled like a Ptr) - | Just byteArrayPrimTyCon == tyConAppTyConPicky_maybe t - = (Nothing, text "const void*") - | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t - = (Nothing, text "void*") - -- Otherwise we don't know the C type. If we are allowing - -- void then return that; otherwise something has gone wrong. - | voidOK = (Nothing, text "void") - | otherwise - = pprPanic "toCType" (ppr t) - -typeTyCon :: Type -> TyCon -typeTyCon ty - | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) - = tc - | otherwise - = pprPanic "GHC.HsToCore.Foreign.Decl.typeTyCon" (ppr ty) - -insertRetAddr :: Platform -> CCallConv - -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] -insertRetAddr platform CCallConv args - = case platformArch platform of - ArchX86_64 - | platformOS platform == OSMinGW32 -> - -- On other Windows x86_64 we insert the return address - -- after the 4th argument, because this is the point - -- at which we need to flush a register argument to the stack - -- (See rts/Adjustor.c for details). - let go :: Int -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] - go 4 args = ret_addr_arg platform : args - go n (arg:args) = arg : go (n+1) args - go _ [] = [] - in go 0 args - | otherwise -> - -- On other x86_64 platforms we insert the return address - -- after the 6th integer argument, because this is the point - -- at which we need to flush a register argument to the stack - -- (See rts/Adjustor.c for details). - let go :: Int -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] - go 6 args = ret_addr_arg platform : args - go n (arg@(_,_,_,rep):args) - | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args - | otherwise = arg : go n args - go _ [] = [] - in go 0 args - _ -> - ret_addr_arg platform : args -insertRetAddr _ _ args = args - -ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType) -ret_addr_arg platform = (text "original_return_addr", text "void*", undefined, - typeCmmType platform addrPrimTy) - --- This function returns the primitive type associated with the boxed --- type argument to a foreign export (eg. Int ==> Int#). -getPrimTyOf :: Type -> UnaryType -getPrimTyOf ty - | isBoolTy rep_ty = intPrimTy - -- Except for Bool, the types we are interested in have a single constructor - -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). - | otherwise = - case splitDataProductType_maybe rep_ty of - Just (_, _, data_con, [Scaled _ prim_ty]) -> - assert (dataConSourceArity data_con == 1) $ - assertPpr (isUnliftedType prim_ty) (ppr prim_ty) - -- NB: it's OK to call isUnliftedType here, as we don't allow - -- representation-polymorphic types in foreign import/export declarations - prim_ty - _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty) - where - rep_ty = unwrapType ty - --- represent a primitive type as a Char, for building a string that --- described the foreign function type. The types are size-dependent, --- e.g. 'W' is a signed 32-bit integer. -primTyDescChar :: Platform -> Type -> Char -primTyDescChar platform ty - | ty `eqType` unitTy = 'v' - | otherwise - = case typePrimRep1 (getPrimTyOf ty) of - IntRep -> signed_word - WordRep -> unsigned_word - Int8Rep -> 'B' - Word8Rep -> 'b' - Int16Rep -> 'S' - Word16Rep -> 's' - Int32Rep -> 'W' - Word32Rep -> 'w' - Int64Rep -> 'L' - Word64Rep -> 'l' - AddrRep -> 'p' - FloatRep -> 'f' - DoubleRep -> 'd' - _ -> pprPanic "primTyDescChar" (ppr ty) - where - (signed_word, unsigned_word) = case platformWordSize platform of - PW4 -> ('W','w') - PW8 -> ('L','l') diff --git a/GHC/HsToCore/Foreign/JavaScript.hs b/GHC/HsToCore/Foreign/JavaScript.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/JavaScript.hs @@ -0,0 +1,683 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | Handling of JavaScript foreign imports/exports +module GHC.HsToCore.Foreign.JavaScript + ( dsJsImport + , dsJsFExport + , dsJsFExportDynamic + ) +where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Hs + +import GHC.HsToCore.Monad +import GHC.HsToCore.Foreign.Call +import GHC.HsToCore.Foreign.Prim +import GHC.HsToCore.Foreign.Utils +import GHC.HsToCore.Utils + +import GHC.Core +import GHC.Core.Make +import GHC.Core.Utils +import GHC.Core.DataCon +import GHC.Core.Unfold.Make +import GHC.Core.Type +import GHC.Core.TyCon +import GHC.Core.Coercion +import GHC.Core.Multiplicity + +import GHC.Types.Id +import GHC.Types.Id.Make +import GHC.Types.Literal +import GHC.Types.ForeignStubs +import GHC.Types.SourceText +import GHC.Types.Name +import GHC.Types.RepType +import GHC.Types.ForeignCall +import GHC.Types.Basic +import GHC.Types.Unique + +import GHC.Unit.Module + +import GHC.Tc.Utils.TcType + +import GHC.Cmm.Expr +import GHC.Cmm.Utils + +import GHC.JS.Ppr + +import GHC.Driver.Session +import GHC.Driver.Config + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names + +import GHC.Data.FastString +import GHC.Data.Pair +import GHC.Data.Maybe + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Encoding + +dsJsFExport + :: Id -- Either the exported Id, + -- or the foreign-export-dynamic constructor + -> Coercion -- Coercion between the Haskell type callable + -- from C, and its representation type + -> CLabelString -- The name to export to C land + -> CCallConv + -> Bool -- True => foreign export dynamic + -- so invoke IO action that's hanging off + -- the first argument's stable pointer + -> 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 + (_tvs,sans_foralls) = tcSplitForAllTyVars ty + (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls + -- We must use tcSplits here, because we want to see + -- the (IO t) in the corner of the type! + fe_arg_tys | isDyn = tail fe_arg_tys' + | otherwise = fe_arg_tys' + + -- Look at the result type of the exported function, orig_res_ty + -- If it's IO t, return (t, True) + -- If it's plain t, return (t, False) + (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of + -- The function already returns IO t + Just (_ioTyCon, res_ty) -> (res_ty, True) + -- The function returns t + Nothing -> (orig_res_ty, False) + platform <- targetPlatform <$> getDynFlags + return $ + mkFExportJSBits platform ext_name + (if isDyn then Nothing else Just fn_id) + (map scaledThing fe_arg_tys) res_ty is_IO_res_ty cconv + +mkFExportJSBits + :: Platform + -> FastString + -> Maybe Id -- Just==static, Nothing==dynamic + -> [Type] + -> Type + -> Bool -- True <=> returns an IO type + -> CCallConv + -> (CHeader, + CStub, + String, -- the argument reps + Int -- total size of arguments + ) +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 + ) + where + -- list the arguments to the JS function + arg_info :: [(SDoc, -- arg name + SDoc, -- C type + Type, -- Haskell type + CmmType)] -- the CmmType + arg_info = [ let stg_type = showStgType ty in + (arg_cname n stg_type, + stg_type, + ty, + typeCmmType platform (getPrimTyOf ty)) + | (ty,n) <- zip arg_htys [1::Int ..] ] + + arg_cname n _stg_ty = text ('a':show n) + + type_string = primTyDescChar platform res_hty : arg_type_string + + arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info] + + -- stuff to do with the return type of the JS function + res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes + + unboxResType | res_hty_is_unit = text "h$rts_getUnit" + | otherwise = unpackHObj res_hty + + header_bits = maybe mempty idTag maybe_target + idTag i = let (tag, u) = unpkUnique (getUnique i) + in CHeader (char tag <> int u) + + fun_args + | null arg_info = empty -- text "void" + | otherwise = hsep $ punctuate comma + $ map (\(nm,_ty,_,_) -> nm) arg_info + + fun_proto + = text "async" <+> + text "function" <+> + (if isNothing maybe_target + then text "h$" <> ftext c_nm + else ftext c_nm) <> + parens fun_args + + fun_export + = case maybe_target of + Just hs_fn | Just m <- nameModule_maybe (getName hs_fn) -> + 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 + ) <> semi + _ -> empty + + strlit xs = docToSDoc (pprStringLit (mkFastString 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)" + Just hs_fn -> idClosureText hs_fn + + -- the expression we give to rts_eval + expr_to_run :: SDoc + expr_to_run + = foldl appArg the_cfun arg_info + where + appArg acc (arg_cname, _, arg_hty, _) + = text "h$rts_apply" + <> parens (acc <> comma <> mkHObj arg_hty <> parens arg_cname) + + -- finally, the whole darn thing + js_bits = CStub { getCStub = js_sdoc + , getInitializers = mempty + , getFinalizers = mempty + } + where js_sdoc = space + $$ fun_proto + $$ vcat + [ lbrace + , text "return" + <+> text "await" + <+> text "h$rts_eval" + <> parens ((if is_IO_res_ty + then expr_to_run + else text "h$rts_toIO" <> parens expr_to_run) + <> comma <+> unboxResType) + <> semi + , rbrace + ] + $$ fun_export + +idClosureText :: Id -> SDoc +idClosureText i + | isExportedId i + , name <- getName i + , Just m <- nameModule_maybe name + = let str = renderWithContext defaultSDocContext (pprFullName m (localiseName name)) + in text "h$" <> text (zEncodeString str) + | otherwise + = panic "idClosureText: unknown module" + +-- | Desugaring of JavaScript foreign imports +dsJsImport + :: Id + -> Coercion + -> CImportSpec + -> CCallConv + -> Safety + -> Maybe Header + -> DsM ([Binding], CHeader, CStub) +dsJsImport id co (CLabel cid) cconv _ _ = do + let ty = pFst $ coercionKind co + fod = case tyConAppTyCon_maybe (dropForAlls ty) of + Just tycon + | tyConUnique tycon == funPtrTyConKey -> + IsFunction + _ -> IsData + (_resTy, foRhs) <- jsResultWrapper ty +-- ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this + let rhs = foRhs (Lit (LitLabel cid stdcall_info fod)) + rhs' = Cast rhs co + stdcall_info = fun_type_arg_stdcall_info cconv ty + + return ([(id, rhs')], mempty, mempty) + +dsJsImport id co (CFunction target) cconv@PrimCallConv safety _ + = dsPrimCall id co (CCall (CCallSpec target cconv safety)) +dsJsImport id co (CFunction target) cconv safety mHeader + = dsJsCall id co (CCall (CCallSpec target cconv safety)) mHeader +dsJsImport id co CWrapper cconv _ _ + = dsJsFExportDynamic id co cconv + +-- fixme work in progress +-- FIXME (Sylvain 2022-03): possibility of code sharing with dsFExportDynamic? +-- Lot of duplication +dsJsFExportDynamic :: Id + -> Coercion + -> CCallConv + -> DsM ([Binding], CHeader, CStub) +dsJsFExportDynamic id co0 cconv = do + let + ty = pFst (coercionKind 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" + -- 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 + 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 + 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). + -} + adj_args = [ mkIntLit platform (toInteger (ccallConvToInt cconv)) + , Var stbl_value + , Lit (LitLabel fe_nm mb_sz_args 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 + + let io_app = mkLams tvs $ + Lam cback $ + mkApps (Var bindIOId) + [ Type stable_ptr_ty + , Type res_ty + , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] + , Lam stbl_value ccall_adj + ] + + fed = (id `setInlineActivation` NeverActive, Cast io_app co0) + -- Never inline the f.e.d. function, because the litlit + -- might not be in scope in other modules. + + return ([fed], h_code, c_code) + +toJsName :: Id -> String +toJsName i = renderWithContext defaultSDocContext (pprCode (ppr (idName i))) + +dsJsCall :: Id -> Coercion -> ForeignCall -> Maybe Header + -> DsM ([(Id, Expr TyVar)], CHeader, CStub) +dsJsCall fn_id co (CCall (CCallSpec target cconv safety)) _mDeclHeader = do + let + ty = pFst $ coercionKind co + (tv_bndrs, rho) = tcSplitForAllTyVarBinders ty + (arg_tys, io_res_ty) = tcSplitFunTys rho + + args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism + (val_args, arg_wrappers) <- mapAndUnzipM unboxJsArg (map Var args) + + let + work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars + + (ccall_result_ty, res_wrapper) <- boxJsResult io_res_ty + + ccall_uniq <- newUnique + work_uniq <- newUnique + + simpl_opts <- initSimpleOpts <$> getDynFlags + + let + -- Build the worker + fcall = CCall (CCallSpec target cconv safety) + worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty) + tvs = map binderVar tv_bndrs + the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty + work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) + work_id = mkSysLocal (fsLit "$wccall") work_uniq ManyTy worker_ty + + -- Build the wrapper + work_app = mkApps (mkVarApps (Var work_id) tvs) val_args + wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers + wrap_rhs = mkLams (tvs ++ args) wrapper_body + wrap_rhs' = Cast wrap_rhs co + fn_id_w_inl = fn_id + `setIdUnfolding` + mkInlineUnfoldingWithArity simpl_opts VanillaSrc + (length args) wrap_rhs' + + return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, mempty) + + +mkHObj :: Type -> SDoc +mkHObj t = text "h$rts_mk" <> text (showFFIType t) + +unpackHObj :: Type -> SDoc +unpackHObj t = text "h$rts_get" <> text (showFFIType t) + +showStgType :: Type -> SDoc +showStgType t = text "Hs" <> text (showFFIType t) + +showFFIType :: Type -> String +showFFIType t = getOccString (getName (typeTyCon t)) + +typeTyCon :: Type -> TyCon +typeTyCon ty + -- UnaryRep rep_ty <- repType ty + | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) -- rep_ty + = tc + | otherwise + = pprPanic "typeTyCon" (ppr ty) + + +{- + We unbox arguments for JS calls a bit different from native code: + - Bool is marshalled to true/false, not 0/1 + - All int types are narrowed, since JS floats have a greater range than Int32 + -} + +unboxJsArg :: CoreExpr -- The supplied argument + -> DsM (CoreExpr, -- To pass as the actual argument + CoreExpr -> CoreExpr -- Wrapper to unbox the arg + ) +unboxJsArg arg + -- Primtive types: nothing to unbox + | isPrimitiveType arg_ty + = return (arg, \body -> body) + + -- Recursive newtypes + | Just (co, _rep_ty) <- topNormaliseNewType_maybe arg_ty + = unboxJsArg (mkCast arg co) + + -- Booleans, do not convert to 0/1, only force them + | Just tc <- tyConAppTyCon_maybe arg_ty, + tc `hasKey` boolTyConKey + = return (arg, + \ body -> mkWildCase arg (unrestricted boolTy) (exprType body) [Alt DEFAULT [] body]) + + | Just tc <- tyConAppTyCon_maybe arg_ty, + tc `hasKey` anyTyConKey + = return (arg, + \ body -> mkWildCase arg (unrestricted arg_ty) (exprType body) [Alt DEFAULT [] body]) + -- 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) + return (Var prim_arg, + \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body] + ) + + -- Byte-arrays, both mutable and otherwise; hack warning + -- We're looking for values of type ByteArray, MutableByteArray + -- 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 && + (arg3_tycon == byteArrayPrimTyCon || + arg3_tycon == mutableByteArrayPrimTyCon) + = do case_bndr <- newSysLocalDs ManyTy 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] + ) + + | otherwise + = do l <- getSrcSpanDs + pprPanic "unboxJsArg: " (ppr l <+> ppr arg_ty) + where + arg_ty = exprType arg + maybe_product_type = splitDataProductType_maybe arg_ty + is_product_type = isJust maybe_product_type + Just (_, _, data_con, data_con_arg_tys) = maybe_product_type + data_con_arity = dataConSourceArity data_con + (data_con_arg_ty1 : _) = data_con_arg_tys + + (_ : _ : 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 +-- Returns a wrapper for the primitive ccall itself, along with the +-- type of the result of the primitive ccall. This result type +-- will be of the form +-- State# RealWorld -> (# State# RealWorld, t' #) +-- where t' is the unwrapped form of t. If t is simply (), then +-- the result type will be +-- State# RealWorld -> (# State# RealWorld #) + +boxJsResult result_ty + | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty + -- isIOType_maybe handles the case where the type is a + -- simple wrapping of IO. E.g. + -- newtype Wrap a = W (IO a) + -- No coercion necessary because its a non-recursive newtype + -- (If we wanted to handle a *recursive* newtype too, we'd need + -- another case, and a coercion.) + -- The result is IO t, so wrap the result in an IO constructor + = do { res <- jsResultWrapper io_res_ty + ; let return_result state ans + = mkCoreUnboxedTuple [state, ans] + + ; (ccall_res_ty, the_alt) <- mk_alt return_result res + + ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy + ; let io_data_con = head (tyConDataCons io_tycon) + toIOCon = dataConWrapId io_data_con + + wrap the_call = + mkApps (Var toIOCon) + [ Type io_res_ty, + Lam state_id $ + mkWildCase (App the_call (Var state_id)) + (unrestricted ccall_res_ty) + (coreAltType the_alt) + [the_alt] + ] + + ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) } + +boxJsResult result_ty + = do -- It isn't IO, so do unsafePerformIO + -- It's not conveniently available, so we inline it + res <- jsResultWrapper result_ty + (ccall_res_ty, the_alt) <- mk_alt return_result res + let + wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) + (unrestricted ccall_res_ty) + (coreAltType the_alt) + [the_alt] + return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) + where + return_result _ ans = ans + +mk_alt :: (Expr Var -> Expr Var -> Expr Var) + -> (Maybe Type, Expr Var -> Expr Var) + -> DsM (Type, CoreAlt) +mk_alt return_result (Nothing, wrap_result) + = do -- The ccall returns () + state_id <- newSysLocalDs ManyTy realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + (wrap_result $ panic "jsBoxResult") + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy] + the_alt = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs + return (ccall_res_ty, the_alt) + +mk_alt return_result (Just prim_res_ty, wrap_result) + -- The ccall returns a non-() value + | isUnboxedTupleType prim_res_ty = do + let + Just ls = fmap dropRuntimeRepArgs (tyConAppArgs_maybe prim_res_ty) + arity = 1 + length ls + args_ids <- mapM (newSysLocalDs ManyTy) ls + state_id <- newSysLocalDs ManyTy realWorldStatePrimTy + let + result_tup = mkCoreUnboxedTuple (map Var args_ids) + the_rhs = return_result (Var state_id) + (wrap_result result_tup) + ccall_res_ty = mkTupleTy Unboxed (realWorldStatePrimTy : ls) + the_alt = Alt (DataAlt (tupleDataCon Unboxed arity)) + (state_id : args_ids) + the_rhs + return (ccall_res_ty, the_alt) + + | otherwise = do + result_id <- newSysLocalDs ManyTy prim_res_ty + state_id <- newSysLocalDs ManyTy realWorldStatePrimTy + let + the_rhs = return_result (Var state_id) + (wrap_result (Var result_id)) + ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty] + 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 + , CoreExpr -> CoreExpr -- Wrapper for the result + ) +-- resultWrapper deals with the result *value* +-- 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 + let tys' = catMaybes tys + -- arity = length args' + -- resCon = tupleDataCon Unboxed (length args) + err = panic "jsResultWrapper: used Id with result type Nothing" + resWrap :: CoreExpr + resWrap = mkCoreUnboxedTuple (zipWith (\w -> w . Var . fromMaybe err) wrappers matched) + return $ + if null tys' + then (Nothing, \_ -> resWrap) + else let innerArity = length tys' + innerTy = mkTupleTy Unboxed tys' + innerCon = tupleDataCon Unboxed innerArity + inner :: CoreExpr -> CoreExpr + inner e = mkWildCase e (unrestricted innerTy) result_ty + [Alt (DataAlt innerCon) + (catMaybes matched) + resWrap + ] + in (Just innerTy, inner) + + -- Base case 1b: primitive types + | isPrimitiveType result_ty + = return (Just result_ty, \e -> e) + -- Base case 1c: boxed tuples + -- fixme: levity args? + | Just (tc, args) <- splitTyConApp_maybe result_ty + , isBoxedTupleTyCon tc = do + let args' = dropRuntimeRepArgs args + innerTy = mkTupleTy Unboxed args' + (inner_res, w) <- jsResultWrapper innerTy + matched <- mapM (newSysLocalDs ManyTy) args' + let inner e = mkWildCase (w e) (unrestricted innerTy) result_ty + [ Alt (DataAlt (tupleDataCon Unboxed (length args'))) + matched + (mkCoreTup (map Var matched)) + -- mkCoreConApps (tupleDataCon Boxed (length args)) (map Type args ++ map Var matched) + ] + return (inner_res, inner) + + -- Base case 2: the unit type () + | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey + = return (Nothing, \_ -> Var unitDataConId) + + -- Base case 3: the boolean type + | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = do +-- result_id <- newSysLocalDs boolTy + ccall_uniq <- newUnique + let forceBool e = mkJsCall ccall_uniq "$r = !(!$1)" [e] boolTy + return + (Just intPrimTy, \e -> forceBool e) + + -- Base case 4: the any type + | Just (tc,_) <- maybe_tc_app, tc `hasKey` anyTyConKey + = return (Just result_ty, \e -> e) + + -- Newtypes + | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty + = do (maybe_ty, wrapper) <- jsResultWrapper rep_ty + return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) + + -- The type might contain foralls (eg. for dummy type arguments, + -- referring to 'Ptr a' is legal). + | Just (tyvar, rest) <- splitForAllTyCoVar_maybe result_ty + = do (maybe_ty, wrapper) <- jsResultWrapper rest + return (maybe_ty, \e -> Lam tyvar (wrapper e)) + + -- Data types with a single constructor, which has a single arg + -- This includes types like Ptr and ForeignPtr + | Just (_tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty, + dataConSourceArity data_con == 1 + = do let (unwrapped_res_ty : _) = data_con_arg_tys + (maybe_ty, wrapper) <- jsResultWrapper (scaledThing unwrapped_res_ty) + return + (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con)) + (map Type tycon_arg_tys ++ [wrapper e])) + + | otherwise + = pprPanic "jsResultWrapper" (ppr result_ty) + where + maybe_tc_app = splitTyConApp_maybe result_ty + +-- low-level primitive JavaScript call: +mkJsCall :: Unique -> String -> [CoreExpr] -> Type -> CoreExpr +mkJsCall u tgt args t = mkFCall u ccall args t + where + ccall = CCall $ CCallSpec + (StaticTarget NoSourceText (mkFastString tgt) (Just primUnit) True) + JavaScriptCallConv + PlayRisky diff --git a/GHC/HsToCore/Foreign/Prim.hs b/GHC/HsToCore/Foreign/Prim.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/Prim.hs @@ -0,0 +1,45 @@ +-- | Foreign primitive calls +-- +-- This is for `@foreign import prim@' declarations. +-- +-- Currently, at the core level we pretend that these primitive calls are +-- foreign calls. It may make more sense in future to have them as a distinct +-- kind of Id, or perhaps to bundle them with PrimOps since semantically and for +-- calling convention they are really prim ops. +module GHC.HsToCore.Foreign.Prim + ( dsPrimCall + ) +where + +import GHC.Prelude + +import GHC.Tc.Utils.Monad -- temp +import GHC.Tc.Utils.TcType + +import GHC.Core +import GHC.Core.Type +import GHC.Core.Coercion + +import GHC.HsToCore.Monad +import GHC.HsToCore.Foreign.Call + +import GHC.Types.Id +import GHC.Types.ForeignStubs +import GHC.Types.ForeignCall + +dsPrimCall :: Id -> Coercion -> ForeignCall + -> DsM ([(Id, Expr TyVar)], CHeader, CStub) +dsPrimCall fn_id co fcall = do + let + ty = coercionLKind co + (tvs, fun_ty) = tcSplitForAllInvisTyVars ty + (arg_tys, io_res_ty) = tcSplitFunTys fun_ty + + args <- newSysLocalsDs arg_tys -- no FFI representation polymorphism + + ccall_uniq <- newUnique + let + call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty + rhs = mkLams tvs (mkLams args call_app) + rhs' = Cast rhs co + return ([(fn_id, rhs')], mempty, mempty) diff --git a/GHC/HsToCore/Foreign/Utils.hs b/GHC/HsToCore/Foreign/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Foreign/Utils.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE MultiWayIf #-} + +module GHC.HsToCore.Foreign.Utils + ( Binding + , getPrimTyOf + , primTyDescChar + , ppPrimTyConStgType + ) +where + +import GHC.Prelude + +import GHC.Platform + +import GHC.Tc.Utils.TcType + +import GHC.Core (CoreExpr) +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Rep + +import GHC.Types.Id +import GHC.Types.RepType + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim + +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 + +-- This function returns the primitive type associated with the boxed +-- type argument to a foreign export (eg. Int ==> Int#). +getPrimTyOf :: Type -> UnaryType +getPrimTyOf ty + | isBoolTy rep_ty = intPrimTy + -- Except for Bool, the types we are interested in have a single constructor + -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). + | otherwise = + case splitDataProductType_maybe rep_ty of + Just (_, _, data_con, [Scaled _ prim_ty]) -> + assert (dataConSourceArity data_con == 1) $ + assertPpr (isUnliftedType prim_ty) (ppr prim_ty) + -- NB: it's OK to call isUnliftedType here, as we don't allow + -- representation-polymorphic types in foreign import/export declarations + prim_ty + _other -> pprPanic "getPrimTyOf" (ppr ty) + where + rep_ty = unwrapType ty + +-- represent a primitive type as a Char, for building a string that +-- described the foreign function type. The types are size-dependent, +-- e.g. 'W' is a signed 32-bit integer. +primTyDescChar :: Platform -> Type -> Char +primTyDescChar !platform ty + | ty `eqType` unitTy = 'v' + | otherwise + = case typePrimRep1 (getPrimTyOf ty) of + IntRep -> signed_word + WordRep -> unsigned_word + Int8Rep -> 'B' + Word8Rep -> 'b' + Int16Rep -> 'S' + Word16Rep -> 's' + Int32Rep -> 'W' + Word32Rep -> 'w' + Int64Rep -> 'L' + Word64Rep -> 'l' + AddrRep -> 'p' + FloatRep -> 'f' + DoubleRep -> 'd' + _ -> pprPanic "primTyDescChar" (ppr ty) + where + (signed_word, unsigned_word) = case platformWordSize platform of + PW4 -> ('W','w') + PW8 -> ('L','l') + +-- | Printed C Type to be used with CAPI calling convention +ppPrimTyConStgType :: TyCon -> Maybe String +ppPrimTyConStgType tc = + if | tc == charPrimTyCon -> Just "StgChar" + | tc == intPrimTyCon -> Just "StgInt" + | tc == int8PrimTyCon -> Just "StgInt8" + | tc == int16PrimTyCon -> Just "StgInt16" + | tc == int32PrimTyCon -> Just "StgInt32" + | tc == int64PrimTyCon -> Just "StgInt64" + | tc == wordPrimTyCon -> Just "StgWord" + | tc == word8PrimTyCon -> Just "StgWord8" + | tc == word16PrimTyCon -> Just "StgWord16" + | tc == word32PrimTyCon -> Just "StgWord32" + | tc == word64PrimTyCon -> Just "StgWord64" + | tc == floatPrimTyCon -> Just "StgFloat" + | tc == doublePrimTyCon -> Just "StgDouble" + | tc == addrPrimTyCon -> Just "StgAddr" + | tc == stablePtrPrimTyCon -> Just "StgStablePtr" + | tc == arrayPrimTyCon -> Just "const StgAddr" + | tc == mutableArrayPrimTyCon -> Just "StgAddr" + | tc == byteArrayPrimTyCon -> Just "const StgAddr" + | tc == mutableByteArrayPrimTyCon -> Just "StgAddr" + | tc == smallArrayPrimTyCon -> Just "const StgAddr" + | tc == smallMutableArrayPrimTyCon -> Just "StgAddr" + | otherwise -> Nothing diff --git a/GHC/HsToCore/GuardedRHSs.hs b/GHC/HsToCore/GuardedRHSs.hs --- a/GHC/HsToCore/GuardedRHSs.hs +++ b/GHC/HsToCore/GuardedRHSs.hs @@ -129,7 +129,7 @@ matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do let upat = unLoc pat - match_var <- selectMatchVar Many upat + match_var <- selectMatchVar ManyTy upat -- We only allow unrestricted patterns in guard, hence the `Many` -- above. It isn't clear what linear patterns would mean, maybe we will -- figure it out in the future. diff --git a/GHC/HsToCore/ListComp.hs b/GHC/HsToCore/ListComp.hs --- a/GHC/HsToCore/ListComp.hs +++ b/GHC/HsToCore/ListComp.hs @@ -366,8 +366,8 @@ let b_ty = idType n_id -- create some new local id's - b <- newSysLocalDs Many b_ty - x <- newSysLocalDs Many x_ty + b <- newSysLocalDs ManyTy b_ty + x <- newSysLocalDs ManyTy x_ty -- build rest of the comprehension core_rest <- dfListComp c_id b quals @@ -397,11 +397,11 @@ -- (a2:as'2) -> (a1, a2) : zip as'1 as'2)] mkZipBind elt_tys = do - ass <- mapM (newSysLocalDs Many) elt_list_tys - as' <- mapM (newSysLocalDs Many) elt_tys - as's <- mapM (newSysLocalDs Many) elt_list_tys + ass <- mapM (newSysLocalDs ManyTy) elt_list_tys + as' <- mapM (newSysLocalDs ManyTy) elt_tys + as's <- mapM (newSysLocalDs ManyTy) elt_list_tys - zip_fn <- newSysLocalDs Many zip_fn_ty + zip_fn <- newSysLocalDs ManyTy zip_fn_ty let inner_rhs = mkConsExpr elt_tuple_ty (mkBigCoreVarTup as') @@ -436,13 +436,13 @@ mkUnzipBind ThenForm _ = return Nothing -- No unzipping for ThenForm mkUnzipBind _ elt_tys - = do { ax <- newSysLocalDs Many elt_tuple_ty - ; axs <- newSysLocalDs Many elt_list_tuple_ty - ; ys <- newSysLocalDs Many elt_tuple_list_ty - ; xs <- mapM (newSysLocalDs Many) elt_tys - ; xss <- mapM (newSysLocalDs Many) elt_list_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 Many unzip_fn_ty + ; unzip_fn <- newSysLocalDs ManyTy unzip_fn_ty ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] @@ -450,8 +450,8 @@ concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) tupled_concat_expression = mkBigCoreTup concat_expressions - folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs) - folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax) + 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 ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) @@ -543,15 +543,12 @@ -- Generate the expressions to build the grouped list -- Build a pattern that ensures the consumer binds into the NEW binders, -- which hold monads rather than single values - ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs - ; body <- dsMcStmts stmts_rest - ; n_tup_var' <- newSysLocalDs Many n_tup_ty' - ; tup_n_var' <- newSysLocalDs Many tup_n_ty' + ; n_tup_var' <- newSysLocalDs ManyTy n_tup_ty' ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys ; us <- newUniqueSupply ; let rhs' = mkApps usingExpr' usingArgs' - body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr' + body' = mkBigTupleCase us to_bndrs body tup_n_expr' ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] } @@ -596,8 +593,8 @@ -- \x. case x of (a,b,c) -> body matchTuple ids body = do { us <- newUniqueSupply - ; tup_id <- newSysLocalDs Many (mkBigCoreVarTupTy ids) - ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) } + ; tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy ids) + ; return (Lam tup_id $ mkBigTupleCase us ids body (Var tup_id)) } -- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a -- desugared `CoreExpr` @@ -610,7 +607,7 @@ -> DsM CoreExpr dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts = do { body <- dsMcStmts stmts - ; var <- selectSimpleMatchVarL Many pat + ; 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 @@ -651,15 +648,15 @@ mkMcUnzipM _ fmap_op ys elt_tys = do { fmap_op' <- dsExpr fmap_op - ; xs <- mapM (newSysLocalDs Many) elt_tys + ; xs <- mapM (newSysLocalDs ManyTy) elt_tys ; let tup_ty = mkBigCoreTupTy elt_tys - ; tup_xs <- newSysLocalDs Many tup_ty + ; tup_xs <- newSysLocalDs ManyTy 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) , mk_sel i, Var ys] mk_sel n = Lam tup_xs $ - mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs) + mkBigTupleSelector xs (getNth xs n) tup_xs (Var tup_xs) ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } diff --git a/GHC/HsToCore/Match.hs b/GHC/HsToCore/Match.hs --- a/GHC/HsToCore/Match.hs +++ b/GHC/HsToCore/Match.hs @@ -6,7 +6,6 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The University of Glasgow 2006 @@ -25,9 +24,11 @@ import GHC.Prelude import GHC.Platform +import Language.Haskell.Syntax.Basic (Boxity(..)) + import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr) -import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) ) +import GHC.Types.Basic ( Origin(..), isGenerated ) import GHC.Types.SourceText import GHC.Driver.Session import GHC.Hs @@ -36,27 +37,31 @@ import GHC.Tc.Utils.Monad import GHC.HsToCore.Pmc import GHC.HsToCore.Pmc.Types ( Nablas, initNablas ) -import GHC.Core -import GHC.Types.Literal -import GHC.Core.Utils -import GHC.Core.Make import GHC.HsToCore.Monad import GHC.HsToCore.Binds import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils -import GHC.Types.Id -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.PatSyn import GHC.HsToCore.Errors.Types import GHC.HsToCore.Match.Constructor import GHC.HsToCore.Match.Literal + +import GHC.Core +import GHC.Core.Utils +import GHC.Core.Make +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.PatSyn import GHC.Core.Type +import GHC.Core.TyCo.Compare( eqType, eqTypes ) import GHC.Core.Coercion ( eqCoercion ) import GHC.Core.TyCon ( isNewTyCon ) import GHC.Core.Multiplicity import GHC.Builtin.Types + +import GHC.Types.Id +import GHC.Types.Literal import GHC.Types.SrcLoc + import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Types.Name @@ -430,7 +435,7 @@ -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v o (AsPat _ (L _ var) pat) +tidy1 v o (AsPat _ (L _ var) _ pat) = do { (wrap, pat') <- tidy1 v o (unLoc pat) ; return (wrapBind var v . wrap, pat') } @@ -517,8 +522,8 @@ -- Push the bang-pattern inwards, in the hope that -- it may disappear next time -tidy_bang_pat v o l (AsPat x v' p) - = tidy1 v o (AsPat x v' (L l (BangPat noExtField p))) +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) @@ -751,7 +756,7 @@ it creates another equation if the match can fail (see @GHC.HsToCore.Expr.doDo@ function) \item @let@ patterns, are treated by @matchSimply@ - List Comprension Patterns, are treated by @matchSimply@ also + List Comprehension Patterns, are treated by @matchSimply@ also \end{itemize} We can't call @matchSimply@ with Lambda patterns, @@ -762,8 +767,8 @@ -} matchWrapper ctxt scrs (MG { mg_alts = L _ matches - , mg_ext = MatchGroupTc arg_tys rhs_ty - , mg_origin = origin }) + , mg_ext = MatchGroupTc arg_tys rhs_ty origin + }) = do { dflags <- getDynFlags ; locn <- getSrcSpanDs @@ -869,7 +874,7 @@ = matchSinglePatVar var Nothing ctx pat ty match_result matchSinglePat scrut hs_ctx pat ty match_result - = do { var <- selectSimpleMatchVarL Many pat + = 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 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 @@ -36,8 +36,8 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import Control.Monad(liftM) -import Data.List (groupBy) import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE {- We are confronted with the first column of patterns in a set of @@ -143,13 +143,13 @@ -- and returns the types of the *value* args, which is what we want match_group :: [Id] - -> [(ConArgPats, EquationInfo)] -> DsM (MatchResult CoreExpr) + -> NonEmpty (ConArgPats, EquationInfo) + -> DsM (MatchResult CoreExpr) -- All members of the group have compatible ConArgPats match_group arg_vars arg_eqn_prs - = assert (notNull arg_eqn_prs) $ - do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs) + = do { (wraps, eqns') <- liftM NE.unzip (mapM shift arg_eqn_prs) ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs - ; match_result <- match (group_arg_vars ++ vars) ty eqns' + ; match_result <- match (group_arg_vars ++ vars) ty (NE.toList eqns') ; return $ foldr1 (.) wraps <$> match_result } @@ -184,9 +184,9 @@ -- suggestions for the new variables -- Divide into sub-groups; see Note [Record patterns] - ; let groups :: [[(ConArgPats, EquationInfo)]] - groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn) - | eqn <- eqn1:eqns ] + ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfo)) + groups = NE.groupBy1 compatible_pats + $ fmap (\eqn -> (pat_args (firstPat eqn), eqn)) (eqn1 :| eqns) ; match_results <- mapM (match_group arg_vars) groups @@ -210,8 +210,8 @@ -- Choose the right arg_vars in the right order for this group -- Note [Record patterns] - select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id] - select_arg_vars arg_vars ((arg_pats, _) : _) + select_arg_vars :: [Id] -> NonEmpty (ConArgPats, EquationInfo) -> [Id] + select_arg_vars arg_vars ((arg_pats, _) :| _) | RecCon flds <- arg_pats , let rpats = rec_flds flds , not (null rpats) -- Treated specially; cf conArgPats @@ -224,7 +224,6 @@ fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env (idName (hsRecFieldId rpat)) - select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" ----------------- compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool 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 @@ -36,29 +36,36 @@ import GHC.Hs -import GHC.Types.Id -import GHC.Types.SourceText +import GHC.Tc.Utils.Zonk ( shortCutLit ) +import GHC.Tc.Utils.TcType + import GHC.Core import GHC.Core.Make import GHC.Core.TyCon import GHC.Core.Reduction ( Reduction(..) ) import GHC.Core.DataCon -import GHC.Tc.Utils.Zonk ( shortCutLit ) -import GHC.Tc.Utils.TcType -import GHC.Types.Name import GHC.Core.Type +import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType ) + +import GHC.Types.Name +import GHC.Types.Literal +import GHC.Types.SrcLoc + import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Builtin.Types.Prim -import GHC.Types.Literal -import GHC.Types.SrcLoc -import GHC.Utils.Outputable as Outputable + +import GHC.Types.Id +import GHC.Types.SourceText + import GHC.Driver.Session + +import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain + import GHC.Data.FastString -import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType ) import Control.Monad import Data.Int @@ -118,7 +125,7 @@ There is a fun wrinkle to this, we used to simply compute the value for these literals and store it as `Rational`. While this might seem reasonable it meant typechecking literals of extremely large numbers -wasn't possible. This happend for example in #15646. +wasn't possible. This happened for example in #15646. There a user would write in GHCi e.g. `:t 1e1234111111111111111111111` which would trip up the compiler. The reason being we would parse it as @@ -265,7 +272,7 @@ 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 + , 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 () diff --git a/GHC/HsToCore/Monad.hs b/GHC/HsToCore/Monad.hs --- a/GHC/HsToCore/Monad.hs +++ b/GHC/HsToCore/Monad.hs @@ -23,7 +23,7 @@ newSysLocalsDs, newUniqueId, newFailLocalDs, newPredVarDs, getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA, - mkPrintUnqualifiedDs, + mkNamePprCtxDs, newUnique, UniqSupply, newUniqueSupply, getGhcModeDs, dsGetFamInstEnvs, @@ -167,11 +167,11 @@ | MR_Fallible (CoreExpr -> DsM a) deriving (Functor) --- | Product is an "or" on falliblity---the combined match result is infallible +-- | Product is an "or" on fallibility---the combined match result is infallible -- only if the left and right argument match results both were. -- -- This is useful for combining a bunch of alternatives together and then --- getting the overall falliblity of the entire group. See 'mkDataConCase' for +-- getting the overall fallibility of the entire group. See 'mkDataConCase' for -- an example. instance Applicative MatchResult where pure v = MR_Infallible (pure v) @@ -199,7 +199,7 @@ type DsWarning = (SrcSpan, SDoc) -- Not quite the same as a WarnMsg, we have an SDoc here - -- and we'll do the print_unqual stuff later on to turn it + -- and we'll do the name_ppr_ctx stuff later on to turn it -- into a Doc. -- | Run a 'DsM' action inside the 'TcM' monad. @@ -237,12 +237,13 @@ type_env = tcg_type_env tcg_env 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 - ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env + ; 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 } @@ -272,6 +273,7 @@ ; eps <- liftIO $ hscEPS hsc_env ; 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 @@ -281,7 +283,7 @@ ids = concatMap bindsToIds binds envs = mkDsEnvs unit_env this_mod rdr_env type_env - fam_inst_env msg_var cc_st_var + fam_inst_env ptc msg_var cc_st_var next_wrapper_num complete_matches ; runDs hsc_env envs thing_inside } @@ -317,13 +319,14 @@ thing_inside ; case mb_ret of Just ret -> pure ret - Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) } + Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) } mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv + -> PromotionTickContext -> IORef (Messages DsMessage) -> IORef CostCentreState -> IORef (ModuleEnv Int) -> CompleteMatches -> (DsGblEnv, DsLclEnv) -mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var +mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var next_wrapper_num complete_matches = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs" -- Failing tests here are `ghci` and `T11985` if you get this wrong. @@ -340,7 +343,7 @@ , ds_fam_inst_env = fam_inst_env , ds_gbl_rdr_env = rdr_env , ds_if_env = (if_genv, if_lenv) - , ds_unqual = mkPrintUnqualified unit_env rdr_env + , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env , ds_msgs = msg_var , ds_complete_matches = complete_matches , ds_cc_st = cc_st_var @@ -378,7 +381,7 @@ newPredVarDs :: PredType -> DsM Var newPredVarDs - = mkSysLocalOrCoVarM (fsLit "ds") Many -- like newSysLocalDs, but we allow covars + = mkSysLocalOrCoVarM (fsLit "ds") ManyTy -- like newSysLocalDs, but we allow covars newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id newSysLocalDs = mkSysLocalM (fsLit "ds") @@ -425,7 +428,7 @@ = do { env <- getGblEnv ; loc <- getSrcSpanDs ; !diag_opts <- initDiagOpts <$> getDynFlags - ; let msg = mkMsgEnvelope diag_opts loc (ds_unqual env) dsMessage + ; let msg = mkMsgEnvelope diag_opts loc (ds_name_ppr_ctx env) dsMessage ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Issue an error, but return the expression for (), so that we can continue @@ -443,8 +446,8 @@ failDs :: DsM a failDs = failM -mkPrintUnqualifiedDs :: DsM PrintUnqualified -mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv +mkNamePprCtxDs :: DsM NamePprCtx +mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where lookupThing = dsLookupGlobal diff --git a/GHC/HsToCore/Pmc.hs b/GHC/HsToCore/Pmc.hs --- a/GHC/HsToCore/Pmc.hs +++ b/GHC/HsToCore/Pmc.hs @@ -318,7 +318,7 @@ -- * Formatting and reporting warnings -- --- | A datatype to accomodate the different call sites of +-- | A datatype to accommodate the different call sites of -- 'formatReportWarnings'. Used for extracting 'CIRB's from a concrete 'ann' -- through 'collectInMode'. Since this is only possible for a couple of -- well-known 'ann's, this is a GADT. 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 @@ -38,10 +38,11 @@ import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper) import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr) import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper) -import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar) +import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar, decideBangHood) import GHC.HsToCore.Match.Literal (dsLit, dsOverLit) import GHC.HsToCore.Monad import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Type import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt @@ -119,7 +120,7 @@ -- (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 ++) <$> desugarLPat y p SigPat _ p _ty -> desugarLPat x p @@ -139,7 +140,8 @@ ListPat {} | ViewPat arg_ty _lexpr pat <- expansion , not (xopt LangExt.RebindableSyntax dflags) - , Just _ <- splitListTyConApp_maybe arg_ty + , Just tc <- tyConAppTyCon_maybe arg_ty + , tc == listTyCon -> desugarLPat x pat _ -> desugarPat x expansion @@ -247,7 +249,7 @@ -- | 'desugarPat', but also select and return a new match var. desugarPatV :: Pat GhcTc -> DsM (Id, [PmGrd]) desugarPatV pat = do - x <- selectMatchVar Many pat + x <- selectMatchVar ManyTy pat grds <- desugarPat x pat pure (x, grds) @@ -332,7 +334,10 @@ -- 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 - pats' <- concat <$> zipWithM desugarLPat vars pats + dflags <- getDynFlags + -- decideBangHood: See Note [Desugaring -XStrict matches in Pmc] + let banged_pats = map (decideBangHood dflags) pats + pats' <- concat <$> 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' } @@ -487,7 +492,7 @@ instances such as @Sing (a :: Bool)@ are a good example of this: If we would just drop the coercion, we'd get a type error when matching @pat@ against its value abstraction, with the result being that pmIsSatisfiable decides that every -possible data constructor fitting @pat@ is rejected as uninhabitated, leading to +possible data constructor fitting @pat@ is rejected as uninhabited, leading to a lot of false warnings. But we can check whether the coercion is a hole or if it is just refl, in @@ -531,4 +536,30 @@ The place to store the 'PmLet' guards for @where@ clauses (which are per 'GRHSs') is as a field of 'PmGRHSs'. For plain @let@ guards as in the guards of @x@, we can simply add them to the 'pg_grds' field of 'PmGRHS'. + +Note [Desugaring -XStrict matches in Pmc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#21761) + + {-# LANGUAGE Strict #-} + idV :: Void -> Void + idV v = v + +Without -XStrict, we would not warn here. But with -XStrict, there is an +implicit bang on `v` and we should give an inaccessible warning for the RHS. +The way we account for that is by calling `decideBangHood` on patterns +in a `Match`, which inserts the implicit bang. + +Making the call here actually seems redundant with the call to `decideBangHood` +in `GHC.HsToCore.Match.matchWrapper`, which does it *after* it calls the +pattern-match checker on the Match's patterns. It would be great if we could expect +`matchWrapper` to pass the bang-adorned `Match` to the pattern-match checker, +but sadly then we get worse warning messages which would print `idV` as if the +user *had* written a bang: + + Pattern match has inaccessible right hand side +- In an equation for ‘idV’: idV v = ... ++ In an equation for ‘idV’: idV !v = ... + +So we live with the duplication. -} 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 @@ -1,8 +1,7 @@ -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} --- | Provides factilities for pretty-printing 'Nabla's in a way appropriate for +-- | Provides facilities for pretty-printing 'Nabla's in a way appropriate for -- user facing pattern match warnings. module GHC.HsToCore.Pmc.Ppr ( pprUncovered @@ -10,6 +9,8 @@ import GHC.Prelude +import GHC.Data.List.Infinite (Infinite (..)) +import qualified GHC.Data.List.Infinite as Inf import GHC.Types.Basic import GHC.Types.Id import GHC.Types.Var.Env @@ -101,12 +102,11 @@ attach_refuts (u, (x, sdoc)) = (u, (sdoc, lookupRefuts nabla x)) -type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), [SDoc]) a +type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), Infinite SDoc) a -- Try nice names p,q,r,s,t before using the (ugly) t_i -nameList :: [SDoc] -nameList = map text ["p","q","r","s","t"] ++ - [ text ('t':show u) | u <- [(0 :: Int)..] ] +nameList :: Infinite SDoc +nameList = map text ["p","q","r","s","t"] Inf.++ flip Inf.unfoldr (0 :: Int) (\ u -> (text ('t':show u), u+1)) runPmPpr :: Nabla -> PmPprM a -> (a, DIdEnv (Id, SDoc)) runPmPpr nabla m = case runRWS m nabla (emptyDVarEnv, nameList) of @@ -117,7 +117,7 @@ getCleanName :: Id -> PmPprM SDoc getCleanName x = do (renamings, name_supply) <- get - let (clean_name:name_supply') = name_supply + let Inf clean_name name_supply' = name_supply case lookupDVarEnv renamings x of Just (_, nm) -> pure nm Nothing -> do 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 @@ -1,4 +1,3 @@ - {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} @@ -46,6 +45,7 @@ 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 @@ -56,13 +56,17 @@ import GHC.Types.Var (EvVar) import GHC.Types.Var.Env import GHC.Types.Var.Set +import GHC.Types.Unique.Supply + import GHC.Core -import GHC.Core.FVs (exprFreeVars) +import GHC.Core.FVs (exprFreeVars) +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Map.Expr +import GHC.Core.Predicate (typeDeterminesValue) import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe) import GHC.Core.Utils (exprType) -import GHC.Core.Make (mkListExpr, mkCharExpr) -import GHC.Types.Unique.Supply +import GHC.Core.Make (mkListExpr, mkCharExpr, mkImpossibleExpr) + import GHC.Data.FastString import GHC.Types.SrcLoc import GHC.Data.Maybe @@ -73,9 +77,8 @@ import GHC.Core.TyCon.RecWalk import GHC.Builtin.Names import GHC.Builtin.Types -import GHC.Builtin.Types.Prim (tYPETyCon) import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Subst (elemTCvSubst) +import GHC.Core.TyCo.Subst (elemSubst) import GHC.Core.Type import GHC.Tc.Solver (tcNormalise, tcCheckGivens, tcCheckWanteds) import GHC.Core.Unify (tcMatchTy) @@ -97,9 +100,6 @@ import qualified Data.List.NonEmpty as NE import Data.Ord (comparing) -import GHC.Utils.Trace -_ = pprTrace -- to silence unused import warnings - -- -- * Main exports -- @@ -147,11 +147,16 @@ -- Ex.: @vanillaCompleteMatchTC 'Maybe' ==> Just ("Maybe", {'Just','Nothing'})@ vanillaCompleteMatchTC :: TyCon -> Maybe CompleteMatch vanillaCompleteMatchTC tc = - let -- TYPE acts like an empty data type on the term-level (#14086), but - -- it is a PrimTyCon, so tyConDataCons_maybe returns Nothing. Hence a - -- special case. - mb_dcs | tc == tYPETyCon = Just [] - | otherwise = tyConDataCons_maybe 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. + -- Hence a special case. + 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. + isTypeDataTyCon tc = Just [] + | otherwise = tyConDataCons_maybe tc in vanillaCompleteMatch . mkUniqDSet . map RealDataCon <$> mb_dcs -- | Initialise from 'dsGetCompleteMatches' (containing all COMPLETE pragmas) @@ -409,7 +414,7 @@ -- (See "Type#type_classification" for what an algebraic type is.) -- -- This is qualified with \"like\" because of a particular special - -- case: TYPE (the underlyind kind behind Type, among others). TYPE + -- case: TYPE (the underlying kind behind Type, among others). TYPE -- is conceptually a datatype (and thus algebraic), but in practice it is -- a primitive builtin type, so we must check for it specially. -- @@ -642,7 +647,7 @@ unique <- getUniqueM let occname = mkVarOccFS (fsLit ("pm_"++show unique)) idname = mkInternalName unique occname noSrcSpan - return (mkLocalIdOrCoVar idname Many pred_ty) + return (mkLocalIdOrCoVar idname ManyTy pred_ty) ----------------------------- -- ** Adding term constraints @@ -881,7 +886,7 @@ where expr_ty = exprType e expr_in_scope = mkInScopeSet (exprFreeVars e) - in_scope_env = (expr_in_scope, const NoUnfolding) + in_scope_env = ISE expr_in_scope noUnfoldingFun -- It's inconvenient to get hold of a global in-scope set -- here, but it'll only be needed if exprIsConApp_maybe ends -- up substituting inside a forall or lambda (i.e. seldom) @@ -918,7 +923,7 @@ ex_tys = map exprToType ex_ty_args vis_args = reverse $ take arty $ reverse val_args uniq_supply <- lift $ lift $ getUniqueSupplyM - let (_, ex_tvs) = cloneTyVarBndrs (mkEmptyTCvSubst in_scope) dc_ex_tvs uniq_supply + let (_, ex_tvs) = cloneTyVarBndrs (mkEmptySubst in_scope) dc_ex_tvs uniq_supply ty_cts = equateTys (map mkTyVarTy ex_tvs) ex_tys -- 1. @x ≁ ⊥@ if 'K' is not a Newtype constructor (#18341) when (not (isNewDataCon dc)) $ @@ -942,23 +947,122 @@ pm_alt_con_app :: Id -> PmAltCon -> [TyVar] -> [Id] -> StateT Nabla (MaybeT DsM) () pm_alt_con_app x con tvs args = modifyT $ \nabla -> addConCt nabla x con tvs args +-- | Like 'modify', but with an effectful modifier action +modifyT :: Monad m => (s -> m s) -> StateT s m () +modifyT f = StateT $ fmap ((,) ()) . f + -- | Finds a representant of the semantic equality class of the given @e@. -- Which is the @x@ of a @let x = e'@ constraint (with @e@ semantically -- equivalent to @e'@) we encountered earlier, or a fresh identifier if -- there weren't any such constraints. representCoreExpr :: Nabla -> CoreExpr -> DsM (Id, Nabla) representCoreExpr nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_reps = reps } } e - | Just rep <- lookupCoreMap reps e = pure (rep, nabla) + | Just rep <- lookupCoreMap reps key = pure (rep, nabla) | otherwise = do rep <- mkPmId (exprType e) - let reps' = extendCoreMap reps e rep + let reps' = extendCoreMap reps key rep let nabla' = nabla{ nabla_tm_st = ts{ ts_reps = reps' } } pure (rep, nabla') + where + key = makeDictsCoherent e + -- Use a key in which dictionaries for the same type become equal. + -- See Note [Unique dictionaries in the TmOracle CoreMap] --- | Like 'modify', but with an effectful modifier action -modifyT :: Monad m => (s -> m s) -> StateT s m () -modifyT f = StateT $ fmap ((,) ()) . f +-- | Change out 'Id's which are uniquely determined by their type to a +-- common value, so that different names for dictionaries of the same type +-- are considered equal when building a 'CoreMap'. +-- +-- See Note [Unique dictionaries in the TmOracle CoreMap] +makeDictsCoherent :: CoreExpr -> CoreExpr +makeDictsCoherent var@(Var v) + | let ty = idType v + , typeDeterminesValue ty + = mkImpossibleExpr ty "Solver.makeDictsCoherent" + | otherwise + = var +makeDictsCoherent lit@(Lit {}) + = lit +makeDictsCoherent (App f a) + = App (makeDictsCoherent f) (makeDictsCoherent a) +makeDictsCoherent (Lam f body) + = Lam f (makeDictsCoherent body) +makeDictsCoherent (Let bndr body) + = Let + (go_bndr bndr) + (makeDictsCoherent body) + where + go_bndr (NonRec bndr expr) = NonRec bndr (makeDictsCoherent expr) + go_bndr (Rec bndrs) = Rec (map ( \(b, expr) -> (b, makeDictsCoherent expr) ) bndrs) +makeDictsCoherent (Case scrut bndr ty alts) + = Case scrut bndr ty + [ Alt con bndr expr' + | Alt con bndr expr <- alts + , let expr' = makeDictsCoherent expr ] +makeDictsCoherent (Cast expr co) + = Cast (makeDictsCoherent expr) co +makeDictsCoherent (Tick tick expr) + = Tick tick (makeDictsCoherent expr) +makeDictsCoherent ty@(Type {}) + = ty +makeDictsCoherent co@(Coercion {}) + = co +{- Note [Unique dictionaries in the TmOracle CoreMap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Any two dictionaries for a coherent typeclass should be considered equal +in the TmOracle CoreMap, as this allows us to report better pattern-match +warnings. + +Consider for example T21662: + + view_fn :: forall (n :: Nat). KnownNat n => Int -> Bool + + foo :: Int -> Int + foo (view_fn @12 -> True ) = 0 + foo (view_fn @12 -> False) = 1 + +In this example, the pattern match is exhaustive because we have covered +the range of the view pattern function. However, we may fail to recognise +the fact that the two cases use the same view function if the KnownNat +dictionaries aren't syntactically equal: + + eqn 1: [let ds_d1p0 = view_fn @12 $dKnownNat_a1ny ds_d1oR, True <- ds_d1p0] + eqn 2: [let ds_d1p6 = view_fn @12 $dKnownNat_a1nC ds_d1oR, False <- ds_d1p6] + +Note that the uniques of the KnownNat 12 dictionary differ. If we fail to utilise +the coherence of the KnownNat constraint, then we have to pessimistically assume +that we have two function calls with different arguments: + + foo (fn arg1 -> True ) = ... + foo (fn arg2 -> False) = ... + +In this case we can't determine whether the pattern matches are complete, so we +emit a pattern match warning. + +Solution: replace all 'Id's whose type uniquely determines its value with +a common value, e.g. in the above example we would replace both +$dKnownNat_a1ny and $dKnownNat_a1nC with error @(KnownNat 12). + +Why did we choose this solution? Here are some alternatives that were considered: + + 1. Perform CSE first. This would common up the dictionaries before we compare + using the CoreMap. + However, this is architecturally difficult as it would require threading + a CSEnv through to desugarPat. + 2. Directly modify CoreMap so that any two dictionaries of the same type are + considered equal. + The problem is that this affects all users of CoreMap. For example, CSE + would now assume that any two dictionaries of the same type are equal, + but this isn't necessarily true in the presence of magicDict, which + violates coherence by design. It seems more prudent to limit the changes + to the pattern-match checker only, to avoid undesirable consequences. + +In the end, replacing dictionaries with an error value in the pattern-match +checker was the most self-contained, although we might want to revisit once +we implement a more robust approach to computing equality in the pattern-match +checker (see #19272). +-} + {- Note [The Pos/Neg invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Invariant applying to each VarInfo: Whenever we have @C @tvs args@ in 'vi_pos', @@ -968,7 +1072,7 @@ * @x ~ Just y@, @x ≁ [Just]@. 'eqPmAltCon' returns @Equal@, so refute. * @x ~ Nothing@, @x ≁ [Just]@. 'eqPmAltCon' returns @Disjoint@, so negative info is redundant and should be discarded. -* @x ~ I# y@, @x ≁ [4,2]@. 'eqPmAltCon' returns @PossiblyOverlap@, so orthogal. +* @x ~ I# y@, @x ≁ [4,2]@. 'eqPmAltCon' returns @PossiblyOverlap@, so orthogonal. We keep this info in order to be able to refute a redundant match on i.e. 4 later on. @@ -1245,7 +1349,7 @@ -- Internally uses and updates the CompleteMatchs in vi_rcm. -- -- NB: Does /not/ filter each CompleteMatch with the oracle; members may --- remain that do not statisfy it. This lazy approach just +-- remain that do not satisfy it. This lazy approach just -- avoids doing unnecessary work. instantiate :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo instantiate fuel nabla vi = {-# SCC "instantiate" #-} @@ -1382,7 +1486,7 @@ compareConLikeTestability :: ConLike -> ConLike -> Ordering -- We should instantiate DataCons first, because they are likely to occur in -- multiple COMPLETE sets at once and we might find that multiple COMPLETE sets --- are inhabitated by instantiating only a single DataCon. +-- are inhabited by instantiating only a single DataCon. compareConLikeTestability PatSynCon{} _ = GT compareConLikeTestability _ PatSynCon{} = GT compareConLikeTestability (RealDataCon a) (RealDataCon b) = mconcat @@ -1477,7 +1581,7 @@ -- Make sure that @ty@ is normalised before. -- -- See Note [Matching against a ConLike result type]. -matchConLikeResTy :: FamInstEnvs -> TyState -> Type -> ConLike -> DsM (Maybe TCvSubst) +matchConLikeResTy :: FamInstEnvs -> TyState -> Type -> ConLike -> DsM (Maybe Subst) matchConLikeResTy env _ ty (RealDataCon dc) = pure $ do (rep_tc, tc_args, _co) <- splitReprTyConApp_maybe env ty if rep_tc == dataConTyCon dc @@ -1486,7 +1590,7 @@ matchConLikeResTy _ (TySt _ inert) ty (PatSynCon ps) = {-# SCC "matchConLikeResTy" #-} runMaybeT $ do let (univ_tvs,req_theta,_,_,_,con_res_ty) = patSynSig ps subst <- MaybeT $ pure $ tcMatchTy con_res_ty ty - guard $ all (`elemTCvSubst` subst) univ_tvs -- See the Note about T11336b + guard $ all (`elemSubst` subst) univ_tvs -- See the Note about T11336b if null req_theta then pure subst else do @@ -1521,7 +1625,7 @@ definition be flagged as inexhaustive (no false positives). Via the LYG algorithm, we reduce both these properties to a property on -the inhabitation test of refinementment types: +the inhabitation test of refinement types: *Soundness*: If the inhabitation test says "no" for a given refinement type Nabla, then it provably has no inhabitant. *Completeness*: If the inhabitation test says "yes" for a given refinement type @@ -1637,7 +1741,7 @@ check if `MkT` is inhabitable in each of those three fields, which in turn will require us to check if `MkT` is inhabitable again... As you can see, the branching factor adds up quickly, and if the initial fuel is, say, -100, then the inhabiation test will effectively take forever. +100, then the inhabitation test will effectively take forever. To mitigate this, we check the branching factor every time we are about to do inhabitation testing in 'instCon'. If the branching factor exceeds 1 @@ -1738,7 +1842,7 @@ Note [Instantiating a ConLike] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -`instCon` implements the the \(Inst\) function from Figure 8 of the LYG paper. +`instCon` implements the \(Inst\) function from Figure 8 of the LYG paper. Given the following type of ConLike `K` 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 @@ -57,6 +57,7 @@ import GHC.Core.TyCon import GHC.Types.Literal import GHC.Core +import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Map.Expr import GHC.Core.Utils (exprType) import GHC.Builtin.Names @@ -348,9 +349,9 @@ lookupSolution :: Nabla -> Id -> Maybe PmAltConApp lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of [] -> Nothing - pos + pos@(x:_) | Just sol <- find isDataConSolution pos -> Just sol - | otherwise -> Just (head pos) + | otherwise -> Just x -------------------------------------------------------------------------------- -- The rest is just providing an IR for (overloaded!) literals and AltCons that @@ -766,7 +767,7 @@ instance Outputable PmLitValue where ppr (PmLitInt i) = ppr i - ppr (PmLitRat r) = ppr (double (fromRat r)) -- good enough + ppr (PmLitRat r) = double (fromRat r) -- good enough ppr (PmLitChar c) = pprHsChar c ppr (PmLitString s) = pprHsString s ppr (PmLitOverInt n i) = minuses n (ppr i) 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 @@ -35,8 +35,8 @@ tracePm :: String -> SDoc -> DsM () tracePm herald doc = do logger <- getLogger - printer <- mkPrintUnqualifiedDs - liftIO $ putDumpFileMaybe' logger printer + name_ppr_ctx <- mkNamePprCtxDs + liftIO $ putDumpFileMaybe' logger name_ppr_ctx Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc)) {-# INLINE tracePm #-} -- see Note [INLINE conditional tracing utilities] @@ -52,7 +52,7 @@ mkPmId ty = getUniqueM >>= \unique -> let occname = mkVarOccFS $ fsLit "pm" name = mkInternalName unique occname noSrcSpan - in return (mkLocalIdOrCoVar name Many ty) + in return (mkLocalIdOrCoVar name ManyTy ty) {-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough -- | All warning flags that need to run the pattern match checker. diff --git a/GHC/HsToCore/Quote.hs b/GHC/HsToCore/Quote.hs --- a/GHC/HsToCore/Quote.hs +++ b/GHC/HsToCore/Quote.hs @@ -51,8 +51,8 @@ import GHC.Core.Class import GHC.Core.DataCon import GHC.Core.TyCon -import GHC.Core.Multiplicity ( pattern Many ) import GHC.Core +import GHC.Core.Type( pattern ManyTy, mkFunTy ) import GHC.Core.Make import GHC.Core.Utils @@ -89,6 +89,8 @@ import qualified GHC.LanguageExtensions as LangExt +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + import Data.ByteString ( unpack ) import Control.Monad import Data.List (sort, sortBy) @@ -96,6 +98,8 @@ import Data.Function import Control.Monad.Trans.Reader import Control.Monad.Trans.Class +import Data.Foldable ( toList ) +import GHC.Types.Name.Reader (RdrName(..)) data MetaWrappers = MetaWrappers { -- Applies its argument to a type argument `m` and dictionary `Quote m` @@ -126,8 +130,9 @@ -- the expected type tyvars = dataConUserTyVarBinders (classDataCon cls) expected_ty = mkInvisForAllTys tyvars $ - mkInvisFunTyMany (mkClassPred cls (mkTyVarTys (binderVars tyvars))) - (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) + mkFunTy invisArgConstraintLike ManyTy + (mkClassPred cls (mkTyVarTys (binderVars tyvars))) + (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) massertPpr (idType monad_sel `eqType` expected_ty) (ppr monad_sel $$ ppr expected_ty) @@ -157,36 +162,32 @@ getPlatform = targetPlatform <$> getDynFlags ----------------------------------------------------------------------------- -dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr - -> HsQuote GhcRn -- See Note [The life cycle of a TH quotation] - -> [PendingTcSplice] - -> DsM CoreExpr +dsBracket :: HsBracketTc -> DsM CoreExpr -- See Note [Desugaring Brackets] -- Returns a CoreExpr of type (M TH.Exp) -- The quoted thing is parameterised over Name, even though it has -- been type checked. We don't want all those type decorations! -dsBracket wrap brack splices - = do_brack brack +dsBracket (HsBracketTc { hsb_wrap = mb_wrap, hsb_splices = splices, hsb_quote = quote }) + = case quote of + VarBr _ _ n -> do { MkC e1 <- lookupOccDsM (unLoc n) ; return e1 } + ExpBr _ e -> runOverloaded $ do { MkC e1 <- repLE e ; return e1 } + PatBr _ p -> runOverloaded $ do { MkC p1 <- repTopP p ; return p1 } + TypBr _ t -> runOverloaded $ do { MkC t1 <- repLTy t ; return t1 } + DecBrG _ gp -> runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 } + DecBrL {} -> panic "dsUntypedBracket: unexpected DecBrL" where - runOverloaded act = do + Just wrap = mb_wrap -- Not used in VarBr case -- In the overloaded case we have to get given a wrapper, it is just - -- for variable quotations that there is no wrapper, because they + -- the VarBr case that there is no wrapper, because they -- have a simple type. - mw <- mkMetaWrappers (expectJust "runOverloaded" wrap) - runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw + runOverloaded act = do { mw <- mkMetaWrappers wrap + ; runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw } + new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices] - do_brack (VarBr _ _ n) = do { MkC e1 <- lookupOccDsM (unLoc n) ; return e1 } - do_brack (ExpBr _ e) = runOverloaded $ do { MkC e1 <- repLE e ; return e1 } - do_brack (PatBr _ p) = runOverloaded $ do { MkC p1 <- repTopP p ; return p1 } - do_brack (TypBr _ t) = runOverloaded $ do { MkC t1 <- repLTy t ; return t1 } - do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 } - do_brack (DecBrL {}) = panic "dsUntypedBracket: unexpected DecBrL" - - {- Note [Desugaring Brackets] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -461,7 +462,7 @@ repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) = do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences] - ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs -> repSynDecl tc1 bndrs rhs ; return (Just (locA loc, dec)) } @@ -469,7 +470,7 @@ , tcdTyVars = tvs , tcdDataDefn = defn })) = do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences] - ; dec <- addTyClTyVarBinds tvs $ \bndrs -> + ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs -> repDataDefn tc1 (Left bndrs) defn ; return (Just (locA loc, dec)) } @@ -478,7 +479,7 @@ tcdSigs = sigs, tcdMeths = meth_binds, tcdATs = ats, tcdATDefs = atds })) = do { cls1 <- lookupLOcc cls -- See Note [Binders and occurrences] - ; dec <- addQTyVarBinds tvs $ \bndrs -> + ; dec <- addQTyVarBinds FreshNamesOnly tvs $ \bndrs -> do { cxt1 <- repLContext cxt -- See Note [Scoped type variables in quotes] ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs meth_binds @@ -519,20 +520,19 @@ -> HsDataDefn GhcRn -> MetaM (Core (M TH.Dec)) repDataDefn tc opts - (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig + (HsDataDefn { dd_ctxt = cxt, dd_kindSig = ksig , dd_cons = cons, dd_derivs = mb_derivs }) = do { cxt1 <- repLContext cxt ; derivs1 <- repDerivs mb_derivs - ; case (new_or_data, cons) of - (NewType, [con]) -> do { con' <- repC con + ; case cons of + NewTypeCon con -> do { con' <- repC con ; ksig' <- repMaybeLTy ksig ; repNewtype cxt1 tc opts ksig' con' derivs1 } - (NewType, _) -> lift $ failWithDs (DsMultipleConForNewtype (getConNames $ unLoc $ head cons)) - (DataType, _) -> do { ksig' <- repMaybeLTy ksig + DataTypeCons type_data cons -> do { ksig' <- repMaybeLTy ksig ; consL <- mapM repC cons ; cons1 <- coreListM conTyConName consL - ; repData cxt1 tc opts ksig' cons1 + ; repData type_data cxt1 tc opts ksig' cons1 derivs1 } } @@ -550,14 +550,11 @@ , fdResultSig = L _ resultSig , fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See Note [Binders and occurrences] - ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn - mkHsQTvs tvs = HsQTvs { hsq_ext = [] - , hsq_explicit = tvs } - resTyVar = case resultSig of - TyVarSig _ bndr -> mkHsQTvs [bndr] - _ -> mkHsQTvs [] - ; dec <- addTyClTyVarBinds tvs $ \bndrs -> - addTyClTyVarBinds resTyVar $ \_ -> + ; let resTyVar = case resultSig of + TyVarSig _ bndr -> [hsLTyVarName bndr] + _ -> [] + ; dec <- addQTyVarBinds ReuseBoundNames tvs $ \bndrs -> + addSimpleTyVarBinds ReuseBoundNames resTyVar $ case info of ClosedTypeFamily Nothing -> notHandled (ThAbstractClosedTypeFamily decl) @@ -646,7 +643,7 @@ , cid_datafam_insts = adts , cid_overlap_mode = overlap }) - = addSimpleTyVarBinds tvs $ + = addSimpleTyVarBinds FreshNamesOnly tvs $ -- We must bring the type variables into scope, so their -- occurrences don't fail, even though the binders don't -- appear in the resulting data structure @@ -673,7 +670,7 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat , deriv_type = ty })) = do { dec <- repDerivStrategy strat $ \strat' -> - addSimpleTyVarBinds tvs $ + addSimpleTyVarBinds FreshNamesOnly tvs $ do { cxt' <- repLContext cxt ; inst_ty' <- repLTy inst_ty ; repDeriv strat' cxt' inst_ty' } @@ -739,14 +736,14 @@ repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ - , fd_fi = CImport (L _ cc) - (L _ s) mch cis _ })) + , fd_fi = CImport _ (L _ cc) + (L _ s) mch cis })) = do MkC name' <- lookupLOcc name MkC typ' <- repHsSigType typ MkC cc' <- repCCallConv cc MkC s' <- repSafety s cis' <- conv_cimportspec cis - MkC str <- coreStringLit (static ++ chStr ++ cis') + MkC str <- coreStringLit (mkFastString (static ++ chStr ++ cis')) dec <- rep2 forImpDName [cc', s', str, name', typ'] return (locA loc, dec) where @@ -805,22 +802,23 @@ repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repRuleD (L loc (HsRule { rd_name = n , rd_act = act - , rd_tyvs = ty_bndrs + , rd_tyvs = m_ty_bndrs , rd_tmvs = tm_bndrs , rd_lhs = lhs , rd_rhs = rhs })) - = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs -> + = 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 ty_bndrs of + ; 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 $ unpackFS $ snd $ unLoc n + ; n' <- coreStringLit $ unLoc n ; act' <- repPhases act ; lhs' <- repLE lhs ; rhs' <- repLE rhs @@ -844,7 +842,7 @@ ; rep2 typedRuleVarName [n', ty'] } repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) -repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp))) +repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp))) = do { target <- repAnnProv ann_prov ; exp' <- repE exp ; dec <- repPragAnn target exp' @@ -879,7 +877,7 @@ , con_ex_tvs = con_tvs , con_mb_cxt = mcxt , con_args = args })) - = addHsTyVarBinds con_tvs $ \ ex_bndrs -> + = addHsTyVarBinds FreshNamesOnly con_tvs $ \ ex_bndrs -> do { c' <- repH98DataCon con args ; ctxt' <- repMbContext mcxt ; if not is_existential && isNothing mcxt @@ -993,16 +991,16 @@ rep_sig (L loc (ClassOpSig _ is_deflt nms ty)) | is_deflt = mapM (rep_ty_sig defaultSigDName (locA loc) ty) nms | otherwise = mapM (rep_ty_sig sigDName (locA loc) ty) nms -rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d (locA loc) fix_sig 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 loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc) rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas rep_sig (L _ (SCCFunSig {})) = notHandled ThSCCPragmas -rep_sig (L loc (CompleteMatchSig _ _st cls mty)) +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) -- Desugar the explicit type variable binders in an 'LHsSigType', making -- sure not to gensym them. @@ -1189,14 +1187,11 @@ elt_ty <- wrapName tyVarBndrUnitTyConName case outer_bndrs of HsOuterImplicit{hso_ximplicit = imp_tvs} -> - addTyClTyVarBinds (mk_qtvs imp_tvs []) $ \_th_exp_bndrs -> + addSimpleTyVarBinds ReuseBoundNames imp_tvs $ thing_inside $ coreNothingList elt_ty HsOuterExplicit{hso_bndrs = exp_bndrs} -> - addTyClTyVarBinds (mk_qtvs [] exp_bndrs) $ \th_exp_bndrs -> + addHsTyVarBinds FreshNamesOnly exp_bndrs $ \th_exp_bndrs -> thing_inside $ coreJustList elt_ty th_exp_bndrs - where - mk_qtvs imp_tvs exp_tvs = HsQTvs { hsq_ext = imp_tvs - , hsq_explicit = exp_tvs } addHsOuterSigTyVarBinds :: HsOuterSigTyVarBndrs GhcRn @@ -1205,9 +1200,9 @@ addHsOuterSigTyVarBinds outer_bndrs thing_inside = case outer_bndrs of HsOuterImplicit{hso_ximplicit = imp_tvs} -> do th_nil <- coreListM tyVarBndrSpecTyConName [] - addSimpleTyVarBinds imp_tvs $ thing_inside th_nil + addSimpleTyVarBinds FreshNamesOnly imp_tvs $ thing_inside th_nil HsOuterExplicit{hso_bndrs = exp_bndrs} -> - addHsTyVarBinds exp_bndrs thing_inside + 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 @@ -1231,69 +1226,86 @@ nullOuterExplicit (HsOuterImplicit{}) = True -- Vacuously true, as there is no outermost explicit quantification -addSimpleTyVarBinds :: [Name] -- the binders to be added +-- Do we want to generate fresh names for type variables +-- or reuse the ones that are already in scope? +data FreshOrReuse + = FreshNamesOnly + -- Generate fresh names for all type variables, regardless of existing + -- variables in the MetaEnv. + -- + -- This is the default strategy. + + | ReuseBoundNames + -- Generate fresh names for type variables not in the MetaEnv. + -- Where a name is already bound in the MetaEnv, use that existing binding; + -- do not create a new one with a fresh name. + -- + -- This is the strategy used for data/newtype declarations and type family + -- instances, so that the nested type variables work right: + -- + -- class C a where + -- type W a b + -- instance C (T a) where + -- type W (T a) b = blah + -- + -- The 'a' in the type instance is the one bound by the instance decl + -- + -- Test cases: TH_reifyExplicitForAllFams T9081 T9199 T10811 + +mkGenSyms' :: FreshOrReuse -> [Name] -> MetaM [GenSymBind] +mkGenSyms' FreshNamesOnly names = mkGenSyms names +mkGenSyms' ReuseBoundNames names = + -- Make fresh names for the ones that are not already in scope + -- This makes things work for associated types + do { env <- lift dsGetMetaEnv + ; mkGenSyms (filterOut (`elemNameEnv` env) names) } + +addSimpleTyVarBinds :: FreshOrReuse + -> [Name] -- the binders to be added -> MetaM (Core (M a)) -- action in the ext env -> MetaM (Core (M a)) -addSimpleTyVarBinds names thing_inside - = do { fresh_names <- mkGenSyms names +addSimpleTyVarBinds fresh_or_reuse names thing_inside + = do { fresh_names <- mkGenSyms' fresh_or_reuse names ; term <- addBinds fresh_names thing_inside ; wrapGenSyms fresh_names term } addHsTyVarBinds :: forall flag flag' a. RepTV flag flag' - => [LHsTyVarBndr flag GhcRn] -- the binders to be added + => FreshOrReuse + -> [LHsTyVarBndr flag GhcRn] -- the binders to be added -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env -> MetaM (Core (M a)) -addHsTyVarBinds exp_tvs thing_inside - = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs) +addHsTyVarBinds fresh_or_reuse exp_tvs thing_inside + = do { fresh_exp_names <- mkGenSyms' fresh_or_reuse (hsLTyVarNames exp_tvs) ; term <- addBinds fresh_exp_names $ do { kbs <- repListM (tyVarBndrName @flag @flag') repTyVarBndr exp_tvs ; thing_inside kbs } ; wrapGenSyms fresh_exp_names term } -addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added +addQTyVarBinds :: FreshOrReuse + -> LHsQTyVars GhcRn -- the binders to be added -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env -> MetaM (Core (M a)) -addQTyVarBinds (HsQTvs { hsq_ext = imp_tvs - , hsq_explicit = exp_tvs }) - thing_inside - = addTyVarBinds exp_tvs imp_tvs thing_inside +addQTyVarBinds fresh_or_reuse qtvs thing_inside = + let HsQTvs { hsq_ext = imp_tvs + , hsq_explicit = exp_tvs } + = qtvs + in addTyVarBinds fresh_or_reuse exp_tvs imp_tvs thing_inside addTyVarBinds :: RepTV flag flag' - => [LHsTyVarBndr flag GhcRn] -- the binders to be added + => FreshOrReuse + -> [LHsTyVarBndr flag GhcRn] -- the binders to be added -> [Name] -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env -> MetaM (Core (M a)) -- gensym a list of type variables and enter them into the meta environment; -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument -addTyVarBinds exp_tvs imp_tvs thing_inside - = addSimpleTyVarBinds imp_tvs $ - addHsTyVarBinds exp_tvs $ +addTyVarBinds fresh_or_reuse exp_tvs imp_tvs thing_inside + = addSimpleTyVarBinds fresh_or_reuse imp_tvs $ + addHsTyVarBinds fresh_or_reuse exp_tvs $ thing_inside -addTyClTyVarBinds :: LHsQTyVars GhcRn - -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) - -> MetaM (Core (M a)) --- Used for data/newtype declarations, and family instances, --- so that the nested type variables work right --- instance C (T a) where --- type W (T a) = blah --- The 'a' in the type instance is the one bound by the instance decl -addTyClTyVarBinds tvs m - = do { let tv_names = hsAllLTyVarNames tvs - ; env <- lift $ dsGetMetaEnv - ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names) - -- Make fresh names for the ones that are not already in scope - -- This makes things work for family declarations - - ; term <- addBinds freshNames $ - do { kbs <- repListM tyVarBndrUnitTyConName repTyVarBndr - (hsQTvExplicit tvs) - ; m kbs } - - ; wrapGenSyms freshNames term } - -- | Represent a type variable binder repTyVarBndr :: RepTV flag flag' => LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag'))) @@ -1342,7 +1354,7 @@ repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type)) repForallT ty | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLocA ty) - = addHsTyVarBinds tvs $ \bndrs -> + = addHsTyVarBinds FreshNamesOnly tvs $ \bndrs -> do { ctxt1 <- repLContext ctxt ; tau1 <- repLTy tau ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...} @@ -1353,16 +1365,16 @@ case tele of HsForAllInvis{} -> repForallT ty HsForAllVis { hsf_vis_bndrs = tvs } -> - addHsTyVarBinds tvs $ \bndrs -> + addHsTyVarBinds FreshNamesOnly tvs $ \bndrs -> do body1 <- repLTy body repTForallVis bndrs body1 repTy ty@(HsQualTy {}) = repForallT ty repTy (HsTyVar _ _ (L _ n)) - | isLiftedTypeKindTyConName n = repTStar + | n `hasKey` liftedTypeKindTyConKey = repTStar | n `hasKey` constraintKindTyConKey = repTConstraint | n `hasKey` unrestrictedFunTyConKey = repArrowTyCon - | n `hasKey` funTyConKey = repMulArrowTyCon + | n `hasKey` fUNTyConKey = repMulArrowTyCon | isTvOcc occ = do tv1 <- lookupOcc n repTvar tv1 | isDataOcc occ = do tc1 <- lookupOcc n @@ -1413,7 +1425,8 @@ t1 <- repLTy t k1 <- repLTy k repTSig t1 k1 -repTy (HsSpliceTy _ splice) = repSplice splice +repTy (HsSpliceTy (HsUntypedSpliceNested n) _) = rep_splice n +repTy t@(HsSpliceTy (HsUntypedSpliceTop _ _) _) = pprPanic "repTy: top level splice" (ppr t) repTy (HsExplicitListTy _ _ tys) = do tys1 <- repLTys tys repTPromotedList tys1 @@ -1432,7 +1445,7 @@ repTy ty = notHandled (ThExoticFormOfType ty) -repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit)) +repTyLit :: HsTyLit (GhcPass p) -> MetaM (Core (M TH.TyLit)) repTyLit (HsNumTy _ i) = do platform <- getPlatform rep2 numTyLitName [mkIntegerExpr platform i] @@ -1460,13 +1473,8 @@ -- Splices ----------------------------------------------------------------------------- -repSplice :: HsSplice GhcRn -> MetaM (Core a) -- See Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice -- We return a CoreExpr of any old type; the context should know -repSplice (HsTypedSplice _ _ n _) = rep_splice n -repSplice (HsUntypedSplice _ _ n _) = rep_splice n -repSplice (HsQuasiQuote _ n _ _ _) = rep_splice n -repSplice e@(HsSpliced {}) = pprPanic "repSplice" (ppr e) rep_splice :: Name -> MetaM (Core a) rep_splice splice_name @@ -1500,7 +1508,7 @@ Just (DsSplice e) -> do { e' <- lift $ dsExpr e ; return (MkC e') } } repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar -repE (HsOverLabel _ s) = repOverLabel s +repE (HsOverLabel _ _ s) = repOverLabel s repE (HsRecSel _ (FieldOcc x _)) = repE (HsVar noExtField (noLocA x)) @@ -1519,7 +1527,8 @@ ; 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 } @@ -1610,7 +1619,7 @@ panic "The impossible has happened!" repE (ExprWithTySig _ e wc_ty) - = addSimpleTyVarBinds (get_scoped_tvs_from_sig sig_ty) $ + = addSimpleTyVarBinds FreshNamesOnly (get_scoped_tvs_from_sig sig_ty) $ do { e1 <- repLE e ; t1 <- rep_ty_sig' sig_ty ; repSigExp e1 t1 } @@ -1634,16 +1643,17 @@ ds3 <- repLE e3 repFromThenTo ds1 ds2 ds3 -repE (HsSpliceE _ splice) = repSplice splice +repE (HsTypedSplice n _) = rep_splice n +repE (HsUntypedSplice (HsUntypedSpliceNested n) _) = rep_splice n +repE e@(HsUntypedSplice (HsUntypedSpliceTop _ _) _) = pprPanic "repE: top level splice" (ppr e) repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC repE (HsUnboundVar _ uv) = do - occ <- occNameLit uv - sname <- repNameS occ - repUnboundVar sname -repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ f)))) = 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 (unLoc . dfoLabel . unLoc) xs) +repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel . unLoc) xs) repE (XExpr (HsExpanded orig_expr ds_expr)) = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax ; if rebindable_on -- See Note [Quotation and rebindable syntax] @@ -1864,7 +1874,7 @@ ; return (locA loc, ipb) } rep_implicit_param_name :: HsIPName -> MetaM (Core String) -rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name) +rep_implicit_param_name (HsIPName name) = coreStringLit name rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] -- Assumes: all the binders of the binding are already in the meta-env @@ -2061,7 +2071,7 @@ 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 (ListPat _ ps) = do { qs <- repLPs ps; repPlist qs } @@ -2074,7 +2084,8 @@ = do { con_str <- lookupLOcc dc ; case details of PrefixCon tyargs ps -> do { qs <- repLPs ps - ; ts <- repListM typeTyConName (repTy . unLoc . hsps_body) tyargs + ; let unwrapTyArg (HsConPatTyArg _ t) = unLoc (hsps_body t) + ; ts <- repListM typeTyConName (repTy . unwrapTyArg) tyargs ; repPcon con_str ts qs } RecCon rec -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec) ; repPrec con_str fps } @@ -2101,7 +2112,8 @@ repP (SigPat _ p t) = do { p' <- repLP p ; t' <- repLTy (hsPatSigType t) ; repPsig p' t' } -repP (SplicePat _ splice) = repSplice splice +repP (SplicePat (HsUntypedSpliceNested n) _) = rep_splice n +repP p@(SplicePat (HsUntypedSpliceTop _ _) _) = pprPanic "repP: top level splice" (ppr p) repP other = notHandled (ThExoticPattern other) ---------------------------------------------------------- @@ -2135,7 +2147,8 @@ -- -- Nevertheless, it's monadic because we have to generate nameTy mkGenSyms ns = do { var_ty <- lookupType nameTyConName - ; return [(nm, mkLocalId (localiseName nm) Many var_ty) | nm <- ns] } + ; return [ (nm, mkLocalId (localiseName nm) ManyTy var_ty) + | nm <- ns] } addBinds :: [GenSymBind] -> MetaM a -> MetaM a @@ -2178,32 +2191,41 @@ Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n) } -globalVar :: Name -> DsM (Core TH.Name) + -- Not bound by the meta-env -- Could be top-level; or could be local -- f x = $(g [| x |]) -- Here the x will be local -globalVar name - | isExternalName name - = do { MkC mod <- coreStringLit name_mod - ; MkC pkg <- coreStringLit name_pkg - ; MkC occ <- nameLit name - ; rep2_nwDsM mk_varg [pkg,mod,occ] } - | otherwise - = do { MkC occ <- nameLit name +globalVar :: Name -> DsM (Core TH.Name) +globalVar n = + case nameModule_maybe n of + Just m -> globalVarExternal m (getOccName n) + Nothing -> globalVarLocal (getUnique n) (getOccName n) + +globalVarLocal :: Unique -> OccName -> DsM (Core TH.Name) +globalVarLocal unique name + = do { MkC occ <- occNameLit name ; platform <- targetPlatform <$> getDynFlags - ; let uni = mkIntegerExpr platform (toInteger $ getKey (getUnique name)) + ; let uni = mkIntegerExpr platform (toInteger $ getKey unique) ; rep2_nwDsM mkNameLName [occ,uni] } + +globalVarExternal :: Module -> OccName -> DsM (Core TH.Name) +globalVarExternal mod name_occ + = do { + + ; MkC mod <- coreStringLit name_mod + ; MkC pkg <- coreStringLit name_pkg + ; MkC occ <- occNameLit name_occ + ; rep2_nwDsM mk_varg [pkg,mod,occ] } where - mod = assert (isExternalName name) nameModule name - name_mod = moduleNameString (moduleName mod) - name_pkg = unitString (moduleUnit mod) - name_occ = nameOccName name - 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) + 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 ; @@ -2230,16 +2252,13 @@ go _ [] = return body go var_ty ((name,id) : binds) = do { MkC body' <- go var_ty binds - ; lit_str <- lift $ nameLit name + ; lit_str <- occNameLit (occName name) ; gensym_app <- repGensym lit_str ; repBindM var_ty elt_ty gensym_app (MkC (Lam id body')) } -nameLit :: Name -> DsM (Core String) -nameLit n = coreStringLit (occNameString (nameOccName n)) - -occNameLit :: OccName -> MetaM (Core String) -occNameLit name = coreStringLit (occNameString name) +occNameLit :: MonadThings m => OccName -> m (Core String) +occNameLit name = coreStringLit (occNameFS name) -- %********************************************************************* @@ -2417,7 +2436,7 @@ coreModNameM :: MetaM (Core (Maybe TH.ModName)) coreModNameM = case maybeModName of Just m -> do - MkC s <- coreStringLit (moduleNameString m) + MkC s <- coreStringLit (moduleNameFS m) mName <- rep2_nw mkModNameName [s] coreJust modNameTyConName mName _ -> coreNothing modNameTyConName @@ -2515,14 +2534,17 @@ repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec)) repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] -repData :: Core (M TH.Cxt) -> Core TH.Name +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 ()))]) (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)) -repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs) - = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] -repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons) +repData type_data (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs) + | type_data = rep2 typeDataDName [nm, tvs, ksig, cons] + | otherwise = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] +repData _ (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons) (MkC derivs) = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs] @@ -2559,7 +2581,7 @@ StockStrategy _ -> thing_inside =<< just =<< repStockStrategy AnyclassStrategy _ -> thing_inside =<< just =<< repAnyclassStrategy NewtypeStrategy _ -> thing_inside =<< just =<< repNewtypeStrategy - ViaStrategy ty -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $ + ViaStrategy ty -> addSimpleTyVarBinds FreshNamesOnly (get_scoped_tvs_from_sig ty) $ do ty' <- rep_ty_sig' ty via_strat <- repViaStrategy ty' m_via_strat <- just via_strat @@ -2705,7 +2727,7 @@ arg_vtys <- repRecConArgs ips rep2 recCName [unC con', unC arg_vtys] -repGadtDataCons :: [LocatedN Name] +repGadtDataCons :: NonEmpty (LocatedN Name) -> HsConDeclGADTDetails GhcRn -> LHsType GhcRn -> MetaM (Core (M TH.Con)) @@ -2715,11 +2737,11 @@ PrefixConGADT ps -> do arg_tys <- repPrefixConArgs ps res_ty' <- repLTy res_ty - rep2 gadtCName [ unC (nonEmptyCoreList cons'), unC arg_tys, unC res_ty'] + rep2 gadtCName [ unC (nonEmptyCoreList' cons'), unC arg_tys, unC res_ty'] RecConGADT ips _ -> do arg_vtys <- repRecConArgs ips res_ty' <- repLTy res_ty - rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys, + rep2 recGadtCName [unC (nonEmptyCoreList' cons'), unC arg_vtys, unC res_ty'] -- TH currently only supports linear constructors. @@ -2929,9 +2951,25 @@ mk_lit (HsFractional f) = mk_rational f mk_lit (HsIsString _ s) = mk_string s +repRdrName :: RdrName -> MetaM (Core TH.Name) +repRdrName rdr_name = do + case rdr_name of + Unqual occ -> + repNameS =<< occNameLit occ + Qual mn occ -> do + let name_mod = moduleNameFS mn + mod <- coreStringLit name_mod + occ <- occNameLit occ + repNameQ mod occ + Orig m n -> lift $ globalVarExternal m n + Exact n -> lift $ globalVar n + repNameS :: Core String -> MetaM (Core TH.Name) repNameS (MkC name) = rep2_nw mkNameSName [name] +repNameQ :: Core String -> Core String -> MetaM (Core TH.Name) +repNameQ (MkC mn) (MkC name) = rep2_nw mkNameQName [mn, name] + --------------- Miscellaneous ------------------- repGensym :: Core String -> MetaM (Core (M TH.Name)) @@ -2951,17 +2989,19 @@ repOverLabel :: FastString -> MetaM (Core (M TH.Exp)) repOverLabel fs = do - (MkC s) <- coreStringLit $ unpackFS fs + MkC s <- coreStringLit fs rep2 labelEName [s] repGetField :: Core (M TH.Exp) -> FastString -> MetaM (Core (M TH.Exp)) repGetField (MkC exp) fs = do - MkC s <- coreStringLit $ unpackFS fs + MkC s <- coreStringLit fs rep2 getFieldEName [exp,s] repProjection :: NonEmpty FastString -> MetaM (Core (M TH.Exp)) repProjection fs = do - MkC xs <- coreListNonEmpty stringTy <$> mapM (coreStringLit . unpackFS) fs + ne_tycon <- lift $ dsLookupTyCon nonEmptyTyConName + MkC xs <- coreListNonEmpty ne_tycon stringTy <$> + mapM coreStringLit fs rep2 projectionEName [xs] ------------ Lists ------------------- @@ -2993,8 +3033,13 @@ -> [Core a] -> Core [a] coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es )) -coreListNonEmpty :: Type -> NonEmpty (Core a) -> Core (NonEmpty a) -coreListNonEmpty ty (MkC x :| xs) = MkC $ mkNonEmptyListExpr ty x (map unC xs) +coreListNonEmpty :: TyCon -- TyCon for NonEmpty + -> Type -- Element type + -> NonEmpty (Core a) + -> Core (NonEmpty a) +coreListNonEmpty ne_tc ty (MkC x :| xs) + = MkC $ mkCoreConApps (tyConSingleDataCon ne_tc) + [Type ty, x, mkListExpr ty (map unC xs)] nonEmptyCoreList :: [Core a] -> Core [a] -- The list must be non-empty so we can get the element type @@ -3002,9 +3047,11 @@ nonEmptyCoreList [] = panic "coreList: empty argument" nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) +nonEmptyCoreList' :: NonEmpty (Core a) -> Core [a] +nonEmptyCoreList' xs@(MkC x:|_) = MkC (mkListExpr (exprType x) (toList $ fmap unC xs)) -coreStringLit :: MonadThings m => String -> m (Core String) -coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } +coreStringLit :: MonadThings m => FastString -> m (Core String) +coreStringLit s = do { z <- mkStringExprFS s; return (MkC z) } ------------------- Maybe ------------------ diff --git a/GHC/HsToCore/Ticks.hs b/GHC/HsToCore/Ticks.hs new file mode 100644 --- /dev/null +++ b/GHC/HsToCore/Ticks.hs @@ -0,0 +1,1249 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE NondecreasingIndentation #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} + +{- +(c) Galois, 2006 +(c) University of Glasgow, 2007 +-} + +module GHC.HsToCore.Ticks + ( TicksConfig (..) + , Tick (..) + , TickishType (..) + , addTicksToBinds + , isGoodSrcSpan' + , stripTicksTopHsExpr + ) where + +import GHC.Prelude as Prelude + +import GHC.Hs +import GHC.Unit + +import GHC.Core.Type +import GHC.Core.TyCon + +import GHC.Data.Maybe +import GHC.Data.FastString +import GHC.Data.Bag +import GHC.Data.SizedSeq + +import GHC.Driver.Flags (DumpFlag(..)) + +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Logger +import GHC.Types.SrcLoc +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Types.Var.Set +import GHC.Types.Name.Set hiding (FreeVars) +import GHC.Types.Name +import GHC.Types.CostCentre +import GHC.Types.CostCentre.State +import GHC.Types.Tickish +import GHC.Types.ProfAuto + +import Control.Monad +import Data.List (isSuffixOf, intersperse) + +import Trace.Hpc.Mix + +import Data.Bifunctor (second) +import Data.Set (Set) +import qualified Data.Set as Set + +{- +************************************************************************ +* * +* The main function: addTicksToBinds +* * +************************************************************************ +-} + +-- | Configuration for compilation pass to add tick for instrumentation +-- to binding sites. +data TicksConfig = TicksConfig + { ticks_passes :: ![TickishType] + -- ^ What purposes do we need ticks for + + , ticks_profAuto :: !ProfAuto + -- ^ What kind of {-# SCC #-} to add automatically + + , ticks_countEntries :: !Bool + -- ^ Whether to count the entries to functions + -- + -- Requires extra synchronization which can vastly degrade + -- performance. + } + +data Tick = Tick + { tick_loc :: SrcSpan -- ^ Tick source span + , tick_path :: [String] -- ^ Path to the declaration + , tick_ids :: [OccName] -- ^ Identifiers being bound + , tick_label :: BoxLabel -- ^ Label for the tick counter + } + + +addTicksToBinds + :: Logger + -> TicksConfig + -> Module + -> ModLocation -- ^ location of the current module + -> NameSet -- ^ Exported Ids. When we call addTicksToBinds, + -- isExportedId doesn't work yet (the desugarer + -- hasn't set it), so we have to work from this set. + -> [TyCon] -- ^ Type constructors in this module + -> LHsBinds GhcTc + -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick)) + +addTicksToBinds logger cfg + mod mod_loc exports tyCons binds + | let passes = ticks_passes cfg + , not (null passes) + , Just orig_file <- ml_hs_file mod_loc = do + + let orig_file2 = guessSourceFile binds orig_file + + tickPass tickish (binds,st) = + let env = TTE + { fileName = mkFastString orig_file2 + , declPath = [] + , tte_countEntries = ticks_countEntries cfg + , exports = exports + , inlines = emptyVarSet + , inScope = emptyVarSet + , blackList = Set.fromList $ + mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of + RealSrcSpan l _ -> Just l + UnhelpfulSpan _ -> Nothing) + tyCons + , density = mkDensity tickish $ ticks_profAuto cfg + , this_mod = mod + , tickishType = tickish + } + (binds',_,st') = unTM (addTickLHsBinds binds) env st + in (binds', st') + + (binds1,st) = foldr tickPass (binds, initTTState) passes + + extendedMixEntries = ticks st + + putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell + (pprLHsBinds binds1) + + return (binds1, Just (orig_file2, extendedMixEntries)) + + | otherwise = return (binds, Nothing) + +guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath +guessSourceFile binds orig_file = + -- Try look for a file generated from a .hsc file to a + -- .hs file, by peeking ahead. + let top_pos = catMaybes $ foldr (\ (L pos _) rest -> + srcSpanFileName_maybe (locA pos) : rest) [] binds + in + case top_pos of + (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name + -> unpackFS file_name + _ -> orig_file + + +-- ----------------------------------------------------------------------------- +-- TickDensity + +-- | Where to insert ticks +data TickDensity + = TickForCoverage -- ^ for Hpc + | TickForBreakPoints -- ^ for GHCi + | TickAllFunctions -- ^ for -prof-auto-all + | TickTopFunctions -- ^ for -prof-auto-top + | TickExportedFunctions -- ^ for -prof-auto-exported + | TickCallSites -- ^ for stack tracing + deriving Eq + +mkDensity :: TickishType -> ProfAuto -> TickDensity +mkDensity tickish pa = case tickish of + HpcTicks -> TickForCoverage + SourceNotes -> TickForCoverage + Breakpoints -> TickForBreakPoints + ProfNotes -> + case pa of + ProfAutoAll -> TickAllFunctions + ProfAutoTop -> TickTopFunctions + ProfAutoExports -> TickExportedFunctions + ProfAutoCalls -> TickCallSites + _other -> panic "mkDensity" + +-- | Decide whether to add a tick to a binding or not. +shouldTickBind :: TickDensity + -> Bool -- ^ top level? + -> Bool -- ^ exported? + -> Bool -- ^ simple pat bind? + -> Bool -- ^ INLINE pragma? + -> Bool + +shouldTickBind density top_lev exported _simple_pat inline + = case density of + TickForBreakPoints -> False + -- we never add breakpoints to simple pattern bindings + -- (there's always a tick on the rhs anyway). + TickAllFunctions -> not inline + TickTopFunctions -> top_lev && not inline + TickExportedFunctions -> exported && not inline + TickForCoverage -> True + TickCallSites -> False + +shouldTickPatBind :: TickDensity -> Bool -> Bool +shouldTickPatBind density top_lev + = case density of + TickForBreakPoints -> False + TickAllFunctions -> True + TickTopFunctions -> top_lev + TickExportedFunctions -> False + TickForCoverage -> False + TickCallSites -> False + +-- Strip ticks HsExpr + +-- | Strip CoreTicks from an HsExpr +stripTicksTopHsExpr :: HsExpr GhcTc -> ([CoreTickish], HsExpr GhcTc) +stripTicksTopHsExpr (XExpr (HsTick t e)) = let (ts, body) = stripTicksTopHsExpr (unLoc e) + in (t:ts, body) +stripTicksTopHsExpr e = ([], e) + +-- ----------------------------------------------------------------------------- +-- Adding ticks to bindings + +addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc) +addTickLHsBinds = mapBagM addTickLHsBind + +addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) +addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds + , abs_exports = abs_exports + }))) = + withEnv add_exports $ + withEnv add_inlines $ do + binds' <- addTickLHsBinds binds + return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' } + where + -- in AbsBinds, the Id on each binding is not the actual top-level + -- Id that we are defining, they are related by the abs_exports + -- field of AbsBinds. So if we're doing TickExportedFunctions we need + -- to add the local Ids to the set of exported Names so that we know to + -- tick the right bindings. + add_exports env = + env{ exports = exports env `extendNameSetList` + [ idName mid + | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports + , idName pid `elemNameSet` (exports env) ] } + + -- See Note [inline sccs] + add_inlines env = + env{ inlines = inlines env `extendVarSetList` + [ mid + | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports + , isInlinePragma (idInlinePragma pid) ] } + +addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do + let name = getOccString id + decl_path <- getPathEntry + density <- getDensity + + inline_ids <- liftM inlines getEnv + -- See Note [inline sccs] + let inline = isInlinePragma (idInlinePragma id) + || id `elemVarSet` inline_ids + + -- See Note [inline sccs] + tickish <- tickishType `liftM` getEnv + case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do + + (fvs, mg) <- + getFreeVars $ + addPathEntry name $ + addTickMatchGroup False (fun_matches funBind) + + blackListed <- isBlackListed (locA pos) + exported_names <- liftM exports getEnv + + -- We don't want to generate code for blacklisted positions + -- We don't want redundant ticks on simple pattern bindings + -- We don't want to tick non-exported bindings in TickExportedFunctions + let simple = isSimplePatBind funBind + toplev = null decl_path + exported = idName id `elemNameSet` exported_names + + tick <- if not blackListed && + shouldTickBind density toplev exported simple inline + then + bindTick density name (locA pos) fvs + else + return Nothing + + let mbCons = maybe Prelude.id (:) + return $ L pos $ funBind { fun_matches = mg + , fun_ext = second (tick `mbCons`) (fun_ext funBind) } + } + + where + -- a binding is a simple pattern binding if it is a funbind with + -- zero patterns + isSimplePatBind :: HsBind GhcTc -> Bool + isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0 + +-- TODO: Revisit this +addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs + , pat_rhs = rhs }))) = do + + let simplePatId = isSimplePat lhs + + -- TODO: better name for rhs's for non-simple patterns? + let name = maybe "(...)" getOccString simplePatId + + (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs + let pat' = pat { pat_rhs = rhs'} + + -- Should create ticks here? + density <- getDensity + decl_path <- getPathEntry + let top_lev = null decl_path + if not (shouldTickPatBind density top_lev) + then return (L pos pat') + else do + + let mbCons = maybe id (:) + + let (initial_rhs_ticks, initial_patvar_tickss) = snd $ pat_ext pat' + + -- Allocate the ticks + + rhs_tick <- bindTick density name (locA pos) fvs + let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks + + patvar_tickss <- case simplePatId of + Just{} -> return initial_patvar_tickss + Nothing -> do + let patvars = map getOccString (collectPatBinders CollNoDictBinders lhs) + patvar_ticks <- mapM (\v -> bindTick density v (locA pos) fvs) patvars + return + (zipWith mbCons patvar_ticks + (initial_patvar_tickss ++ repeat [])) + + return $ L pos $ pat' { pat_ext = second (const (rhs_ticks, patvar_tickss)) (pat_ext pat') } + +-- Only internal stuff, not from source, uses VarBind, so we ignore it. +addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind +addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind + +bindTick + :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish) +bindTick density name pos fvs = do + decl_path <- getPathEntry + let + toplev = null decl_path + count_entries = toplev || density == TickAllFunctions + top_only = density /= TickAllFunctions + box_label = if toplev then TopLevelBox [name] + else LocalBox (decl_path ++ [name]) + -- + allocATickBox box_label count_entries top_only pos fvs + + +-- Note [inline sccs] +-- ~~~~~~~~~~~~~~~~~~ +-- The reason not to add ticks to INLINE functions is that this is +-- sometimes handy for avoiding adding a tick to a particular function +-- (see #6131) +-- +-- So for now we do not add any ticks to INLINE functions at all. +-- +-- We used to use isAnyInlinePragma to figure out whether to avoid adding +-- ticks for this purpose. However, #12962 indicates that this contradicts +-- the documentation on profiling (which only mentions INLINE pragmas). +-- So now we're more careful about what we avoid adding ticks to. + +-- ----------------------------------------------------------------------------- +-- Decorate an LHsExpr with ticks + +-- selectively add ticks to interesting expressions +addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExpr e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | isGoodBreakExpr e0 -> tick_it + TickForCoverage -> tick_it + TickCallSites | isCallSite e0 -> tick_it + _other -> dont_tick_it + where + tick_it = allocTickBox (ExpBox False) False False (locA pos) + $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- Add a tick to an expression which is the RHS of an equation or a binding. +-- We always consider these to be breakpoints, unless the expression is a 'let' +-- (because the body will definitely have a tick somewhere). ToDo: perhaps +-- we should treat 'case' and 'if' the same way? +addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprRHS e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it + | otherwise -> tick_it + TickForCoverage -> tick_it + TickCallSites | isCallSite e0 -> tick_it + _other -> dont_tick_it + where + tick_it = allocTickBox (ExpBox False) False False (locA pos) + $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- The inner expression of an evaluation context: +-- let binds in [], ( [] ) +-- we never tick these if we're doing HPC, but otherwise +-- we treat it like an ordinary expression. +addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprEvalInner e = do + d <- getDensity + case d of + TickForCoverage -> addTickLHsExprNever e + _otherwise -> addTickLHsExpr e + +-- | A let body is treated differently from addTickLHsExprEvalInner +-- above with TickForBreakPoints, because for breakpoints we always +-- want to tick the body, even if it is not a redex. See test +-- break012. This gives the user the opportunity to inspect the +-- values of the let-bound variables. +addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprLetBody e@(L pos e0) = do + d <- getDensity + case d of + TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it + | otherwise -> tick_it + _other -> addTickLHsExprEvalInner e + where + tick_it = allocTickBox (ExpBox False) False False (locA pos) + $ addTickHsExpr e0 + dont_tick_it = addTickLHsExprNever e + +-- version of addTick that does not actually add a tick, +-- because the scope of this tick is completely subsumed by +-- another. +addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickLHsExprNever (L pos e0) = do + e1 <- addTickHsExpr e0 + return $ L pos e1 + +-- General heuristic: expressions which are calls (do not denote +-- values) are good break points. +isGoodBreakExpr :: HsExpr GhcTc -> Bool +isGoodBreakExpr e = isCallSite e + +isCallSite :: HsExpr GhcTc -> Bool +isCallSite HsApp{} = True +isCallSite HsAppType{} = True +isCallSite (XExpr (ExpansionExpr (HsExpanded _ 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) + = ifDensity TickForCoverage + (allocTickBox (ExpBox oneOfMany) False False (locA pos) + $ addTickHsExpr e0) + (addTickLHsExpr (L pos e0)) + +addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addBinTickLHsExpr boxLabel (L pos e0) + = ifDensity TickForCoverage + (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0) + (addTickLHsExpr (L pos e0)) + + +-- ----------------------------------------------------------------------------- +-- Decorate the body of an HsExpr with ticks. +-- (Whether to put a tick around the whole expression was already decided, +-- in the addTickLHsExpr family of functions.) + +addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) +addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e +addTickHsExpr e@(HsUnboundVar {}) = return e +addTickHsExpr e@(HsRecSel _ (FieldOcc id _)) = do freeVar id; return e + +addTickHsExpr e@(HsIPVar {}) = return e +addTickHsExpr e@(HsOverLit {}) = return e +addTickHsExpr e@(HsOverLabel{}) = return e +addTickHsExpr e@(HsLit {}) = return e +addTickHsExpr (HsLam x mg) = liftM (HsLam x) + (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 + e' <- addTickLHsExprNever e + return (HsAppType x e' at ty) +addTickHsExpr (OpApp fix e1 e2 e3) = + liftM4 OpApp + (return fix) + (addTickLHsExpr e1) + (addTickLHsExprNever e2) + (addTickLHsExpr e3) +addTickHsExpr (NegApp x e neg) = + liftM2 (NegApp x) + (addTickLHsExpr e) + (addTickSyntaxExpr hpcSrcSpan neg) +addTickHsExpr (HsPar x lpar e rpar) = do + e' <- addTickLHsExprEvalInner e + return (HsPar x lpar e' rpar) +addTickHsExpr (SectionL x e1 e2) = + liftM2 (SectionL x) + (addTickLHsExpr e1) + (addTickLHsExprNever e2) +addTickHsExpr (SectionR x e1 e2) = + liftM2 (SectionR x) + (addTickLHsExprNever e1) + (addTickLHsExpr e2) +addTickHsExpr (ExplicitTuple x es boxity) = + liftM2 (ExplicitTuple x) + (mapM addTickTupArg es) + (return boxity) +addTickHsExpr (ExplicitSum ty tag arity e) = do + e' <- addTickLHsExpr e + return (ExplicitSum ty tag arity e') +addTickHsExpr (HsCase x e mgs) = + liftM2 (HsCase x) + (addTickLHsExpr e) -- not an EvalInner; e might not necessarily + -- be evaluated. + (addTickMatchGroup False mgs) +addTickHsExpr (HsIf x e1 e2 e3) = + liftM3 (HsIf x) + (addBinTickLHsExpr (BinBox CondBinBox) e1) + (addTickLHsExprOptAlt True e2) + (addTickLHsExprOptAlt True e3) +addTickHsExpr (HsMultiIf ty alts) + = do { let isOneOfMany = case alts of [_] -> False; _ -> True + ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False) alts + ; return $ HsMultiIf ty alts' } +addTickHsExpr (HsLet x tkLet binds tkIn e) = + bindLocals (collectLocalBinders CollNoDictBinders 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 +addTickHsExpr (ExplicitList ty es) + = liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es) + +addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e + +addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds }) + = do { rec_binds' <- addTickHsRecordBinds rec_binds + ; return (expr { rcon_flds = rec_binds' }) } + +addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Left 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 }) + = do { e' <- addTickLHsExpr e + ; flds' <- mapM addTickHsRecField flds + ; return (expr { rupd_expr = e', rupd_flds = Right flds' }) } + +addTickHsExpr (ExprWithTySig x e ty) = + liftM3 ExprWithTySig + (return x) + (addTickLHsExprNever e) -- No need to tick the inner expression + -- for expressions with signatures + (return ty) +addTickHsExpr (ArithSeq ty wit arith_seq) = + liftM3 ArithSeq + (return ty) + (addTickWit wit) + (addTickArithSeqInfo arith_seq) + where addTickWit Nothing = return Nothing + addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl + return (Just fl') + +addTickHsExpr (HsPragE x p e) = + liftM (HsPragE x p) (addTickLHsExpr e) +addTickHsExpr e@(HsTypedBracket {}) = return e +addTickHsExpr e@(HsUntypedBracket{}) = return e +addTickHsExpr e@(HsTypedSplice{}) = return e +addTickHsExpr e@(HsUntypedSplice{}) = return e +addTickHsExpr e@(HsGetField {}) = return e +addTickHsExpr e@(HsProjection {}) = return e +addTickHsExpr (HsProc x pat cmdtop) = + liftM2 (HsProc x) + (addTickLPat pat) + (traverse (addTickHsCmdTop) cmdtop) +addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) = + liftM (XExpr . WrapExpr . HsWrap w) $ + (addTickHsExpr e) -- Explicitly no tick on inside +addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) = + liftM (XExpr . ExpansionExpr . HsExpanded a) $ + (addTickHsExpr b) + +addTickHsExpr e@(XExpr (ConLikeTc {})) = return e + -- We used to do a freeVar on a pat-syn builder, but actually + -- such builders are never in the inScope env, which + -- doesn't include top level bindings + +-- We might encounter existing ticks (multiple Coverage passes) +addTickHsExpr (XExpr (HsTick t e)) = + liftM (XExpr . HsTick t) (addTickLHsExprNever e) +addTickHsExpr (XExpr (HsBinTick t0 t1 e)) = + liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e) + +addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) +addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e + ; return (Present x e') } +addTickTupArg (Missing ty) = return (Missing ty) + + +addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc) + -> TM (MatchGroup GhcTc (LHsExpr GhcTc)) +addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do + let isOneOfMany = matchesOneOfMany matches + matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam)) matches + return $ mg { mg_alts = L l matches' } + +addTickMatch :: Bool -> Bool -> 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 + return $ match { m_grhss = gRHSs' } + +addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc) + -> TM (GRHSs GhcTc (LHsExpr GhcTc)) +addTickGRHSs isOneOfMany isLambda (GRHSs x guarded local_binds) = + bindLocals binders $ do + local_binds' <- addTickHsLocalBinds local_binds + guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda)) guarded + return $ GRHSs x guarded' local_binds' + where + binders = collectLocalBinders CollNoDictBinders local_binds + +addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc) + -> TM (GRHS GhcTc (LHsExpr GhcTc)) +addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do + (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts + (addTickGRHSBody isOneOfMany isLambda expr) + return $ GRHS x stmts' expr' + +addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do + d <- getDensity + case d of + TickForCoverage -> addTickLHsExprOptAlt isOneOfMany expr + TickAllFunctions | isLambda -> + addPathEntry "\\" $ + allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $ + addTickHsExpr e0 + _otherwise -> + addTickLHsExprRHS expr + +addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] + -> TM [ExprLStmt GhcTc] +addTickLStmts isGuard stmts = do + (stmts, _) <- addTickLStmts' isGuard stmts (return ()) + return stmts + +addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a + -> TM ([ExprLStmt GhcTc], a) +addTickLStmts' isGuard lstmts res + = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $ + do { lstmts' <- mapM (traverse (addTickStmt isGuard)) lstmts + ; a <- res + ; return (lstmts', a) } + +addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc) + -> TM (Stmt GhcTc (LHsExpr GhcTc)) +addTickStmt _isGuard (LastStmt x e noret ret) = + liftM3 (LastStmt x) + (addTickLHsExpr e) + (pure noret) + (addTickSyntaxExpr hpcSrcSpan ret) +addTickStmt _isGuard (BindStmt xbs pat e) = + liftM4 (\b f -> BindStmt $ XBindStmtTc + { xbstc_bindOp = b + , xbstc_boundResultType = xbstc_boundResultType xbs + , xbstc_boundResultMult = xbstc_boundResultMult xbs + , xbstc_failOp = f + }) + (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs)) + (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs)) + (addTickLPat pat) + (addTickLHsExprRHS e) +addTickStmt isGuard (BodyStmt x e bind' guard') = + liftM3 (BodyStmt x) + (addTick isGuard e) + (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') +addTickStmt _isGuard (LetStmt x binds) = + liftM (LetStmt x) + (addTickHsLocalBinds binds) +addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = + liftM3 (ParStmt x) + (mapM (addTickStmtAndBinders isGuard) pairs) + (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) mzipExpr)) + (addTickSyntaxExpr hpcSrcSpan bindExpr) +addTickStmt isGuard (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 + , trS_ret = returnExpr, trS_bind = bindExpr + , trS_fmap = liftMExpr }) = do + t_s <- addTickLStmts isGuard stmts + t_y <- traverse addTickLHsExprRHS by + t_u <- addTickLHsExprRHS using + t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr + t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr + t_m <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) liftMExpr)) + return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u + , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } + +addTickStmt isGuard stmt@(RecStmt {}) + = do { stmts' <- addTickLStmts isGuard (unLoc $ recS_stmts stmt) + ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) + ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) + ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) + ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret' + , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } + +addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) +addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e + | otherwise = addTickLHsExprRHS e + +addTickApplicativeArg + :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc) + -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc) +addTickApplicativeArg isGuard (op, arg) = + liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg) + where + addTickArg (ApplicativeArgOne m_fail pat expr isBody) = + ApplicativeArgOne + <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail + <*> addTickLPat pat + <*> addTickLHsExpr expr + <*> pure isBody + addTickArg (ApplicativeArgMany x stmts ret pat ctxt) = + (ApplicativeArgMany x) + <$> addTickLStmts isGuard stmts + <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret)) + <*> addTickLPat pat + <*> pure ctxt + +addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc + -> TM (ParStmtBlock GhcTc GhcTc) +addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) = + liftM3 (ParStmtBlock x) + (addTickLStmts isGuard stmts) + (return ids) + (addTickSyntaxExpr hpcSrcSpan returnExpr) + +addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc) +addTickHsLocalBinds (HsValBinds x binds) = + liftM (HsValBinds x) + (addTickHsValBinds binds) +addTickHsLocalBinds (HsIPBinds x binds) = + liftM (HsIPBinds x) + (addTickHsIPBinds binds) +addTickHsLocalBinds (EmptyLocalBinds x) = return (EmptyLocalBinds x) + +addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a) + -> TM (HsValBindsLR GhcTc (GhcPass b)) +addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do + b <- liftM2 NValBinds + (mapM (\ (rec,binds') -> + liftM2 (,) + (return rec) + (addTickLHsBinds binds')) + binds) + (return sigs) + return $ XValBindsLR b +addTickHsValBinds _ = panic "addTickHsValBinds" + +addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc) +addTickHsIPBinds (IPBinds dictbinds ipbinds) = + liftM2 IPBinds + (return dictbinds) + (mapM (traverse (addTickIPBind)) ipbinds) + +addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc) +addTickIPBind (IPBind x nm e) = + liftM (IPBind x nm) + (addTickLHsExpr e) + +-- There is no location here, so we might need to use a context location?? +addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) +addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do + x' <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan pos) x)) + return $ syn { syn_expr = x' } +addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc + +-- we do not walk into patterns. +addTickLPat :: LPat GhcTc -> TM (LPat GhcTc) +addTickLPat pat = return pat + +addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc) +addTickHsCmdTop (HsCmdTop x cmd) = + liftM2 HsCmdTop + (return x) + (addTickLHsCmd cmd) + +addTickLHsCmd :: LHsCmd GhcTc -> TM (LHsCmd GhcTc) +addTickLHsCmd (L pos c0) = do + c1 <- addTickHsCmd c0 + return $ L pos c1 + +addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc) +addTickHsCmd (HsCmdLam x matchgroup) = + liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup) +addTickHsCmd (HsCmdApp x c e) = + liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e) +{- +addTickHsCmd (OpApp e1 c2 fix c3) = + liftM4 OpApp + (addTickLHsExpr e1) + (addTickLHsCmd c2) + (return fix) + (addTickLHsCmd c3) +-} +addTickHsCmd (HsCmdPar x lpar e rpar) = do + e' <- addTickLHsCmd e + return (HsCmdPar x lpar e' rpar) +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 + binds' <- addTickHsLocalBinds binds -- to think about: !patterns. + c' <- addTickLHsCmd c + return (HsCmdLet x tkLet binds' tkIn c') +addTickHsCmd (HsCmdDo srcloc (L l stmts)) + = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) + ; return (HsCmdDo srcloc (L l stmts')) } + +addTickHsCmd (HsCmdArrApp arr_ty e1 e2 ty1 lr) = + liftM5 HsCmdArrApp + (return arr_ty) + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (return ty1) + (return lr) +addTickHsCmd (HsCmdArrForm x e f fix cmdtop) = + liftM4 (HsCmdArrForm x) + (addTickLHsExpr e) + (return f) + (return fix) + (mapM (traverse (addTickHsCmdTop)) cmdtop) + +addTickHsCmd (XCmd (HsWrap w cmd)) = + liftM XCmd $ + liftM (HsWrap w) (addTickHsCmd cmd) + +-- Others should never happen in a command context. +--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) + +addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc) + -> TM (MatchGroup GhcTc (LHsCmd GhcTc)) +addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do + matches' <- mapM (traverse addTickCmdMatch) matches + return $ mg { mg_alts = L l matches' } + +addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) +addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) = + bindLocals (collectPatsBinders CollNoDictBinders pats) $ do + gRHSs' <- addTickCmdGRHSs gRHSs + return $ match { m_grhss = gRHSs' } + +addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc)) +addTickCmdGRHSs (GRHSs x guarded local_binds) = + bindLocals binders $ do + local_binds' <- addTickHsLocalBinds local_binds + guarded' <- mapM (traverse addTickCmdGRHS) guarded + return $ GRHSs x guarded' local_binds' + where + binders = collectLocalBinders CollNoDictBinders local_binds + +addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) +-- The *guards* are *not* Cmds, although the body is +-- C.f. addTickGRHS for the BinBox stuff +addTickCmdGRHS (GRHS x stmts cmd) + = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) + stmts (addTickLHsCmd cmd) + ; return $ GRHS x stmts' expr' } + +addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)] + -> TM [LStmt GhcTc (LHsCmd GhcTc)] +addTickLCmdStmts stmts = do + (stmts, _) <- addTickLCmdStmts' stmts (return ()) + return stmts + +addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a + -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a) +addTickLCmdStmts' lstmts res + = bindLocals binders $ do + lstmts' <- mapM (traverse addTickCmdStmt) lstmts + a <- res + return (lstmts', a) + where + binders = collectLStmtsBinders CollNoDictBinders lstmts + +addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc)) +addTickCmdStmt (BindStmt x pat c) = + liftM2 (BindStmt x) + (addTickLPat pat) + (addTickLHsCmd c) +addTickCmdStmt (LastStmt x c noret ret) = + liftM3 (LastStmt x) + (addTickLHsCmd c) + (pure noret) + (addTickSyntaxExpr hpcSrcSpan ret) +addTickCmdStmt (BodyStmt x c bind' guard') = + liftM3 (BodyStmt x) + (addTickLHsCmd c) + (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') +addTickCmdStmt (LetStmt x binds) = + liftM (LetStmt x) + (addTickHsLocalBinds binds) +addTickCmdStmt stmt@(RecStmt {}) + = do { stmts' <- addTickLCmdStmts (unLoc $ recS_stmts stmt) + ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) + ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) + ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) + ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret' + , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } +addTickCmdStmt 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) + = do { fields' <- mapM addTickHsRecField fields + ; return (HsRecFields fields' dd) } + +addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc) + -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc)) +addTickHsRecField (L l (HsFieldBind x id expr pun)) + = do { expr' <- addTickLHsExpr expr + ; return (L l (HsFieldBind x id expr' pun)) } + +addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) +addTickArithSeqInfo (From e1) = + liftM From + (addTickLHsExpr e1) +addTickArithSeqInfo (FromThen e1 e2) = + liftM2 FromThen + (addTickLHsExpr e1) + (addTickLHsExpr e2) +addTickArithSeqInfo (FromTo e1 e2) = + liftM2 FromTo + (addTickLHsExpr e1) + (addTickLHsExpr e2) +addTickArithSeqInfo (FromThenTo e1 e2 e3) = + liftM3 FromThenTo + (addTickLHsExpr e1) + (addTickLHsExpr e2) + (addTickLHsExpr e3) + +data TickTransState = TT { ticks :: !(SizedSeq Tick) + , ccIndices :: !CostCentreState + } + +initTTState :: TickTransState +initTTState = TT { ticks = emptySS + , ccIndices = newCostCentreState + } + +addMixEntry :: Tick -> TM Int +addMixEntry ent = do + c <- fromIntegral . sizeSS . ticks <$> getState + setState $ \st -> + st { ticks = addToSS (ticks st) ent + } + return c + +data TickTransEnv = TTE { fileName :: FastString + , density :: TickDensity + , tte_countEntries :: !Bool + -- ^ Whether the number of times functions are + -- entered should be counted. + , exports :: NameSet + , inlines :: VarSet + , declPath :: [String] + , inScope :: VarSet + , blackList :: Set RealSrcSpan + , this_mod :: Module + , tickishType :: TickishType + } + +-- deriving Show + +-- | Reasons why we need ticks, +data TickishType + -- | For profiling + = ProfNotes + -- | For Haskell Program Coverage + | HpcTicks + -- | For ByteCode interpreter break points + | Breakpoints + -- | For source notes + | SourceNotes + deriving (Eq) + +-- | Tickishs that only make sense when their source code location +-- refers to the current file. This might not always be true due to +-- LINE pragmas in the code - which would confuse at least HPC. +tickSameFileOnly :: TickishType -> Bool +tickSameFileOnly HpcTicks = True +tickSameFileOnly _other = False + +type FreeVars = OccEnv Id +noFVs :: FreeVars +noFVs = emptyOccEnv + +-- Note [freevars] +-- ~~~~~~~~~~~~~~~ +-- For breakpoints we want to collect the free variables of an +-- expression for pinning on the HsTick. We don't want to collect +-- *all* free variables though: in particular there's no point pinning +-- on free variables that are will otherwise be in scope at the GHCi +-- prompt, which means all top-level bindings. Unfortunately detecting +-- top-level bindings isn't easy (collectHsBindsBinders on the top-level +-- bindings doesn't do it), so we keep track of a set of "in-scope" +-- variables in addition to the free variables, and the former is used +-- to filter additions to the latter. This gives us complete control +-- over what free variables we track. + +newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) } + deriving (Functor) + -- a combination of a state monad (TickTransState) and a writer + -- monad (FreeVars). + +instance Applicative TM where + pure a = TM $ \ _env st -> (a,noFVs,st) + (<*>) = ap + +instance Monad TM where + (TM m) >>= k = TM $ \ env st -> + case m env st of + (r1,fv1,st1) -> + case unTM (k r1) env st1 of + (r2,fv2,st2) -> + (r2, fv1 `plusOccEnv` fv2, st2) + +-- | Get the next HPC cost centre index for a given centre name +getCCIndexM :: FastString -> TM CostCentreIndex +getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $ + ccIndices st + in (idx, noFVs, st { ccIndices = is' }) + +getState :: TM TickTransState +getState = TM $ \ _ st -> (st, noFVs, st) + +setState :: (TickTransState -> TickTransState) -> TM () +setState f = TM $ \ _ st -> ((), noFVs, f st) + +getEnv :: TM TickTransEnv +getEnv = TM $ \ env st -> (env, noFVs, st) + +withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a +withEnv f (TM m) = TM $ \ env st -> + case m (f env) st of + (a, fvs, st') -> (a, fvs, st') + +getDensity :: TM TickDensity +getDensity = TM $ \env st -> (density env, noFVs, st) + +ifDensity :: TickDensity -> TM a -> TM a -> TM a +ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el + +getFreeVars :: TM a -> TM (FreeVars, a) +getFreeVars (TM m) + = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st') + +freeVar :: Id -> TM () +freeVar id = TM $ \ env st -> + if id `elemVarSet` inScope env + then ((), unitOccEnv (nameOccName (idName id)) id, st) + else ((), noFVs, st) + +addPathEntry :: String -> TM a -> TM a +addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] }) + +getPathEntry :: TM [String] +getPathEntry = declPath `liftM` getEnv + +getFileName :: TM FastString +getFileName = fileName `liftM` getEnv + +isGoodSrcSpan' :: SrcSpan -> Bool +isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos +isGoodSrcSpan' (UnhelpfulSpan _) = False + +isGoodTickSrcSpan :: SrcSpan -> TM Bool +isGoodTickSrcSpan pos = do + file_name <- getFileName + tickish <- tickishType `liftM` getEnv + let need_same_file = tickSameFileOnly tickish + same_file = Just file_name == srcSpanFileName_maybe pos + return (isGoodSrcSpan' pos && (not need_same_file || same_file)) + +ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a +ifGoodTickSrcSpan pos then_code else_code = do + good <- isGoodTickSrcSpan pos + if good then then_code else else_code + +bindLocals :: [Id] -> TM a -> TM a +bindLocals new_ids (TM m) + = TM $ \ env st -> + case m env{ inScope = inScope env `extendVarSetList` new_ids } st of + (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st') + where occs = [ nameOccName (idName id) | id <- new_ids ] + +isBlackListed :: SrcSpan -> TM Bool +isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st) +isBlackListed (UnhelpfulSpan _) = return False + +-- the tick application inherits the source position of its +-- expression argument to support nested box allocations +allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc) + -> TM (LHsExpr GhcTc) +allocTickBox boxLabel countEntries topOnly pos m = + ifGoodTickSrcSpan pos (do + (fvs, e) <- getFreeVars m + env <- getEnv + tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env) + return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e)) + ) (do + e <- m + return (L (noAnnSrcSpan pos) e) + ) + +-- the tick application inherits the source position of its +-- expression argument to support nested box allocations +allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars + -> TM (Maybe CoreTickish) +allocATickBox boxLabel countEntries topOnly pos fvs = + ifGoodTickSrcSpan pos (do + let + mydecl_path = case boxLabel of + TopLevelBox x -> x + LocalBox xs -> xs + _ -> panic "allocATickBox" + tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path + return (Just tickish) + ) (return Nothing) + + +mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String] + -> TM CoreTickish +mkTickish boxLabel countEntries topOnly pos fvs decl_path = do + + let ids = filter (not . mightBeUnliftedType . idType) $ nonDetOccEnvElts fvs + -- unlifted types cause two problems here: + -- * we can't bind them at the GHCi prompt + -- (bindLocalsAtBreakpoint already filters them out), + -- * the simplifier might try to substitute a literal for + -- the Id, and we can't handle that. + + me = Tick + { tick_loc = pos + , tick_path = decl_path + , tick_ids = map (nameOccName.idName) ids + , tick_label = boxLabel + } + + cc_name | topOnly = head decl_path + | otherwise = 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 + count = countEntries && tte_countEntries env + return $ ProfNote cc count True{-scopes-} + + Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids + + SourceNotes | RealSrcSpan pos' _ <- pos -> + return $ SourceNote pos' cc_name + + _otherwise -> panic "mkTickish: bad source span!" + + +allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc) + -> TM (LHsExpr GhcTc) +allocBinTickBox boxLabel pos m = do + env <- getEnv + case tickishType env of + HpcTicks -> do e <- liftM (L (noAnnSrcSpan pos)) m + ifGoodTickSrcSpan pos + (mkBinTickBoxHpc boxLabel pos e) + (return e) + _other -> allocTickBox (ExpBox False) False False pos m + +mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc + -> TM (LHsExpr GhcTc) +mkBinTickBoxHpc boxLabel pos e = do + env <- getEnv + binTick <- HsBinTick + <$> addMixEntry (Tick { tick_loc = pos + , tick_path = declPath env + , tick_ids = [] + , tick_label = boxLabel True + }) + <*> addMixEntry (Tick { tick_loc = pos + , tick_path = declPath env + , tick_ids = [] + , tick_label = boxLabel False + }) + <*> pure e + tick <- HpcTick (this_mod env) + <$> addMixEntry (Tick { tick_loc = pos + , tick_path = declPath env + , tick_ids = [] + , tick_label = ExpBox False + }) + let pos' = noAnnSrcSpan pos + return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick)) + +hpcSrcSpan :: SrcSpan +hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") + +matchesOneOfMany :: [LMatch GhcTc body] -> Bool +matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 + where + matchCount :: LMatch GhcTc body -> Int + matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ })) + = length grhss diff --git a/GHC/HsToCore/Types.hs b/GHC/HsToCore/Types.hs --- a/GHC/HsToCore/Types.hs +++ b/GHC/HsToCore/Types.hs @@ -49,7 +49,7 @@ , ds_gbl_rdr_env :: GlobalRdrEnv -- needed *only* to know what newtype -- constructors are in scope during -- pattern-match satisfiability checking - , ds_unqual :: PrintUnqualified + , 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 diff --git a/GHC/HsToCore/Usage.hs b/GHC/HsToCore/Usage.hs --- a/GHC/HsToCore/Usage.hs +++ b/GHC/HsToCore/Usage.hs @@ -5,26 +5,30 @@ module GHC.HsToCore.Usage ( -- * Dependency/fingerprinting code (used by GHC.Iface.Make) mkUsageInfo, mkUsedNames, + + UsageConfig(..), ) where import GHC.Prelude import GHC.Driver.Env -import GHC.Driver.Session - import GHC.Tc.Types +import GHC.Iface.Load + import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Fingerprint import GHC.Utils.Panic +import GHC.Utils.Monad import GHC.Types.Name import GHC.Types.Name.Set ( NameSet, allUses ) import GHC.Types.Unique.Set import GHC.Unit +import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module.Imported import GHC.Unit.Module.ModIface @@ -32,6 +36,7 @@ import GHC.Data.Maybe +import Data.IORef import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map @@ -64,17 +69,24 @@ mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus -mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath] - -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded -> IO [Usage] -mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged needed_links needed_pkgs +data UsageConfig = UsageConfig + { 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 = do - eps <- hscEPS hsc_env - hashes <- mapM getFileHash dependent_files + eps <- liftIO $ readIORef (euc_eps (ue_eps unit_env)) + hashes <- liftIO $ mapM getFileHash dependent_files + let hu = unsafeGetHomeUnit unit_env + hug = ue_home_unit_graph unit_env -- Dependencies on object files due to TH and plugins - object_usages <- mkObjectUsage (eps_PIT eps) hsc_env needed_links needed_pkgs - let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod + 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 + mod_usages <- mk_mod_usage_info uc hu all_home_ids this_mod dir_imp_mods used_names - usages = mod_usages ++ [ UsageFile { usg_file_path = f + let usages = mod_usages ++ [ UsageFile { usg_file_path = f , usg_file_hash = hash , usg_file_label = Nothing } | (f, hash) <- zip dependent_files hashes ] @@ -151,18 +163,18 @@ -- | Find object files corresponding to the transitive closure of given home -- modules and direct object files for pkg dependencies -mkObjectUsage :: PackageIfaceTable -> HscEnv -> [Linkable] -> PkgsLoaded -> IO [Usage] -mkObjectUsage pit hsc_env th_links_needed th_pkgs_needed = do +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) 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 $ hsc_plugins hsc_env + (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 msg m = moduleNameString (moduleName m) ++ "[TH] changed" - fing mmsg fn = UsageFile fn <$> lookupFileCache (hsc_FC hsc_env) fn <*> pure mmsg + fing mmsg fn = UsageFile fn <$> lookupFileCache fc fn <*> pure mmsg unlinkedToUsage m ul = case nameOfObject_maybe ul of @@ -170,7 +182,7 @@ Nothing -> do -- This should only happen for home package things but oneshot puts -- home package ifaces in the PIT. - let miface = lookupIfaceByModule (hsc_HUG hsc_env) pit m + let miface = lookupIfaceByModule hug pit m case miface of Nothing -> pprPanic "mkObjectUsage" (ppr m) Just iface -> @@ -182,19 +194,17 @@ librarySpecToUsage (DLLPath fn) = traverse (fing Nothing) [fn] librarySpecToUsage _ = return [] -mk_mod_usage_info :: PackageIfaceTable - -> HscEnv +mk_mod_usage_info :: UsageConfig + -> HomeUnit + -> Set.Set UnitId -> Module -> ImportedMods -> NameSet - -> [Usage] -mk_mod_usage_info pit hsc_env this_mod direct_imports used_names - = mapMaybe mkUsage usage_mods + -> IfG [Usage] +mk_mod_usage_info uc home_unit home_unit_ids this_mod direct_imports used_names + = mapMaybeM mkUsageM usage_mods where - hpt = hsc_HUG hsc_env - dflags = hsc_dflags hsc_env - home_unit = hsc_home_unit hsc_env - home_unit_ids = hsc_all_home_unit_ids hsc_env + safe_implicit_imps_req = uc_safe_implicit_imps_req uc used_mods = moduleEnvKeys ent_map dir_imp_mods = moduleEnvKeys direct_imports @@ -228,22 +238,27 @@ in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ] where occ = nameOccName name + mkUsageM :: Module -> IfG (Maybe Usage) + mkUsageM mod | mod == this_mod -- We don't care about usages of things in *this* module + || moduleUnit mod == interactiveUnit -- ... or in GHCi + = return Nothing + mkUsageM mod = do + iface <- loadSysInterface (text "mk_mod_usage") mod + -- Make sure the interface is loaded even if we don't directly use + -- any symbols from it, to ensure determinism. See #22217. + return $ mkUsage mod iface + + -- We want to create a Usage for a home module if -- a) we used something from it; has something in used_names -- b) we imported it, even if we used nothing from it -- (need to recompile if its export list changes: export_fprint) - mkUsage :: Module -> Maybe Usage - mkUsage mod - | isNothing maybe_iface -- We can't depend on it if we didn't - -- load its interface. - || mod == this_mod -- We don't care about usages of - -- things in *this* module - = Nothing - + mkUsage :: Module -> ModIface -> Maybe Usage + mkUsage mod iface | toUnitId (moduleUnit mod) `Set.notMember` home_unit_ids - = Just UsagePackageModule{ usg_mod = mod, - usg_mod_hash = mod_hash, - usg_safe = imp_safe } + = Just $ UsagePackageModule{ usg_mod = mod, + usg_mod_hash = mod_hash, + usg_safe = imp_safe } -- for package modules, we record the module hash only | (null used_occs @@ -264,11 +279,6 @@ usg_entities = Map.toList ent_hashs, usg_safe = imp_safe } where - maybe_iface = lookupIfaceByModule hpt pit mod - -- In one-shot mode, the interfaces for home-package - -- modules accumulate in the PIT not HPT. Sigh. - - Just iface = maybe_iface 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) @@ -284,7 +294,7 @@ -- across all imports, why did the old code only look -- at the first import? Just bys -> (True, any by_is_safe bys) - Nothing -> (False, safeImplicitImpsReq dflags) + Nothing -> (False, safe_implicit_imps_req) -- Nothing case is for references to entities which were -- not directly imported (NB: the "implicit" Prelude import -- counts as directly imported! An entity is not directly diff --git a/GHC/HsToCore/Utils.hs b/GHC/HsToCore/Utils.hs --- a/GHC/HsToCore/Utils.hs +++ b/GHC/HsToCore/Utils.hs @@ -46,12 +46,13 @@ import GHC.Prelude +import Language.Haskell.Syntax.Basic (Boxity(..)) + import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply ) import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsSyntaxExpr ) import GHC.Hs import GHC.Hs.Syn.Type -import GHC.Tc.Utils.TcType( tcSplitTyConApp ) import GHC.Core import GHC.HsToCore.Monad @@ -66,7 +67,6 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Builtin.Types -import GHC.Types.Basic import GHC.Core.ConLike import GHC.Types.Unique.Set import GHC.Types.Unique.Supply @@ -142,7 +142,7 @@ -- multiplicity stored within the variable -- itself. It's easier to pull it from the -- variable, so we ignore the multiplicity. -selectMatchVar _w (AsPat _ var _) = assert (isManyDataConTy _w ) (return (unLoc var)) +selectMatchVar _w (AsPat _ var _ _) = assert (isManyTy _w ) (return (unLoc var)) selectMatchVar w other_pat = newSysLocalDs w (hsPatType other_pat) {- Note [Localise pattern binders] @@ -421,7 +421,7 @@ Adding 'f x False = error "Non-exhaustive pattern..."' would violate the linearity of x. -Instead, we use 'f x False = case error "Non-exhausive pattern..." :: () of {}'. +Instead, we use 'f x False = case error "Non-exhaustive pattern..." :: () of {}'. This case expression accounts for linear variables by assigning bottom usage (See Note [Bottom as a usage] in GHC.Core.Multiplicity). This is done in mkErrorAppDs, called from mkFailExpr. @@ -471,14 +471,12 @@ Consider, f x y = x `seq` (y `seq` (# x,y #)) - The [Core let/app invariant] means that, other things being equal, because - the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus: + 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 for two reasons: - (a) we now evaluate y before x, and - (b) we can't bind v to an unboxed pair + 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 #) @@ -495,7 +493,7 @@ 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 contet, we'll + 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: @@ -541,7 +539,7 @@ case_bndr = case arg1 of Var v1 | isInternalName (idName v1) -> v1 -- Note [Desugaring seq], points (2) and (3) - _ -> mkWildValBinder Many ty1 + _ -> mkWildValBinder ManyTy ty1 mkCoreAppDs _ (Var f `App` Type _r) arg | f `hasKey` noinlineIdKey -- See Note [noinlineId magic] in GHC.Types.Id.Make @@ -631,7 +629,7 @@ Note that we return 't' as the variable to force if the pattern is strict (i.e. with -XStrict or an outermost-bang-pattern) - Note that (A) /includes/ the situation where + Note that (C) /includes/ the situation where * The pattern binds exactly one variable let !(Just (Just x) = e in body @@ -641,7 +639,8 @@ in t `seq` body 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'. + but does not force 'v'. That's why we call `mkBigCoreVarTupSolo` + in `mkSeletcorBinds` * The pattern binds no variables let !(True,False) = e in body @@ -739,7 +738,7 @@ | is_flat_prod_lpat pat' -- Special case (B) = do { let pat_ty = hsLPatType pat' - ; val_var <- newSysLocalDs Many pat_ty + ; val_var <- newSysLocalDs ManyTy pat_ty ; let mk_bind tick bndr_var -- (mk_bind sv bv) generates bv = case sv of { pat -> bv } @@ -757,13 +756,13 @@ ; return ( val_var, (val_var, val_expr) : binds) } | otherwise -- General case (C) - = do { tuple_var <- newSysLocalDs Many tuple_ty + = do { tuple_var <- newSysLocalDs ManyTy tuple_ty ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat') ; tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr ; let mk_tup_bind tick binder = (binder, mkOptTickBox tick $ - mkTupleSelector1 local_binders binder + mkBigTupleSelectorSolo local_binders binder tuple_var (Var tuple_var)) tup_binds = zipWith mk_tup_bind ticks' binders ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) } @@ -776,7 +775,7 @@ ticks' = ticks ++ repeat [] local_binders = map localiseId binders -- See Note [Localise pattern binders] - local_tuple = mkBigCoreVarTup1 binders + local_tuple = mkBigCoreVarTupSolo binders tuple_ty = exprType local_tuple strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p) @@ -822,7 +821,7 @@ mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc mkLHsPatTup [] = noLocA $ mkVanillaTuplePat [] Boxed mkLHsPatTup [lpat] = lpat -mkLHsPatTup lpats = L (getLoc (head lpats)) $ +mkLHsPatTup lpats@(L l _:_) = L l $ mkVanillaTuplePat lpats Boxed mkVanillaTuplePat :: [LPat GhcTc] -> Boxity -> Pat GhcTc @@ -914,11 +913,11 @@ CoreExpr) -- Fail variable applied to realWorld# -- See Note [Failure thunks and CPR] mkFailurePair expr - = do { fail_fun_var <- newFailLocalDs Many (unboxedUnitTy `mkVisFunTyMany` ty) - ; fail_fun_arg <- newSysLocalDs Many unboxedUnitTy + = do { fail_fun_var <- newFailLocalDs ManyTy (unboxedUnitTy `mkVisFunTyMany` ty) + ; fail_fun_arg <- newSysLocalDs ManyTy unboxedUnitTy ; let real_arg = setOneShotLambda fail_fun_arg ; return (NonRec fail_fun_var (Lam real_arg expr), - App (Var fail_fun_var) (Var voidPrimId)) } + App (Var fail_fun_var) unboxedUnitExpr) } where ty = exprType expr @@ -939,8 +938,8 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (This note predates join points as formal entities (hence the quotation marks). We can't use actual join points here (see above); if we did, this would also -solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR -join points] in GHC.Core.Opt.WorkWrap.) +solve the CPR problem, since join points don't get CPR'd. See Note [Don't w/w +join points for CPR] in GHC.Core.Opt.WorkWrap.) When we make a failure point we ensure that it does not look like a thunk. Example: @@ -998,7 +997,7 @@ mkBinaryTickBox ixT ixF e = do uq <- newUnique this_mod <- getModule - let bndr1 = mkSysLocal (fsLit "t1") uq One boolTy + let bndr1 = mkSysLocal (fsLit "t1") uq OneTy boolTy -- It's always sufficient to pattern-match on a boolean with -- multiplicity 'One'. let @@ -1067,7 +1066,7 @@ -- Returns Just {..} if we're sure that the expression is True -- I.e. * 'True' datacon -- * 'otherwise' Id --- * Trivial wappings of these +-- * Trivial wrappings of these -- The arguments to Just are any HsTicks that we have found, -- because we still want to tick then, even it they are always evaluated. isTrueLHsExpr (L _ (HsVar _ (L _ v))) diff --git a/GHC/Iface/Binary.hs b/GHC/Iface/Binary.hs --- a/GHC/Iface/Binary.hs +++ b/GHC/Iface/Binary.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BinaryLiterals, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE BinaryLiterals, ScopedTypeVariables #-} -- -- (c) The University of Glasgow 2002-2006 @@ -15,7 +15,6 @@ readBinIface, readBinIfaceHeader, getSymtabName, - getDictFastString, CheckHiWay(..), TraceBinIFace(..), getWithUserData, @@ -24,11 +23,8 @@ -- * Internal serialisation functions getSymbolTable, putName, - putDictionary, - putFastString, putSymbolTable, BinSymbolTable(..), - BinDictionary(..) ) where import GHC.Prelude @@ -48,7 +44,6 @@ import GHC.Types.Name.Cache import GHC.Types.SrcLoc import GHC.Platform -import GHC.Data.FastString import GHC.Settings.Constants import GHC.Utils.Fingerprint @@ -118,7 +113,7 @@ check_tag <- get bh let tag = profileBuildTag profile - wantedGot "Way" tag check_tag ppr + wantedGot "Way" tag check_tag text when (checkHiWay == CheckHiWay) $ errorOnMismatch "mismatched interface file profile tag" tag check_tag @@ -153,31 +148,28 @@ -- Names or FastStrings. getWithUserData :: Binary a => NameCache -> BinHandle -> IO a getWithUserData name_cache bh = do + bh <- getTables name_cache bh + get bh + +-- | 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 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_p <- Binary.get bh - data_p <- tellBin bh -- Remember where we are now - seekBin bh dict_p - dict <- getDictionary bh - seekBin bh data_p -- Back to where we were before + dict <- Binary.forwardGet bh (getDictionary bh) -- Initialise the user-data field of bh - bh <- do - bh <- return $ setUserData bh $ newReadState (error "getSymtabName") - (getDictFastString dict) - symtab_p <- Binary.get bh -- Get the symtab ptr - data_p <- tellBin bh -- Remember where we are now - seekBin bh symtab_p - symtab <- getSymbolTable bh name_cache - seekBin bh data_p -- Back to where we were before + let bh_fs = setUserData bh $ newReadState (error "getSymtabName") + (getDictFastString dict) - -- It is only now that we know how to get a Name - return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab) - (getDictFastString dict) + symtab <- Binary.forwardGet bh_fs (getSymbolTable bh_fs name_cache) - -- Read the interface file - get bh + -- It is only now that we know how to get a Name + return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab) + (getDictFastString dict) -- | Write an interface file writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO () @@ -211,67 +203,66 @@ -- This segment should be read using `getWithUserData`. putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO () putWithUserData traceBinIface bh payload = do - -- Remember where the dictionary pointer will go - dict_p_p <- tellBin bh - -- Placeholder for ptr to dictionary - put_ bh dict_p_p + (name_count, fs_count, _b) <- putWithTables bh (\bh' -> put bh' payload) - -- Remember where the symbol table pointer will go - symtab_p_p <- tellBin bh - put_ bh symtab_p_p - -- Make some initial state + case traceBinIface of + QuietBinIFace -> return () + TraceBinIFace printer -> do + printer (text "writeBinIface:" <+> int name_count + <+> text "Names") + printer (text "writeBinIface:" <+> int fs_count + <+> text "dict entries") + +-- | Write name/symbol tables +-- +-- 1. setup the given BinHandle with Name/FastString table handling +-- 2. write the following +-- - FastString table pointer +-- - Name table pointer +-- - payload +-- - Name table +-- - FastString table +-- +-- It returns (number of names, number of FastStrings, 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 } - dict_next_ref <- newFastMutInt 0 - dict_map_ref <- newIORef emptyUFM - let bin_dict = BinDictionary { - bin_dict_next = dict_next_ref, - bin_dict_map = dict_map_ref } + let bin_symtab = BinSymbolTable + { bin_symtab_next = symtab_next + , bin_symtab_map = symtab_map + } - -- Put the main thing, - bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab) - (putName bin_dict bin_symtab) - (putFastString bin_dict) - put_ bh payload + (bh_fs, bin_dict, put_dict) <- initFSTable bh - -- Write the symtab pointer at the front of the file - symtab_p <- tellBin bh -- This is where the symtab will start - putAt bh symtab_p_p symtab_p -- Fill in the placeholder - seekBin bh symtab_p -- Seek back to the end of the file + (fs_count,(name_count,r)) <- forwardPut bh (const put_dict) $ do - -- Write the symbol table itself - symtab_next <- readFastMutInt symtab_next - symtab_map <- readIORef symtab_map - putSymbolTable bh symtab_next symtab_map - case traceBinIface of - QuietBinIFace -> return () - TraceBinIFace printer -> - printer (text "writeBinIface:" <+> int symtab_next - <+> text "Names") + -- 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 - -- NB. write the dictionary after the symbol table, because - -- writing the symbol table may create more dictionary entries. + forwardPut bh_fs (const put_symtab) $ do - -- Write the dictionary pointer at the front of the file - dict_p <- tellBin bh -- This is where the dictionary will start - putAt bh dict_p_p dict_p -- Fill in the placeholder - seekBin bh dict_p -- Seek back to the end of the file + -- 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 - -- Write the dictionary itself - dict_next <- readFastMutInt dict_next_ref - dict_map <- readIORef dict_map_ref - putDictionary bh dict_next dict_map - case traceBinIface of - QuietBinIFace -> return () - TraceBinIFace printer -> - printer (text "writeBinIface:" <+> int dict_next - <+> text "dict entries") + put_payload bh_name + return (name_count, fs_count, r) + -- | Initial ram buffer to allocate for writing interface files initBinMemSize :: Int initBinMemSize = 1024 * 1024 @@ -287,9 +278,9 @@ -- putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO () -putSymbolTable bh next_off symtab = do - put_ bh next_off - let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab)) +putSymbolTable bh name_count symtab = do + put_ bh name_count + let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab)) -- It's OK to use nonDetEltsUFM here because the elements have -- indices that array uses to create order mapM_ (\n -> serialiseName bh n symtab) names @@ -340,7 +331,7 @@ -- See Note [Symbol table representation of names] -putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO () +putName :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO () putName _dict BinSymbolTable{ bin_symtab_map = symtab_map_ref, bin_symtab_next = symtab_next } @@ -381,7 +372,7 @@ in return $! case lookupKnownKeyName u of Nothing -> pprPanic "getSymtabName:unknown known-key unique" - (ppr i $$ ppr (unpkUnique u)) + (ppr i $$ ppr u $$ char tag $$ ppr ix) Just n -> n _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) @@ -390,32 +381,5 @@ bin_symtab_next :: !FastMutInt, -- The next index to use bin_symtab_map :: !(IORef (UniqFM Name (Int,Name))) -- indexed by Name - } - -putFastString :: BinDictionary -> BinHandle -> FastString -> IO () -putFastString dict bh fs = allocateFastString dict fs >>= put_ bh - -allocateFastString :: BinDictionary -> FastString -> IO Word32 -allocateFastString BinDictionary { bin_dict_next = j_r, - bin_dict_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) - -getDictFastString :: Dictionary -> BinHandle -> IO FastString -getDictFastString dict bh = do - j <- get bh - return $! (dict ! fromIntegral (j :: Word32)) - -data BinDictionary = BinDictionary { - bin_dict_next :: !FastMutInt, -- The next index to use - bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString))) - -- indexed by FastString } diff --git a/GHC/Iface/Errors.hs b/GHC/Iface/Errors.hs --- a/GHC/Iface/Errors.hs +++ b/GHC/Iface/Errors.hs @@ -46,7 +46,7 @@ -- are the same withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ -- we want the Modules below to be qualified with package names, - -- so reset the PrintUnqualified setting. + -- so reset the NamePprCtx setting. hsep [ text "Something is amiss; requested module " , ppr requested_mod , text "differs from name found in the interface file" 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 @@ -23,7 +23,7 @@ import GHC.Utils.Outputable(ppr) -import GHC.Prelude +import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Types.Avail ( Avails ) import GHC.Data.Bag ( Bag, bagToList ) @@ -61,7 +61,7 @@ import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils -import GHC.Unit.Module ( ModuleName, ml_hs_file ) +import GHC.Unit.Module ( ml_hs_file ) import GHC.Unit.Module.ModSummary import qualified Data.Array as A @@ -69,7 +69,10 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Data ( Data, Typeable ) +import Data.Foldable ( toList ) import Data.Functor.Identity ( Identity(..) ) +import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) +import qualified Data.List.NonEmpty as NE import Data.Void ( Void, absurd ) import Control.Monad ( forM_ ) import Control.Monad.Trans.State.Strict @@ -320,7 +323,7 @@ runIdentity $ flip evalStateT initState $ flip runReaderT SourceInfo $ do tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts rasts <- processGrp hsGrp - imps <- toHie $ filter (not . ideclImplicit . unLoc) imports + imps <- toHie $ filter (not . ideclImplicit . ideclExt . unLoc) imports exps <- toHie $ fmap (map $ IEC Export . fst) exports docs <- toHie docs -- Add Instance bindings @@ -332,10 +335,11 @@ Nothing -> pure () Just c -> forM_ (classSCSelIds c) $ \v -> addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing) - let spanFile file children = case children of - [] -> realSrcLocSpan (mkRealSrcLoc file 1 1) - _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children) - (realSrcSpanEnd $ nodeSpan $ last children) + let spanFile file children = case nonEmpty children of + Nothing -> realSrcLocSpan (mkRealSrcLoc file 1 1) + Just children -> mkRealSrcSpan + (realSrcSpanStart $ nodeSpan (NE.head children)) + (realSrcSpanEnd $ nodeSpan (NE.last children)) flat_asts = concat [ tasts @@ -377,8 +381,9 @@ let asts = HieASTs $ resolveTyVarScopes asts' return asts - where - processGrp grp = concatM + +processGrp :: HsGroup GhcRn -> HieM [HieAST Type] +processGrp grp = concatM [ toHie $ fmap (RS ModuleScope ) hs_valds grp , toHie $ hs_splcds grp , toHie $ hs_tyclds grp @@ -495,15 +500,15 @@ map (\(RS sc a) -> PS rsp useScope sc a) $ listScopes patScope xs --- | 'listScopes' specialised to 'HsPatSigType' -tScopes +-- | 'listScopes' specialised to 'HsConPatTyArg' +taScopes :: Scope -> Scope - -> [HsPatSigType (GhcPass a)] + -> [HsConPatTyArg (GhcPass a)] -> [TScoped (HsPatSigType (GhcPass a))] -tScopes scope rhsScope xs = +taScopes scope rhsScope xs = map (\(RS sc a) -> TS (ResolvedScopes [scope, sc]) (unLoc a)) $ - listScopes rhsScope (map (\hsps -> L (getLoc $ hsps_body hsps) hsps) xs) + 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. @@ -555,6 +560,9 @@ loc [] = noSrcSpan loc xs = foldl1' combineSrcSpans $ map loc xs +instance HasLoc a => HasLoc (DataDefnCons a) where + loc = loc . toList + instance (HasLoc a, HiePass p) => HasLoc (FamEqn (GhcPass p) a) where loc (FamEqn _ a outer_bndrs b _ c) = case outer_bndrs of HsOuterImplicit{} -> @@ -588,6 +596,12 @@ instance (ToHie a) => ToHie [a] where toHie = concatMapM toHie +instance (ToHie a) => ToHie (NonEmpty a) where + toHie = concatMapM toHie + +instance (ToHie a) => ToHie (DataDefnCons a) where + toHie = concatMapM toHie + instance (ToHie a) => ToHie (Bag a) where toHie = toHie . bagToList @@ -744,9 +758,6 @@ RecordCon con_expr _ _ -> computeType con_expr ExprWithTySig _ e _ -> computeLType e HsPragE _ _ e -> computeLType e - -- By this point all splices are lifted into splice environments so - -- the remaining HsSpliceE in the syntax tree contain bogus information. - HsSpliceE {} -> Nothing XExpr (ExpansionExpr (HsExpanded (HsGetField _ _ _) e)) -> Just (hsExprType e) -- for record-dot-syntax XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e XExpr (HsTick _ e) -> computeLType e @@ -802,7 +813,7 @@ , Data (AmbiguousFieldOcc (GhcPass p)) , Data (HsCmdTop (GhcPass p)) , Data (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) - , Data (HsSplice (GhcPass p)) + , Data (HsUntypedSplice (GhcPass p)) , Data (HsLocalBinds (GhcPass p)) , Data (FieldOcc (GhcPass p)) , Data (HsTupArg (GhcPass p)) @@ -839,11 +850,11 @@ instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where toHie (BC context scope b@(L span bind)) = concatM $ getTypeNode b : case bind of - FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} -> + FunBind{fun_id = name, fun_matches = matches, fun_ext = ext} -> [ toHie $ C (ValBind context scope $ getRealSpanA span) name , toHie matches , case hiePass @p of - HieTc -> toHie $ L span wrap + HieTc | (wrap, _) <- ext -> toHie $ L span wrap _ -> pure [] ] PatBind{pat_lhs = lhs, pat_rhs = rhs} -> @@ -883,11 +894,14 @@ , ToHie (LocatedA (body (GhcPass p))) ) => ToHie (MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))) where toHie mg = case mg of - MG{ mg_alts = (L span alts) , mg_origin = origin} -> + MG{ mg_alts = (L span alts) } -> local (setOrigin origin) $ concatM [ locOnly (locA span) , toHie alts ] + where origin = case hiePass @p of + HieRn -> mg_ext mg + HieTc -> mg_origin $ mg_ext mg setOrigin :: Origin -> NodeOrigin -> NodeOrigin setOrigin FromSource _ = SourceInfo @@ -964,7 +978,7 @@ LazyPat _ p -> [ toHie $ PS rsp scope pscope p ] - AsPat _ lname pat -> + AsPat _ lname _ pat -> [ toHie $ C (PatternBind scope (combineScopes (mkLScopeA pat) pscope) rsp) @@ -1039,9 +1053,11 @@ ] ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ] where - contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType GhcRn) a (HsRecFields (GhcPass p) a) + 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 (tScopes scope argscope tyargs) (patScopes rsp scope pscope args) + contextify (PrefixCon tyargs args) = + PrefixCon (taScopes scope argscope tyargs) + (patScopes rsp scope pscope args) where argscope = foldr combineScopes NoScope $ map mkLScopeA args contextify (InfixCon a b) = InfixCon a' b' where [a', b'] = patScopes rsp scope pscope [a,b] @@ -1105,7 +1121,7 @@ [ toHie a , toHie b ] - HsAppType _ expr sig -> + HsAppType _ expr _ sig -> [ toHie expr , toHie $ TS (ResolvedScopes []) sig ] @@ -1203,11 +1219,14 @@ [ toHie b , toHie xbracket ] - HieTc | HsBracketTc _ _ _ p <- xbracket -> - [ toHie b + HieTc | HsBracketTc q _ _ p <- xbracket -> + [ toHie q , toHie p ] - HsSpliceE _ x -> + HsTypedSplice _ x -> + [ toHie x + ] + HsUntypedSplice _ x -> [ toHie $ L mspan x ] HsGetField {} -> [] @@ -1468,8 +1487,8 @@ quant_scope = mkLScopeA $ 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 $ map mkLScopeA $ dd_cons defn - deriv_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_derivs defn + con_sc = foldr combineScopes NoScope $ mkLScopeA <$> dd_cons defn + deriv_sc = foldr combineScopes NoScope $ mkLScopeA <$> dd_derivs defn ClassDecl { tcdCtxt = context , tcdLName = name , tcdTyVars = vars @@ -1562,7 +1581,7 @@ ] instance ToHie (HsDataDefn GhcRn) where - toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM + toHie (HsDataDefn _ ctx _ mkind cons derivs) = concatM [ toHie ctx , toHie mkind , toHie cons @@ -1605,7 +1624,7 @@ ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ , con_doc = doc} -> - [ toHie $ map (C (Decl ConDec $ getRealSpanA span)) names + [ 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) @@ -1693,7 +1712,6 @@ _ -> toHie $ map (C $ TyDecl) names , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ ] - IdSig _ _ -> [] FixSig _ fsig -> [ toHie $ L sp fsig ] @@ -1704,21 +1722,22 @@ [ toHie $ (C Use) name , toHie $ map (TS (ResolvedScopes [])) typs ] - SpecInstSig _ _ typ -> + SpecInstSig _ typ -> [ toHie $ TS (ResolvedScopes []) typ ] - MinimalSig _ _ form -> + MinimalSig _ form -> [ toHie form ] - SCCFunSig _ _ name mtxt -> + SCCFunSig _ name mtxt -> [ toHie $ (C Use) name , maybe (pure []) (locOnly . getLocA) mtxt ] - CompleteMatchSig _ _ (L ispan names) typ -> + CompleteMatchSig _ (L ispan names) typ -> [ locOnly ispan , 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 : @@ -1872,8 +1891,13 @@ [ toHie splice ] -instance ToHie (HsQuote a) where - toHie _ = pure [] +instance ToHie (HsQuote GhcRn) where + toHie (ExpBr _ e) = toHie e + toHie (PatBr _ b) = toHie (PS Nothing NoScope NoScope b) + toHie (DecBrL {} ) = pure [] + toHie (DecBrG _ decls) = processGrp decls + toHie (TypBr _ ty) = toHie ty + toHie (VarBr {} ) = pure [] instance ToHie PendingRnSplice where toHie (PendingRnSplice _ _ e) = toHie e @@ -1899,25 +1923,14 @@ instance ToHie (LocatedAn NoEpAnns HsIPName) where toHie (L span e) = makeNodeA e span -instance HiePass p => ToHie (LocatedA (HsSplice (GhcPass p))) where +instance HiePass p => ToHie (LocatedA (HsUntypedSplice (GhcPass p))) where toHie (L span sp) = concatM $ makeNodeA sp span : case sp of - HsTypedSplice _ _ _ expr -> - [ toHie expr - ] - HsUntypedSplice _ _ _ expr -> + HsUntypedSpliceExpr _ expr -> [ toHie expr ] - HsQuasiQuote _ _ _ ispan _ -> - [ locOnly ispan + HsQuasiQuote _ _ ispanFs -> + [ locOnly (getLocA ispanFs) ] - HsSpliced _ _ _ -> - [] - XSplice x -> case hiePass @p of -#if __GLASGOW_HASKELL__ < 811 - HieRn -> dataConCantHappen x -#endif - HieTc -> case x of - HsSplicedT _ -> [] instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where toHie (L span annot) = concatM $ makeNodeA annot span : case annot of @@ -2000,22 +2013,22 @@ , toHie fe ] -instance ToHie ForeignImport where - toHie (CImport (L a _) (L b _) _ _ (L c _)) = concatM $ +instance ToHie (ForeignImport GhcRn) where + toHie (CImport (L c _) (L a _) (L b _) _ _) = concatM $ [ locOnly a , locOnly b , locOnly c ] -instance ToHie ForeignExport where - toHie (CExport (L a _) (L b _)) = concatM $ +instance ToHie (ForeignExport GhcRn) where + toHie (CExport (L b _) (L a _)) = concatM $ [ locOnly a , locOnly b ] instance ToHie (LocatedA (WarnDecls GhcRn)) where toHie (L span decl) = concatM $ makeNodeA decl span : case decl of - Warnings _ _ warnings -> + Warnings _ warnings -> [ toHie warnings ] @@ -2027,7 +2040,7 @@ instance ToHie (LocatedA (AnnDecl GhcRn)) where toHie (L span decl) = concatM $ makeNodeA decl span : case decl of - HsAnnotation _ _ prov expr -> + HsAnnotation _ prov expr -> [ toHie prov , toHie expr ] @@ -2039,7 +2052,7 @@ instance ToHie (LocatedA (RuleDecls GhcRn)) where toHie (L span decl) = concatM $ makeNodeA decl span : case decl of - HsRules _ _ rules -> + HsRules _ rules -> [ toHie rules ] @@ -2069,7 +2082,7 @@ instance ToHie (LocatedA (ImportDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of - ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> + ImportDecl { ideclName = name, ideclAs = as, ideclImportList = hidden } -> [ toHie $ IEC Import name , toHie $ fmap (IEC ImportAs) as , maybe (pure []) goIE hidden @@ -2080,8 +2093,13 @@ , toHie $ map (IEC c) liens ] where - c = if hiding then ImportHiding else Import + -- ROMES:TODO: I notice some overlap here with Iface types, eventually + -- we could join these + c = case hiding of + Exactly -> Import + EverythingBut -> ImportHiding + instance ToHie (IEContext (LocatedA (IE GhcRn))) where toHie (IEC c (L span ie)) = concatM $ makeNode ie (locA span) : case ie of IEVar _ n -> @@ -2105,16 +2123,16 @@ IEDoc _ d -> [toHie d] IEDocNamed _ _ -> [] -instance ToHie (IEContext (LIEWrappedName Name)) where +instance ToHie (IEContext (LocatedA (IEWrappedName GhcRn))) where toHie (IEC c (L span iewn)) = concatM $ makeNodeA iewn span : case iewn of - IEName n -> - [ toHie $ C (IEThing c) n + IEName _ (L l n) -> + [ toHie $ C (IEThing c) (L l n) ] - IEPattern _ p -> - [ toHie $ C (IEThing c) p + IEPattern _ (L l p) -> + [ toHie $ C (IEThing c) (L l p) ] - IEType _ n -> - [ toHie $ C (IEThing c) n + IEType _ (L l n) -> + [ toHie $ C (IEThing c) (L l n) ] instance ToHie (IEContext (Located FieldLabel)) where 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 @@ -21,7 +21,6 @@ import GHC.Settings.Config ( cProjectVersion ) import GHC.Prelude import GHC.Utils.Binary -import GHC.Iface.Binary ( getDictFastString ) import GHC.Data.FastMutInt import GHC.Data.FastString ( FastString ) import GHC.Types.Name @@ -331,7 +330,7 @@ KnownKeyName u -> case lookupKnownKeyName u of Nothing -> pprPanic "fromHieName:unknown known-key unique" - (ppr (unpkUnique u)) + (ppr u) Just n -> pure n -- ** Reading and writing `HieName`'s @@ -339,10 +338,10 @@ putHieName :: BinHandle -> HieName -> IO () putHieName bh (ExternalName mod occ span) = do putByte bh 0 - put_ bh (mod, occ, span) + put_ bh (mod, occ, BinSrcSpan span) putHieName bh (LocalName occName span) = do putByte bh 1 - put_ bh (occName, span) + put_ bh (occName, BinSrcSpan span) putHieName bh (KnownKeyName uniq) = do putByte bh 2 put_ bh $ unpkUnique uniq @@ -353,10 +352,10 @@ case t of 0 -> do (modu, occ, span) <- get bh - return $ ExternalName modu occ span + return $ ExternalName modu occ $ unBinSrcSpan span 1 -> do (occ, span) <- get bh - return $ LocalName occ span + return $ LocalName occ $ unBinSrcSpan span 2 -> do (c,i) <- get bh return $ KnownKeyName $ mkUnique c i 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 @@ -28,7 +28,6 @@ import GHC.Types.Avail import GHC.Types.Unique import qualified GHC.Utils.Outputable as O ( (<>) ) -import GHC.Utils.Misc import GHC.Utils.Panic import qualified Data.Array as A @@ -41,6 +40,7 @@ import Control.Applicative ( (<|>) ) import Data.Coerce ( coerce ) import Data.Function ( on ) +import qualified Data.Semigroup as S type Span = RealSrcSpan @@ -143,7 +143,7 @@ = HTyVarTy Name | HAppTy a (HieArgs a) | HTyConApp IfaceTyCon (HieArgs a) - | HForAllTy ((Name, a),ArgFlag) a + | HForAllTy ((Name, a),ForAllTyFlag) a | HFunTy a a a | HQualTy a a -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy') | HLitTy IfaceTyLit @@ -206,7 +206,7 @@ -- | A list of type arguments along with their respective visibilities (ie. is --- this an argument that would return 'True' for 'isVisibleArgFlag'?). +-- this an argument that would return 'True' for 'isVisibleForAllTyFlag'?). newtype HieArgs a = HieArgs [(Bool,a)] deriving (Functor, Foldable, Traversable, Eq) @@ -251,12 +251,12 @@ instance Binary (HieAST TypeIndex) where put_ bh ast = do put_ bh $ sourcedNodeInfo ast - put_ bh $ nodeSpan ast + put_ bh $ BinSpan $ nodeSpan ast put_ bh $ nodeChildren ast get bh = Node <$> get bh - <*> get bh + <*> (unBinSpan <$> get bh) <*> get bh instance Outputable a => Outputable (HieAST a) where @@ -486,19 +486,19 @@ putByte bh 3 put_ bh bt put_ bh sc - put_ bh msp + put_ bh $ BinSpan <$> msp put_ bh (PatternBind a b c) = do putByte bh 4 put_ bh a put_ bh b - put_ bh c + put_ bh $ BinSpan <$> c put_ bh (ClassTyDecl sp) = do putByte bh 5 - put_ bh sp + put_ bh $ BinSpan <$> sp put_ bh (Decl a b) = do putByte bh 6 put_ bh a - put_ bh b + put_ bh $ BinSpan <$> b put_ bh (TyVarBind a b) = do putByte bh 7 put_ bh a @@ -506,13 +506,13 @@ put_ bh (RecField a b) = do putByte bh 8 put_ bh a - put_ bh b + put_ bh $ BinSpan <$> b put_ bh MatchBind = putByte bh 9 put_ bh (EvidenceVarBind a b c) = do putByte bh 10 put_ bh a put_ bh b - put_ bh c + put_ bh $ BinSpan <$> c put_ bh EvidenceVarUse = putByte bh 11 get bh = do @@ -521,14 +521,14 @@ 0 -> return Use 1 -> IEThing <$> get bh 2 -> return TyDecl - 3 -> ValBind <$> get bh <*> get bh <*> get bh - 4 -> PatternBind <$> get bh <*> get bh <*> get bh - 5 -> ClassTyDecl <$> get bh - 6 -> Decl <$> get bh <*> get bh + 3 -> ValBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh) + 4 -> PatternBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh) + 5 -> ClassTyDecl <$> (fmap unBinSpan <$> get bh) + 6 -> Decl <$> get bh <*> (fmap unBinSpan <$> get bh) 7 -> TyVarBind <$> get bh <*> get bh - 8 -> RecField <$> get bh <*> get bh + 8 -> RecField <$> get bh <*> (fmap unBinSpan <$> get bh) 9 -> return MatchBind - 10 -> EvidenceVarBind <$> get bh <*> get bh <*> get bh + 10 -> EvidenceVarBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh) 11 -> return EvidenceVarUse _ -> panic "Binary ContextInfo: invalid tag" @@ -621,7 +621,7 @@ ppr RecFieldDecl = text "declaration" ppr RecFieldAssign = text "assignment" ppr RecFieldMatch = text "pattern match" - ppr RecFieldOcc = text "occurence" + ppr RecFieldOcc = text "occurrence" instance Binary RecFieldContext where put_ bh b = putByte bh (fromIntegral (fromEnum b)) @@ -679,14 +679,14 @@ put_ bh NoScope = putByte bh 0 put_ bh (LocalScope span) = do putByte bh 1 - put_ bh span + put_ bh $ BinSpan span put_ bh ModuleScope = putByte bh 2 get bh = do (t :: Word8) <- get bh case t of 0 -> return NoScope - 1 -> LocalScope <$> get bh + 1 -> LocalScope . unBinSpan <$> get bh 2 -> return ModuleScope _ -> panic "Binary Scope: invalid tag" @@ -732,13 +732,13 @@ put_ bh (UnresolvedScope ns span) = do putByte bh 1 put_ bh ns - put_ bh span + put_ bh (BinSpan <$> span) get bh = do (t :: Word8) <- get bh case t of 0 -> ResolvedScopes <$> get bh - 1 -> UnresolvedScope <$> get bh <*> get bh + 1 -> UnresolvedScope <$> get bh <*> (fmap unBinSpan <$> get bh) _ -> panic "Binary TyVarScope: invalid tag" -- | `Name`'s get converted into `HieName`'s before being written into @.hie@ @@ -751,9 +751,9 @@ deriving (Eq) instance Ord HieName where - compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) `thenCmp` leftmost_smallest c f + compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) S.<> leftmost_smallest c f -- TODO (int-index): Perhaps use RealSrcSpan in HieName? - compare (LocalName a b) (LocalName c d) = compare a c `thenCmp` leftmost_smallest b d + compare (LocalName a b) (LocalName c d) = compare a c S.<> leftmost_smallest b d -- TODO (int-index): Perhaps use RealSrcSpan in HieName? compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b -- Not actually non deterministic as it is a KnownKey @@ -774,7 +774,7 @@ case lookupKnownKeyName u of Just n -> nameOccName n Nothing -> pprPanic "hieNameOcc:unknown known-key unique" - (ppr (unpkUnique u)) + (ppr u) toHieName :: Name -> HieName toHieName name 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 @@ -13,7 +13,6 @@ import GHC.Driver.Ppr import GHC.Data.FastString ( FastString, mkFastString ) import GHC.Iface.Type -import GHC.Core.Multiplicity import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set import GHC.Utils.Outputable hiding ( (<>) ) @@ -22,6 +21,7 @@ import GHC.CoreToIface import GHC.Core.TyCon import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Compare( nonDetCmpType ) import GHC.Core.Type import GHC.Types.Var import GHC.Types.Var.Env @@ -41,6 +41,7 @@ import Data.Traversable ( for ) import Data.Coerce import GHC.Utils.Monad.State.Strict hiding (get) +import GHC.Utils.Panic.Plain( assert ) import Control.Monad.Trans.Reader import qualified Data.Tree as Tree @@ -61,7 +62,7 @@ resolveVisibility :: Type -> [Type] -> [(Bool,Type)] resolveVisibility kind ty_args - = go (mkEmptyTCvSubst in_scope) kind ty_args + = go (mkEmptySubst in_scope) kind ty_args where in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) @@ -70,8 +71,8 @@ | Just ty' <- coreView ty = go env ty' ts go env (ForAllTy (Bndr tv vis) res) (t:ts) - | isVisibleArgFlag vis = (True , t) : ts' - | otherwise = (False, t) : ts' + | isVisibleForAllTyFlag vis = (True , t) : ts' + | otherwise = (False, t) : ts' where ts' = go (extendTvSubst env tv t) res ts @@ -160,8 +161,8 @@ go (HLitTy l) = IfaceLitTy l go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k) in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t - go (HFunTy w a b) = IfaceFunTy VisArg w a b - go (HQualTy pred b) = IfaceFunTy InvisArg many_ty pred b + 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 (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) @@ -240,9 +241,9 @@ ai <- getTypeIndex a bi <- getTypeIndex b wi <- getTypeIndex w - return $ case af of - InvisArg -> case w of Many -> HQualTy ai bi; _ -> error "Unexpected non-unrestricted predicate" - VisArg -> HFunTy wi ai bi + return $ if isInvisibleFunArg af + then assert (isManyTy w) $ HQualTy ai bi + else HFunTy wi ai bi go (LitTy a) = return $ HLitTy $ toIfaceTyLit a go (CastTy t _) = do i <- getTypeIndex t diff --git a/GHC/Iface/Load.hs b/GHC/Iface/Load.hs --- a/GHC/Iface/Load.hs +++ b/GHC/Iface/Load.hs @@ -68,7 +68,6 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Logger -import GHC.Utils.Trace import GHC.Settings.Constants @@ -300,7 +299,7 @@ loadSrcInterface doc mod want_boot maybe_pkg = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg ; case res of - Failed err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) + Failed err -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) Succeeded iface -> return iface } -- | Like 'loadSrcInterface', but returns a 'MaybeErr'. @@ -603,8 +602,11 @@ This is a mess. -Note [HPT space leak] (#15111) -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Home Unit Graph space leak] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Ticket: #15111 + In IfL, we defer some work until it is demanded using forkM, such as building TyThings from IfaceDecls. These thunks are stored in the ExternalPackageState, and they might never be poked. If we're @@ -615,14 +617,15 @@ Therefore, when loading a package interface file , we use a "clean" version of the HscEnv with all the data about the currently loaded program stripped out. Most of the fields can be panics because -we'll never read them, but hsc_HPT needs to be empty because this +we'll never read them, but hsc_HUG needs to be empty because this interface will cause other interfaces to be loaded recursively, and -when looking up those interfaces we use the HPT in loadInterface. +when looking up those interfaces we use the HUG in loadInterface. We know that none of the interfaces below here can refer to -home-package modules however, so it's safe for the HPT to be empty. +home-package modules however, so it's safe for the HUG to be empty. -} -- Note [GHC Heap Invariants] +-- Note [Home Unit Graph space leak] dontLeakTheHUG :: IfL a -> IfL a dontLeakTheHUG thing_inside = do env <- getTopEnv @@ -1081,11 +1084,12 @@ qualifyImportedNames mod _ | mod == mi_module iface = NameUnqual | otherwise = NameNotInScope1 - print_unqual = QueryQualify qualifyImportedNames + name_ppr_ctx = QueryQualify qualifyImportedNames neverQualifyModules neverQualifyPackages + alwaysPrintPromTick logMsg logger MCDump noSrcSpan - $ withPprStyle (mkDumpStyle print_unqual) + $ withPprStyle (mkDumpStyle name_ppr_ctx) $ pprModIface unit_state iface -- | Show a ModIface but don't display details; suitable for ModIfaces stored in @@ -1126,6 +1130,10 @@ , 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 + Nothing -> empty + Just eds -> text "extra decls:" + $$ nest 2 (vcat ([ppr bs | bs <- eds])) , vcat (map ppr (mi_insts iface)) , vcat (map ppr (mi_fam_insts iface)) , vcat (map ppr (mi_rules iface)) diff --git a/GHC/Iface/Make.hs b/GHC/Iface/Make.hs --- a/GHC/Iface/Make.hs +++ b/GHC/Iface/Make.hs @@ -42,13 +42,15 @@ 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.Unify( RoughMatchTc(..) ) +import GHC.Core.RoughMap( RoughMatchTc(..) ) +import GHC.Driver.Config.HsToCore.Usage import GHC.Driver.Env import GHC.Driver.Backend import GHC.Driver.Session @@ -76,15 +78,14 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Misc hiding ( eqListBy ) +import GHC.Utils.Misc import GHC.Utils.Logger -import GHC.Utils.Trace import GHC.Data.FastString import GHC.Data.Maybe import GHC.HsToCore.Docs -import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames ) +import GHC.HsToCore.Usage import GHC.Unit import GHC.Unit.Module.Warnings @@ -110,11 +111,12 @@ -} mkPartialIface :: HscEnv + -> CoreProgram -> ModDetails -> ModSummary -> ModGuts -> PartialModIface -mkPartialIface hsc_env mod_details mod_summary +mkPartialIface hsc_env core_prog mod_details mod_summary ModGuts{ mg_module = this_mod , mg_hsc_src = hsc_src , mg_usages = usages @@ -128,7 +130,7 @@ , mg_trust_pkg = self_trust , mg_docs = docs } - = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust + = mkIface_ hsc_env this_mod core_prog hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust safe_mode usages docs mod_summary mod_details -- | Fully instantiate an interface. Adds fingerprints and potentially code @@ -193,9 +195,10 @@ -> SafeHaskellMode -- The safe haskell mode -> ModDetails -- gotten from mkBootModDetails, probably -> ModSummary + -> Maybe CoreProgram -> TcGblEnv -- Usages, deprecations, etc -> IO ModIface -mkIfaceTc hsc_env safe_mode mod_details mod_summary +mkIfaceTc hsc_env safe_mode mod_details mod_summary mb_program tc_result@TcGblEnv{ tcg_mod = this_mod, tcg_src = hsc_src, tcg_imports = imports, @@ -219,6 +222,10 @@ 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 @@ -226,13 +233,13 @@ -- 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 <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names + usages <- initIfaceLoad hsc_env $ mkUsageInfo uc plugins fc unit_env this_mod (imp_mods imports) used_names dep_files merged needed_links needed_pkgs docs <- extractDocs (ms_hspp_opts mod_summary) tc_result let partial_iface = mkIface_ hsc_env - this_mod hsc_src + 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 @@ -241,7 +248,7 @@ mkFullIface hsc_env partial_iface Nothing Nothing -mkIface_ :: HscEnv -> Module -> HscSource +mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource -> Bool -> Dependencies -> GlobalRdrEnv -> NameEnv FixItem -> Warnings GhcRn -> HpcInfo -> Bool @@ -252,7 +259,7 @@ -> ModDetails -> PartialModIface mkIface_ hsc_env - this_mod hsc_src used_th deps rdr_env fix_env src_warns + 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, @@ -272,6 +279,9 @@ semantic_mod = homeModuleNameInstantiation home_unit (moduleName this_mod) 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 decls = [ tyThingToIfaceDecl show_linear_types entity | entity <- entities, let name = getName entity, @@ -323,6 +333,7 @@ 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, @@ -349,7 +360,7 @@ -- scope available. (#5534) maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv maybeGlobalRdrEnv rdr_env - | backendRetainsAllBindings (backend dflags) = Just rdr_env + | backendWantsGlobalBindings (backend dflags) = Just rdr_env | otherwise = Nothing ifFamInstTcName = ifFamInstFam @@ -522,7 +533,7 @@ , IfaceData { ifName = getName tycon, ifBinders = if_binders, ifResKind = if_res_kind, - ifCType = tyConCType tycon, + ifCType = tyConCType_maybe tycon, ifRoles = tyConRoles tycon, ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), ifCons = ifaceConDecls (algTyConRhs tycon), @@ -540,7 +551,7 @@ ifCType = Nothing, ifRoles = tyConRoles tycon, ifCtxt = [], - ifCons = IfDataTyCon [], + ifCons = IfDataTyCon False [], ifGadtSyntax = False, ifParent = IfNoParent }) where @@ -549,7 +560,7 @@ -- an error. (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) tc_tyvars = binderVars tc_binders - if_binders = toIfaceTyCoVarBinders 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 @@ -574,9 +585,10 @@ axn = coAxiomName ax ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon [ifaceConDecl con] - ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) + 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. @@ -590,7 +602,7 @@ ifConInfix = dataConIsInfix data_con, ifConWrapper = isJust (dataConWrapId_maybe data_con), ifConExTCvs = map toIfaceBndr ex_tvs', - ifConUserTvBinders = map toIfaceForAllBndr user_bndrs', + ifConUserTvBinders = toIfaceForAllBndrs user_bndrs', ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, ifConCtxt = tidyToIfaceContext con_env2 theta, ifConArgTys = @@ -617,18 +629,18 @@ -- A bit grimy, perhaps, but it's simple! (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs - user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs + 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 dcUserTyCoVarBinders invariant + -- 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. - tidyUserTyCoVarBinder :: TidyEnv -> InvisTVBinder -> InvisTVBinder - tidyUserTyCoVarBinder env (Bndr tv vis) = + tidyUserForAllTyBinder :: TidyEnv -> InvisTVBinder -> InvisTVBinder + tidyUserForAllTyBinder env (Bndr tv vis) = Bndr (tidyTyCoVarOcc env tv) vis classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) @@ -636,7 +648,7 @@ = ( env1 , IfaceClass { ifName = getName tycon, ifRoles = tyConRoles (classTyCon clas), - ifBinders = toIfaceTyCoVarBinders tc_binders, + ifBinders = toIfaceForAllBndrs tc_binders, ifBody = body, ifFDs = map toIfaceFD clas_fds }) where @@ -691,7 +703,7 @@ tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis) = case lookupVarEnv subst tv of Just tv' -> (env, Bndr tv' vis) - Nothing -> tidyTyCoVarBinder env tvb + Nothing -> tidyForAllTyBinder env tvb tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) tidyTyConBinders = mapAccumL tidyTyConBinder @@ -729,7 +741,7 @@ nameModule (coAxiomName axiom) is_local name = nameIsLocalOrFrom mod name - lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom) + lhs_names = filterNameSet is_local (orphNamesOfAxiomLHS axiom) orph | is_local fam_decl = NotOrphan (nameOccName fam_decl) diff --git a/GHC/Iface/Recomp.hs b/GHC/Iface/Recomp.hs --- a/GHC/Iface/Recomp.hs +++ b/GHC/Iface/Recomp.hs @@ -19,6 +19,7 @@ where import GHC.Prelude +import GHC.Data.FastString import GHC.Driver.Backend import GHC.Driver.Config.Finder @@ -44,13 +45,12 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Outputable as Outputable -import GHC.Utils.Misc as Utils hiding ( eqListBy ) +import GHC.Utils.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.Utils.Trace import GHC.Types.Annotations import GHC.Types.Name @@ -70,7 +70,7 @@ import GHC.Unit.Module.Deps import Control.Monad -import Data.List (sortBy, sort) +import Data.List (sortBy, sort, sortOn) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Word (Word64) @@ -137,6 +137,10 @@ -- ^ 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 @@ -165,7 +169,7 @@ data RecompReason = UnitDepRemoved UnitId - | ModulePackageChanged String + | ModulePackageChanged FastString | SourceFileChanged | ThisUnitIdChanged | ImpurePlugin @@ -197,7 +201,7 @@ instance Outputable RecompReason where ppr = \case UnitDepRemoved uid -> ppr uid <+> text "removed" - ModulePackageChanged s -> text s <+> text "package changed" + ModulePackageChanged s -> ftext s <+> text "package changed" SourceFileChanged -> text "Source file changed" ThisUnitIdChanged -> text "-this-unit-id changed" ImpurePlugin -> text "Impure plugin forced recompilation" @@ -323,7 +327,7 @@ -- 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 (backendProducesObject $ backend dflags) -> + True | not (backendWritesFiles $ backend dflags) -> return $ OutOfDateItem MustCompile maybe_iface -- Try and read the old interface for the current module @@ -585,7 +589,7 @@ liftIO $ check_mods (sort hs) prev_dep_mods `recompThen` - let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd (ps ++ implicit_deps ++ bkpk_units) + let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd (ps ++ implicit_deps) in check_packages allPkgDeps prev_dep_pkgs where @@ -593,7 +597,7 @@ -> [(t, GenLocated l ModuleName)] -> IfG [Either - CompileReason (Either (UnitId, ModuleName) (String, UnitId))] + CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))] classify_import find_import imports = liftIO $ traverse (\(mb_pkg, L _ mod) -> let reason = ModuleChanged mod @@ -609,9 +613,8 @@ 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))) - bkpk_units = map (("Signature",) . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface))) - implicit_deps = map ("Implicit",) (implicitPackageDeps dflags) + 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 @@ -620,12 +623,12 @@ Just home_unit | homeUnitId home_unit == primUnitId -> Left (primUnitId, mkModuleName "GHC.Prim") - _ -> Right ("GHC.Prim", primUnitId) + _ -> 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 (moduleNameString (moduleName mod), toUnitId $ moduleUnit mod)) + | otherwise = Right (Right (moduleNameFS (moduleName mod), toUnitId $ moduleUnit mod)) classify reason _ = Left (RecompBecause reason) check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired @@ -646,21 +649,21 @@ text " not among previous dependencies" return $ needsRecompileBecause $ ModuleAdded new - check_packages :: [(String, UnitId)] -> [UnitId] -> IO RecompileRequired + 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:news) olds + check_packages ((new_name, new_unit):news) olds | Just (old, olds') <- uncons olds - , snd new == old = check_packages (dropWhile ((== (snd new)) . snd) news) olds' + , new_unit == old = check_packages (dropWhile ((== new_unit) . snd) news) olds' | otherwise = do trace_hi_diffs logger $ - text "imported package " <> quotes (ppr new) <> - text " not among previous dependencies" - return $ needsRecompileBecause $ ModulePackageChanged $ fst new + text "imported package" <+> ftext new_name <+> ppr new_unit <+> + text "not among previous dependencies" + return $ needsRecompileBecause $ ModulePackageChanged new_name needInterface :: Module -> (ModIface -> IO RecompileRequired) @@ -929,7 +932,7 @@ group_fingerprint. Since we included the sequence number in step (1) programs identical up to - transposition of recursive occurrences are distinguisable, avoiding the + transposition of recursive occurrences are distinguishable, avoiding the second issue mentioned above. 3. Produce the final environment by extending hash_env, mapping each @@ -1200,6 +1203,16 @@ 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 @@ -1233,7 +1246,7 @@ iface_hash <- computeFingerprint putNameLiterally (mod_hash, mi_src_hash iface0, - ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache + ann_fn (mkVarOccFS (fsLit "module")), -- See mkIfaceAnnCache mi_usages iface0, sorted_deps, mi_hpc iface0) @@ -1257,7 +1270,7 @@ , mi_fix_fn = fix_fn , mi_hash_fn = lookupOccEnv local_env } - final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts } + final_iface = iface0 { mi_decls = sorted_decls, mi_extra_decls = sorted_extra_decls, mi_final_exts = final_iface_exts } -- return final_iface @@ -1628,7 +1641,7 @@ pair (IfaceAnnotation target value) = (case target of NamedTarget occn -> occn - ModuleTarget _ -> mkVarOcc "module" + ModuleTarget _ -> mkVarOccFS (fsLit "module") , [value]) -- flipping (++), so the first argument is always short env = mkOccEnv_C (flip (++)) (map pair 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 @@ -1,6 +1,6 @@ --- | Computing fingerprints of values serializeable with GHC's \"Binary\" module. +-- | Computing fingerprints of values serializable with GHC's \"Binary\" module. module GHC.Iface.Recomp.Binary ( -- * Computing fingerprints fingerprintBinMem diff --git a/GHC/Iface/Rename.hs b/GHC/Iface/Rename.hs --- a/GHC/Iface/Rename.hs +++ b/GHC/Iface/Rename.hs @@ -1,7 +1,3 @@ - - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | This module implements interface renaming, which is -- used to rewrite interface files on the fly when we -- are doing indefinite typechecking and need instantiations @@ -543,8 +539,8 @@ rnIfaceTyConParent IfNoParent = pure IfNoParent rnIfaceConDecls :: Rename IfaceConDecls -rnIfaceConDecls (IfDataTyCon ds) - = IfDataTyCon <$> mapM rnIfaceConDecl ds +rnIfaceConDecls (IfDataTyCon type_data ds) + = IfDataTyCon type_data <$> mapM rnIfaceConDecl ds rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon @@ -600,12 +596,8 @@ = pure i rnIfaceUnfolding :: Rename IfaceUnfolding -rnIfaceUnfolding (IfCoreUnfold stable cache if_expr) - = IfCoreUnfold stable cache <$> rnIfaceExpr if_expr -rnIfaceUnfolding (IfCompulsory if_expr) - = IfCompulsory <$> rnIfaceExpr if_expr -rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr) - = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr +rnIfaceUnfolding (IfCoreUnfold src cache guide if_expr) + = IfCoreUnfold src cache guide <$> rnIfaceExpr if_expr rnIfaceUnfolding (IfDFunUnfold bs ops) = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops @@ -636,7 +628,7 @@ rnIfaceExpr (IfaceCast expr co) = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit) -rnIfaceExpr (IfaceLitRubbish rep) = IfaceLitRubbish <$> rnIfaceType rep +rnIfaceExpr (IfaceLitRubbish tc rep) = IfaceLitRubbish tc <$> rnIfaceType rep rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr @@ -697,7 +689,7 @@ = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 rnIfaceCo (IfaceInstCo c1 c2) = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 -rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c +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) diff --git a/GHC/Iface/Syntax.hs b/GHC/Iface/Syntax.hs --- a/GHC/Iface/Syntax.hs +++ b/GHC/Iface/Syntax.hs @@ -5,15 +5,16 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveTraversable #-} module GHC.Iface.Syntax ( module GHC.Iface.Type, IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, - IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..), - IfaceBinding(..), IfaceConAlt(..), - IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), + IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..), IfaceBinding, + IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..), + IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), IfaceClassBody(..), @@ -22,7 +23,7 @@ IfaceAxBranch(..), IfaceTyConParent(..), IfaceCompleteMatch(..), - IfaceLFInfo(..), + IfaceLFInfo(..), IfaceTopBndrInfo(..), -- * Binding names IfaceTopBndr, @@ -43,7 +44,8 @@ import GHC.Prelude -import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey ) +import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey, + constraintKindTyConKey ) import GHC.Types.Unique ( hasKey ) import GHC.Iface.Type import GHC.Iface.Recomp.Binary @@ -63,8 +65,8 @@ import GHC.Unit.Module import GHC.Types.SrcLoc import GHC.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) -import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders ) -import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) +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 @@ -78,6 +80,8 @@ import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, seqList, zipWithEqual ) +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + import Control.Monad import System.IO.Unsafe import Control.DeepSeq @@ -115,6 +119,7 @@ --pprTrace "putIfaceTopBndr" (ppr name) $ put_binding_name bh name + data IfaceDecl = IfaceId { ifName :: IfaceTopBndr, ifType :: IfaceType, @@ -232,7 +237,9 @@ data IfaceConDecls = IfAbstractTyCon -- c.f TyCon.AbstractTyCon - | IfDataTyCon [IfaceConDecl] -- Data type decls + | IfDataTyCon !Bool [IfaceConDecl] -- Data type decls + -- The Bool is True for "type data" declarations. + -- see Note [Type data declarations] in GHC.Rename.Module | IfNewTyCon IfaceConDecl -- Newtype decls -- For IfDataTyCon and IfNewTyCon we store: @@ -351,7 +358,6 @@ | HsUnfold Bool -- True <=> isStrongLoopBreaker is true IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs - | HsLevity -- Present <=> never representation-polymorphic | HsLFInfo IfaceLFInfo | HsTagSig TagSig @@ -359,23 +365,17 @@ -- only later attached to the Id. Partial reason: some are orphans. data IfaceUnfolding - = IfCoreUnfold Bool IfUnfoldingCache IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding - -- Possibly could eliminate the Bool here, the information - -- is also in the InlinePragma. - - | IfCompulsory IfaceExpr -- default methods and unsafeCoerce# - -- for more about unsafeCoerce#, see - -- Note [Wiring in unsafeCoerce#] in "GHC.HsToCore" - - | IfInlineRule Arity -- INLINE pragmas - Bool -- OK to inline even if *un*-saturated - Bool -- OK to inline even if context is boring + = IfCoreUnfold UnfoldingSource + IfUnfoldingCache -- See Note [Tying the 'CoreUnfolding' knot] + IfGuidance IfaceExpr - | IfDFunUnfold [IfaceBndr] [IfaceExpr] type IfUnfoldingCache = UnfoldingCache +data IfGuidance + = IfNoGuidance -- Compute it from the IfaceExpr + | IfWhen Arity Bool Bool -- Just like UnfWhen in Core.UnfoldingGuidance -- We only serialise the IdDetails of top-level Ids, and even then -- we only need a very limited selection. Notably, none of the @@ -458,7 +458,7 @@ visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls (IfAbstractTyCon {}) = [] -visibleIfConDecls (IfDataTyCon cs) = cs +visibleIfConDecls (IfDataTyCon _ cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] @@ -467,18 +467,23 @@ -- especially the question of whether there's a wrapper for a datacon -- See Note [Implicit TyThings] in GHC.Driver.Env --- N.B. the set of names returned here *must* match the set of --- TyThings returned by GHC.Driver.Env.implicitTyThings, in the sense that +-- N.B. the set of names returned here *must* match the set of TyThings +-- returned by GHC.Types.TyThing.implicitTyThings, in the sense that -- TyThing.getOccName should define a bijection between the two lists. --- This invariant is used in GHC.IfaceToCore.tc_iface_decl_fingerprint (see note --- [Tricky iface loop]) +-- This invariant is used in GHC.IfaceToCore.tc_iface_decl_fingerprint +-- (see Note [Tricky iface loop] in GHC.Types.TyThing.) -- The order of the list does not matter. ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons }) = case cons of IfAbstractTyCon {} -> [] IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd - IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds + IfDataTyCon type_data cds + | type_data -> + -- Constructors in "type data" declarations have no implicits. + -- see Note [Type data declarations] in GHC.Rename.Module + [occName con_name | IfCon { ifConName = con_name } <- cds] + | otherwise -> concatMap ifaceConDeclImplicitBndrs cds ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass }) = [] @@ -558,11 +563,11 @@ | IfaceApp IfaceExpr IfaceExpr | IfaceCase IfaceExpr IfLclName [IfaceAlt] | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] - | IfaceLet IfaceBinding IfaceExpr + | IfaceLet (IfaceBinding IfaceLetBndr) IfaceExpr | IfaceCast IfaceExpr IfaceCoercion | IfaceLit Literal - | IfaceLitRubbish IfaceType -- See GHC.Types.Literal - -- Note [Rubbish literals] item (6) + | IfaceLitRubbish TypeOrConstraint IfaceType + -- See GHC.Types.Literal Note [Rubbish literals] item (6) | IfaceFCall ForeignCall IfaceType | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E @@ -581,15 +586,24 @@ | IfaceDataAlt IfExtName | IfaceLitAlt Literal -data IfaceBinding - = IfaceNonRec IfaceLetBndr IfaceExpr - | IfaceRec [(IfaceLetBndr, IfaceExpr)] +type IfaceBinding b = IfaceBindingX IfaceExpr b +data IfaceBindingX r b + = IfaceNonRec b r + | IfaceRec [(b, r)] + deriving (Functor, Foldable, Traversable, Ord, Eq) + -- 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 IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDetails + | IfGblTopBndr IfaceTopBndr + +-- See Note [Interface File with Core: Sharing RHSs] +data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr + data IfaceJoinInfo = IfaceNotJoinPoint | IfaceJoinPoint JoinArity @@ -706,8 +720,24 @@ instance Outputable IfaceDecl where ppr = pprIfaceDecl showToIface +instance (Outputable r, Outputable b) => Outputable (IfaceBindingX r b) where + ppr b = case b of + (IfaceNonRec b r) -> ppr_bind (b, r) + (IfaceRec pairs) -> sep [text "rec {", nest 2 (sep (map ppr_bind pairs)),text "}"] + where + ppr_bind (b, r) = ppr b <+> equals <+> ppr r + +instance Outputable IfaceTopBndrInfo where + ppr (IfLclTopBndr lcl_name _ _ _) = ppr lcl_name + ppr (IfGblTopBndr gbl) = ppr gbl + +instance Outputable IfaceMaybeRhs where + ppr IfUseUnfoldingRhs = text "" + ppr (IfRhs ie) = ppr ie + {- -Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Minimal complete definition] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The minimal complete definition should only be included if a complete class definition is shown. Since the minimal complete definition is anonymous we can't reuse the same mechanism that is used for the @@ -767,7 +797,7 @@ ppShowIface _ _ = Outputable.empty -- show if all sub-components or the complete interface is shown -ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition] +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 @@ -841,7 +871,7 @@ 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 isIfaceTauType kind + 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 @@ -890,6 +920,7 @@ pp_nd = case condecls of IfAbstractTyCon{} -> text "data" + IfDataTyCon True _ -> text "type data" IfDataTyCon{} -> text "data" IfNewTyCon{} -> text "newtype" @@ -963,7 +994,8 @@ -- See Note [Printing type abbreviations] in GHC.Iface.Type ppr_tau | tc `hasKey` liftedTypeKindTyConKey || - tc `hasKey` unrestrictedFunTyConKey + tc `hasKey` unrestrictedFunTyConKey || + tc `hasKey` constraintKindTyConKey = updSDocContext (\ctx -> ctx { sdocPrintTypeAbbreviations = False }) $ ppr tau | otherwise = ppr tau @@ -1048,7 +1080,8 @@ , ppWhen insert_empty_ctxt $ parens empty <+> darrow , ex_msg , pprIfaceContextArr prov_ctxt - , pprIfaceType $ foldr (IfaceFunTy VisArg many_ty) pat_ty arg_tys ]) + , pprIfaceType $ foldr (IfaceFunTy visArgTypeLike many_ty) + pat_ty arg_tys ]) pat_body = braces $ sep $ punctuate comma $ map ppr pat_fldlbls univ_msg = pprUserIfaceForAll $ tyVarSpecToBinders univ_bndrs ex_msg = pprUserIfaceForAll $ tyVarSpecToBinders ex_bndrs @@ -1187,16 +1220,18 @@ -- 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) arg_tys ts) + (t:ts) -> fsep (t : zipWithEqual "pprIfaceConDecl" (\(w,_) d -> ppr_arr w <+> d) + arg_tys ts) [] -> panic "pp_con_taus" | otherwise = sep [pp_field_args, arrow <+> pp_gadt_res_ty] -- Constructors are linear by default, but we don't want to show -- linear arrows when -XLinearTypes is disabled - ppr_arr w = sdocOption sdocLinearTypes (\linearTypes -> if linearTypes - then ppr_fun_arrow w - else arrow) + ppr_arr w = sdocOption sdocLinearTypes $ \linearTypes -> + if linearTypes + then pprTypeArrow visArgTypeLike w + else arrow ppr_bang IfNoBang = whenPprDebug $ char '_' ppr_bang IfStrict = char '!' @@ -1264,7 +1299,7 @@ | otherwise = Nothing where sel = flSelector lbl - occ = mkVarOccFS (flLabel lbl) + occ = mkVarOccFS (field_label $ flLabel lbl) mk_user_con_res_ty :: IfaceEqSpec -> SDoc -- See Note [Result type of a data family GADT] @@ -1286,7 +1321,7 @@ -- 3. Pretty-print the data type constructor applied to its arguments. -- This process will omit any invisible arguments, such as coercion -- variables, if necessary. (See Note - -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.) + -- [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.) ppr_tc_app gadt_subst = pprPrefixIfDeclBndr how_much (occName tycon) <+> pprParendIfaceAppArgs @@ -1295,7 +1330,7 @@ mk_tc_app_args :: [IfaceTyConBinder] -> IfaceAppArgs mk_tc_app_args [] = IA_Nil mk_tc_app_args (Bndr bndr vis:tc_bndrs) = - IA_Arg (IfaceTyVar (ifaceBndrName bndr)) (tyConBndrVisArgFlag vis) + IA_Arg (IfaceTyVar (ifaceBndrName bndr)) (tyConBndrVisForAllTyFlag vis) (mk_tc_app_args tc_bndrs) instance Outputable IfaceRule where @@ -1372,16 +1407,20 @@ -- an atomic value (e.g. function args) pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc -pprIfaceExpr _ (IfaceLcl v) = ppr v -pprIfaceExpr _ (IfaceExt v) = ppr v -pprIfaceExpr _ (IfaceLit l) = ppr l -pprIfaceExpr _ (IfaceLitRubbish r) = text "RUBBISH" <> parens (ppr r) -pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) -pprIfaceExpr _ (IfaceType ty) = char '@' <> pprParendIfaceType ty -pprIfaceExpr _ (IfaceCo co) = text "@~" <> pprParendIfaceCoercion co +pprIfaceExpr _ (IfaceLcl v) = ppr v +pprIfaceExpr _ (IfaceExt v) = ppr v +pprIfaceExpr _ (IfaceLit l) = ppr l +pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) +pprIfaceExpr _ (IfaceType ty) = char '@' <> pprParendIfaceType ty +pprIfaceExpr _ (IfaceCo co) = text "@~" <> pprParendIfaceCoercion co +pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as) +pprIfaceExpr _ (IfaceLitRubbish tc r) + = text "RUBBISH" + <> (case tc of { TypeLike -> empty; ConstraintLike -> text "[c]" }) + <> parens (ppr r) + pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) -pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as) pprIfaceExpr add_par i@(IfaceLam _ _) = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow, @@ -1480,7 +1519,6 @@ ppr (HsDmdSig str) = text "Strictness:" <+> ppr str ppr (HsCprSig cpr) = text "CPR:" <+> ppr cpr ppr HsNoCafRefs = text "HasNoCafRefs" - ppr HsLevity = text "Never levity-polymorphic" ppr (HsLFInfo lf_info) = text "LambdaFormInfo:" <+> ppr lf_info ppr (HsTagSig tag_sig) = text "TagSig:" <+> ppr tag_sig @@ -1489,17 +1527,15 @@ ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar) instance Outputable IfaceUnfolding where - ppr (IfCompulsory e) = text "" <+> parens (ppr e) - ppr (IfCoreUnfold s _ e) = (if s - then text "" - else Outputable.empty) - <+> parens (ppr e) - ppr (IfInlineRule a uok bok e) = sep [text "InlineRule" - <+> ppr (a,uok,bok), - pprParendIfaceExpr e] + ppr (IfCoreUnfold src _ guide e) + = sep [ text "Core:" <+> ppr src <+> ppr guide, ppr e ] ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot) 2 (sep (map pprParendIfaceExpr es)) +instance Outputable IfGuidance where + ppr IfNoGuidance = empty + ppr (IfWhen a u b) = angleBrackets (ppr a <> comma <> ppr u <> ppr b) + {- ************************************************************************ * * @@ -1619,8 +1655,8 @@ freeNamesDM _ = emptyNameSet freeNamesIfConDecls :: IfaceConDecls -> NameSet -freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c -freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c +freeNamesIfConDecls (IfDataTyCon _ cs) = fnList freeNamesIfConDecl cs +freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet @@ -1687,7 +1723,7 @@ = freeNamesIfCoercion c freeNamesIfCoercion (IfaceTransCo c1 c2) = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 -freeNamesIfCoercion (IfaceNthCo _ co) +freeNamesIfCoercion (IfaceSelCo _ co) = freeNamesIfCoercion co freeNamesIfCoercion (IfaceLRCo _ co) = freeNamesIfCoercion co @@ -1743,9 +1779,7 @@ freeNamesItem _ = emptyNameSet freeNamesIfUnfold :: IfaceUnfolding -> NameSet -freeNamesIfUnfold (IfCoreUnfold _ _ e) = freeNamesIfExpr e -freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e -freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfCoreUnfold _ _ _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es freeNamesIfExpr :: IfaceExpr -> NameSet @@ -2106,14 +2140,16 @@ instance Binary IfaceConDecls where put_ bh IfAbstractTyCon = putByte bh 0 - put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs - put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c + put_ bh (IfDataTyCon False cs) = putByte bh 1 >> put_ bh cs + put_ bh (IfDataTyCon True cs) = putByte bh 2 >> put_ bh cs + put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c get bh = do h <- getByte bh case h of 0 -> return IfAbstractTyCon - 1 -> liftM IfDataTyCon (get bh) - 2 -> liftM IfNewTyCon (get bh) + 1 -> liftM (IfDataTyCon False) (get bh) + 2 -> liftM (IfDataTyCon True) (get bh) + 3 -> liftM IfNewTyCon (get bh) _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls" instance Binary IfaceConDecl where @@ -2246,7 +2282,6 @@ put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad put_ bh HsNoCafRefs = putByte bh 4 - put_ bh HsLevity = putByte bh 5 put_ bh (HsCprSig cpr) = putByte bh 6 >> put_ bh cpr put_ bh (HsLFInfo lf_info) = putByte bh 7 >> put_ bh lf_info put_ bh (HsTagSig sig) = putByte bh 8 >> put_ bh sig @@ -2261,48 +2296,49 @@ return (HsUnfold lb ad) 3 -> liftM HsInline $ get bh 4 -> return HsNoCafRefs - 5 -> return HsLevity 6 -> HsCprSig <$> get bh 7 -> HsLFInfo <$> get bh _ -> HsTagSig <$> get bh instance Binary IfaceUnfolding where - put_ bh (IfCoreUnfold s c e) = do + put_ bh (IfCoreUnfold s c g e) = do putByte bh 0 put_ bh s putUnfoldingCache bh c + put_ bh g put_ bh e - put_ bh (IfInlineRule a b c d) = do - putByte bh 1 - put_ bh a - put_ bh b - put_ bh c - put_ bh d put_ bh (IfDFunUnfold as bs) = do - putByte bh 2 + putByte bh 1 put_ bh as put_ bh bs - put_ bh (IfCompulsory e) = do - putByte bh 3 - put_ bh e get bh = do h <- getByte bh case h of 0 -> do s <- get bh c <- getUnfoldingCache bh + g <- get bh e <- get bh - return (IfCoreUnfold s c e) - 1 -> do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (IfInlineRule a b c d) - 2 -> do as <- get bh + return (IfCoreUnfold s c g e) + _ -> do as <- get bh bs <- get bh return (IfDFunUnfold as bs) - _ -> do e <- get bh - return (IfCompulsory e) +instance Binary IfGuidance where + put_ bh IfNoGuidance = putByte bh 0 + put_ bh (IfWhen a b c ) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh c + get bh = do + h <- getByte bh + case h of + 0 -> return IfNoGuidance + _ -> do a <- get bh + b <- get bh + c <- get bh + return (IfWhen a b c) + putUnfoldingCache :: BinHandle -> IfUnfoldingCache -> IO () putUnfoldingCache bh (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike , uf_is_work_free = wf, uf_expandable = exp }) = do @@ -2388,9 +2424,12 @@ putByte bh 13 put_ bh a put_ bh b - put_ bh (IfaceLitRubbish r) = do + put_ bh (IfaceLitRubbish TypeLike r) = do putByte bh 14 put_ bh r + put_ bh (IfaceLitRubbish ConstraintLike r) = do + putByte bh 15 + put_ bh r get bh = do h <- getByte bh case h of @@ -2434,7 +2473,9 @@ b <- get bh return (IfaceECase a b) 14 -> do r <- get bh - return (IfaceLitRubbish r) + return (IfaceLitRubbish TypeLike r) + 15 -> do r <- get bh + return (IfaceLitRubbish ConstraintLike r) _ -> panic ("get IfaceExpr " ++ show h) instance Binary IfaceTickish where @@ -2488,7 +2529,7 @@ 1 -> liftM IfaceDataAlt $ get bh _ -> liftM IfaceLitAlt $ get bh -instance Binary IfaceBinding where +instance (Binary r, Binary b) => Binary (IfaceBindingX b r) where put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac get bh = do @@ -2509,6 +2550,38 @@ d <- get bh return (IfLetBndr a b c d) +instance Binary IfaceTopBndrInfo where + put_ bh (IfLclTopBndr lcl ty info dets) = do + putByte bh 0 + put_ bh lcl + put_ bh ty + put_ bh info + put_ bh dets + put_ bh (IfGblTopBndr gbl) = do + putByte bh 1 + put_ bh gbl + get bh = do + tag <- getByte bh + case tag of + 0 -> IfLclTopBndr <$> get bh <*> get bh <*> get bh <*> get bh + 1 -> IfGblTopBndr <$> get bh + _ -> pprPanic "IfaceTopBndrInfo" (intWithCommas tag) + +instance Binary IfaceMaybeRhs where + put_ bh IfUseUnfoldingRhs = putByte bh 0 + put_ bh (IfRhs e) = do + putByte bh 1 + put_ bh e + + get bh = do + b <- getByte bh + case b of + 0 -> return IfUseUnfoldingRhs + 1 -> IfRhs <$> get bh + _ -> pprPanic "IfaceMaybeRhs" (intWithCommas b) + + + instance Binary IfaceJoinInfo where put_ bh IfaceNotJoinPoint = putByte bh 0 put_ bh (IfaceJoinPoint ar) = do @@ -2602,7 +2675,7 @@ instance NFData IfaceConDecls where rnf = \case IfAbstractTyCon -> () - IfDataTyCon f1 -> rnf f1 + IfDataTyCon _ f1 -> rnf f1 IfNewTyCon f1 -> rnf f1 instance NFData IfaceConDecl where @@ -2631,22 +2704,20 @@ HsInline p -> p `seq` () -- TODO: seq further? HsUnfold b unf -> rnf b `seq` rnf unf HsNoCafRefs -> () - HsLevity -> () HsCprSig cpr -> cpr `seq` () HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further? HsTagSig sig -> sig `seq` () +instance NFData IfGuidance where + rnf = \case + IfNoGuidance -> () + IfWhen a b c -> a `seq` b `seq` c `seq` () + instance NFData IfaceUnfolding where rnf = \case - IfCoreUnfold inlinable cache expr -> - rnf inlinable `seq` cache `seq` rnf expr + IfCoreUnfold src cache guidance expr -> src `seq` 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 - IfCompulsory expr -> - rnf expr - IfInlineRule arity b1 b2 e -> - rnf arity `seq` rnf b1 `seq` rnf b2 `seq` rnf e - IfDFunUnfold bndrs exprs -> - rnf bndrs `seq` rnf exprs instance NFData IfaceExpr where rnf = \case @@ -2662,17 +2733,25 @@ IfaceLet bind e -> rnf bind `seq` rnf e IfaceCast e co -> rnf e `seq` rnf co IfaceLit l -> l `seq` () -- FIXME - IfaceLitRubbish r -> rnf r `seq` () + IfaceLitRubbish tc r -> tc `seq` rnf r `seq` () IfaceFCall fc ty -> fc `seq` rnf ty IfaceTick tick e -> rnf tick `seq` rnf e instance NFData IfaceAlt where rnf (IfaceAlt con bndrs rhs) = rnf con `seq` rnf bndrs `seq` rnf rhs -instance NFData IfaceBinding where +instance (NFData b, NFData a) => NFData (IfaceBindingX a b) where rnf = \case IfaceNonRec bndr e -> rnf bndr `seq` rnf e IfaceRec binds -> rnf binds + +instance NFData IfaceTopBndrInfo where + rnf (IfGblTopBndr n) = n `seq` () + rnf (IfLclTopBndr fs ty info dets) = rnf fs `seq` rnf ty `seq` rnf info `seq` rnf dets `seq` () + +instance NFData IfaceMaybeRhs where + rnf IfUseUnfoldingRhs = () + rnf (IfRhs ce) = rnf ce `seq` () instance NFData IfaceLetBndr where rnf (IfLetBndr nm ty id_info join_info) = diff --git a/GHC/Iface/Tidy.hs b/GHC/Iface/Tidy.hs --- a/GHC/Iface/Tidy.hs +++ b/GHC/Iface/Tidy.hs @@ -24,15 +24,17 @@ 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, exprBotStrictness_maybe, typeArity ) +import GHC.Core.Seq ( seqBinds ) +import GHC.Core.Opt.Arity ( exprArity, typeArity, exprBotStrictness_maybe ) import GHC.Core.InstEnv -import GHC.Core.Type ( tidyTopType, Type ) +import GHC.Core.Type ( Type, tidyTopType ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Iface.Tidy.StaticPtrTable import GHC.Iface.Env @@ -40,7 +42,6 @@ import GHC.Utils.Outputable import GHC.Utils.Misc( filterOut ) import GHC.Utils.Panic -import GHC.Utils.Trace import GHC.Utils.Logger as Logger import qualified GHC.Utils.Error as Err @@ -51,8 +52,7 @@ import GHC.Types.Id import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info -import GHC.Types.Demand ( isDeadEndAppSig, isNopSig, isDeadEndSig ) -import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Types.Demand ( isDeadEndAppSig, isNopSig, nopSig, isDeadEndSig ) import GHC.Types.Basic import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set @@ -73,7 +73,6 @@ import Data.List ( sortBy, mapAccumL ) import qualified Data.Set as S import GHC.Types.CostCentre -import GHC.Core.Opt.OccurAnal (occurAnalyseExpr) {- Constructing the TypeEnv, Instances, Rules from which the @@ -380,9 +379,10 @@ }) = do let implicit_binds = concatMap getImplicitBinds tcs + all_binds = implicit_binds ++ binds - (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod binds implicit_binds imp_rules - let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env + (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 (tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds @@ -419,7 +419,7 @@ tidy_rules = tidyRules tidy_env trimmed_rules -- See Note [Injecting implicit bindings] - all_tidy_binds = implicit_binds ++ tidy_binds' + all_tidy_binds = tidy_binds' -- Get the TyCons to generate code for. Careful! We must use -- the untidied TyCons here, because we need @@ -646,12 +646,11 @@ chooseExternalIds :: TidyOpts -> Module -> [CoreBind] - -> [CoreBind] -> [CoreRule] -> IO (UnfoldEnv, TidyOccEnv) -- Step 1 from the notes above -chooseExternalIds opts mod binds implicit_binds imp_id_rules +chooseExternalIds opts mod 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 } @@ -680,10 +679,9 @@ rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules binders = map fst $ flattenBinds binds - implicit_binders = bindersOfBinds implicit_binds binder_set = mkVarSet binders - avoids = [getOccName name | bndr <- binders ++ implicit_binders, + avoids = [getOccName name | bndr <- binders, let name = idName bndr, isExternalName name ] -- In computing our "avoids" list, we must include @@ -875,9 +873,9 @@ dffvLetBndr :: Bool -> Id -> DFFV () -- Gather the free vars of the RULES and unfolding of a binder -- We always get the free vars of a *stable* unfolding, but --- for a *vanilla* one (InlineRhs), the flag controls what happens: +-- for a *vanilla* one (VanillaSrc), the flag controls what happens: -- True <=> get fvs of even a *vanilla* unfolding --- False <=> ignore an InlineRhs +-- False <=> ignore a VanillaSrc -- For nested bindings (call from dffvBind) we always say "False" because -- we are taking the fvs of the RHS anyway -- For top-level bindings (call from addExternal, via bndrFvsInOrder) @@ -889,10 +887,9 @@ idinfo = idInfo id go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) - = case src of - InlineRhs | vanilla_unfold -> dffvExpr rhs - | otherwise -> return () - _ -> dffvExpr rhs + | isStableSource src = dffvExpr rhs + | vanilla_unfold = dffvExpr rhs + | otherwise = return () go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) = extendScopeList bndrs $ mapM_ dffvExpr args @@ -964,6 +961,13 @@ called in the final code), we keep the rule too. 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. -} findExternalRules :: TidyOpts @@ -975,7 +979,8 @@ findExternalRules opts binds imp_id_rules unfold_env = (trimmed_binds, filter keep_rule all_rules) where - imp_rules = filter expose_rule imp_id_rules + 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 @@ -996,16 +1001,14 @@ -- RHS: the auto rules that might mention a binder that has -- been discarded; see Note [Trimming auto-rules] - expose_rule rule - | not (opt_expose_rules opts) = False - | otherwise = all is_external_id (ruleLhsFreeIdsList rule) + expose_rule rule = all is_external_id (ruleLhsFreeIdsList rule) -- Don't expose a rule whose LHS mentions a locally-defined -- Id that is completely internal (i.e. not visible to an -- importing module). NB: ruleLhsFreeIds only returns LocalIds. -- See Note [Which rules to expose] is_external_id id = case lookupVarEnv unfold_env id of - Just (name, _) -> isExternalName name + Just (name, _) -> isExternalName name && not (isImplicitId id) Nothing -> False trim_binds :: [CoreBind] @@ -1020,7 +1023,7 @@ = ([], emptyVarSet, imp_user_rule_fvs, imp_rules) trim_binds (bind:binds) - | any needed bndrs -- Keep binding + | any needed bndrs -- Keep this binding = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules ) | otherwise -- Discard binding altogether = stuff @@ -1041,7 +1044,8 @@ -- In needed_fvs', we don't bother to delete binders from the fv set local_rules = [ rule - | id <- bndrs + | (opt_expose_rules opts) + , id <- bndrs , is_external_id id -- Only collect rules for external Ids , rule <- idCoreRules id , expose_rule rule ] -- and ones that can fire in a client @@ -1093,12 +1097,12 @@ | otherwise = panic "tidyTopName" where - name = idName id + !name = idName id external = isJust maybe_ref global = isExternalName name local = not global internal = not external - loc = nameSrcSpan name + !loc = nameSrcSpan name old_occ = nameOccName name new_occ | Just ref <- maybe_ref @@ -1218,27 +1222,27 @@ -- Indeed, CorePrep must eta expand where necessary to make -- the manifest arity equal to the claimed arity. -- -tidyTopIdInfo :: TidyEnv -> Name -> Type -> CoreExpr -> CoreExpr - -> IdInfo -> Bool -> IdInfo +tidyTopIdInfo :: TidyEnv -> Name -> Type + -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> IdInfo tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough; -- c.f. GHC.Core.Tidy.tidyLetBndr `setArityInfo` arity - `setDmdSigInfo` final_sig - `setCprSigInfo` final_cpr - `setUnfoldingInfo` minimal_unfold_info -- See Note [Preserve evaluatedness] + `setDmdSigInfo` final_sig + `setCprSigInfo` final_cpr + `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness] -- in GHC.Core.Tidy | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo - `setArityInfo` arity - `setDmdSigInfo` final_sig - `setCprSigInfo` final_cpr - `setOccInfo` robust_occ_info - `setInlinePragInfo` (inlinePragInfo idinfo) - `setUnfoldingInfo` unfold_info + `setArityInfo` arity + `setDmdSigInfo` final_sig + `setCprSigInfo` final_cpr + `setOccInfo` robust_occ_info + `setInlinePragInfo` inlinePragInfo idinfo + `setUnfoldingInfo` unfold_info -- NB: we throw away the Rules -- They have already been extracted by findExternalRules where @@ -1253,23 +1257,32 @@ mb_bot_str = exprBotStrictness_maybe orig_rhs sig = dmdSigInfo idinfo - final_sig | not $ isNopSig sig + final_sig | not (isNopSig sig) = warnPprTrace (_bottom_hidden sig) "tidyTopIdInfo" (ppr name) sig - -- try a cheap-and-cheerful bottom analyser - | Just (_, nsig) <- mb_bot_str = nsig - | otherwise = sig + -- No demand signature, so try a + -- cheap-and-cheerful bottom analyser + | Just (_, bot_str_sig, _) <- mb_bot_str + = bot_str_sig + + -- No strictness info + | otherwise = nopSig + cpr = cprSigInfo idinfo - final_cpr | Just _ <- mb_bot_str - = mkCprSig arity botCpr + final_cpr | Just (_, _, bot_cpr_sig) <- mb_bot_str + = bot_cpr_sig | otherwise = cpr - _bottom_hidden id_sig = case mb_bot_str of - Nothing -> False - Just (arity, _) -> not (isDeadEndAppSig id_sig arity) + _bottom_hidden id_sig + = case mb_bot_str of + Nothing -> False + Just (arity, _, _) -> not (isDeadEndAppSig id_sig arity) --------- Unfolding ------------ + -- Force unfold_info (hence bangs), otherwise the old unfolding + -- is retained during code generation. See #22071 + unf_info = realUnfoldingInfo idinfo !minimal_unfold_info = trimUnfolding unf_info @@ -1277,27 +1290,10 @@ = tidyTopUnfolding rhs_tidy_env tidy_rhs unf_info | otherwise = minimal_unfold_info - -- NB: use `orig_rhs` not `tidy_rhs` in this call to mkFinalUnfolding -- else you get a black hole (#22122). Reason: mkFinalUnfolding -- looks at IdInfo, and that is knot-tied in tidyTopBind (the Rec case) - -- NB: do *not* expose the worker if show_unfold is off, - -- because that means this thing is a loop breaker or - -- marked NOINLINE or something like that - -- This is important: if you expose the worker for a loop-breaker - -- then you can make the simplifier go into an infinite loop, because - -- in effect the unfolding is exposed. See #1709 - -- - -- You might think that if show_unfold is False, then the thing should - -- not be w/w'd in the first place. But a legitimate reason is this: - -- the function returns bottom - -- In this case, show_unfold will be false (we don't expose unfoldings - -- for bottoming functions), but we might still have a worker/wrapper - -- split (see Note [Worker/wrapper for bottoming functions] in - -- GHC.Core.Opt.WorkWrap) - - --------- Arity ------------ -- Usually the Id will have an accurate arity on it, because -- the simplifier has just run, but not always. @@ -1305,8 +1301,12 @@ -- did was to let-bind a non-atomic argument and then float -- it to the top level. So it seems more robust just to -- fix it here. - arity = exprArity orig_rhs `min` (length $ typeArity rhs_ty) - + arity = exprArity orig_rhs `min` typeArity rhs_ty + -- orig_rhs: using tidy_rhs would make a black hole, since + -- exprArity uses the arities of Ids inside the rhs + -- + -- typeArity: see Note [Arity invariants for bindings] + -- in GHC.Core.Opt.Arity ------------ Unfolding -------------- tidyTopUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding @@ -1355,4 +1355,107 @@ And (unlike tidyNestedUnfolding) don't deep-seq the new unfolding, because that'll cause a black hole (I /think/ because occurAnalyseExpr looks in IdInfo). + + +************************************************************************ +* * + Old, dead, type-trimming code +* * +************************************************************************ + +We used to try to "trim off" the constructors of data types that are +not exported, to reduce the size of interface files, at least without +-O. But that is not always possible: see the old Note [When we can't +trim types] below for exceptions. + +Then (#7445) I realised that the TH problem arises for any data type +that we have deriving( Data ), because we can invoke + Language.Haskell.TH.Quote.dataToExpQ +to get a TH Exp representation of a value built from that data type. +You don't even need {-# LANGUAGE TemplateHaskell #-}. + +At this point I give up. The pain of trimming constructors just +doesn't seem worth the gain. So I've dumped all the code, and am just +leaving it here at the end of the module in case something like this +is ever resurrected. + + +Note [When we can't trim types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of type trimming is to export algebraic data types +abstractly (without their data constructors) when compiling without +-O, unless of course they are explicitly exported by the user. + +We always export synonyms, because they can be mentioned in the type +of an exported Id. We could do a full dependency analysis starting +from the explicit exports, but that's quite painful, and not done for +now. + +But there are some times we can't do that, indicated by the 'no_trim_types' flag. + +First, Template Haskell. Consider (#2386) this + module M(T, makeOne) where + data T = Yay String + makeOne = [| Yay "Yep" |] +Notice that T is exported abstractly, but makeOne effectively exports it too! +A module that splices in $(makeOne) will then look for a declaration of Yay, +so it'd better be there. Hence, brutally but simply, we switch off type +constructor trimming if TH is enabled in this module. + +Second, data kinds. Consider (#5912) + {-# LANGUAGE DataKinds #-} + module M() where + data UnaryTypeC a = UnaryDataC a + type Bug = 'UnaryDataC +We always export synonyms, so Bug is exposed, and that means that +UnaryTypeC must be too, even though it's not explicitly exported. In +effect, DataKinds means that we'd need to do a full dependency analysis +to see what data constructors are mentioned. But we don't do that yet. + +In these two cases we just switch off type trimming altogether. + +mustExposeTyCon :: Bool -- Type-trimming flag + -> NameSet -- Exports + -> TyCon -- The tycon + -> Bool -- Can its rep be hidden? +-- We are compiling without -O, and thus trying to write as little as +-- possible into the interface file. But we must expose the details of +-- any data types whose constructors or fields are exported +mustExposeTyCon no_trim_types exports tc + | no_trim_types -- See Note [When we can't trim types] + = True + + | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to + -- figure out whether it was mentioned in the type + -- of any other exported thing) + = True + + | isEnumerationTyCon tc -- For an enumeration, exposing the constructors + = True -- won't lead to the need for further exposure + + | isFamilyTyCon tc -- Open type family + = True + + -- Below here we just have data/newtype decls or family instances + + | null data_cons -- Ditto if there are no data constructors + = True -- (NB: empty data types do not count as enumerations + -- see Note [Enumeration types] in GHC.Core.TyCon + + | any exported_con data_cons -- Expose rep if any datacon or field is exported + = True + + | isNewTyCon tc && isFFITy (snd (newTyConRhs tc)) + = True -- Expose the rep for newtypes if the rep is an FFI type. + -- For a very annoying reason. 'Foreign import' is meant to + -- be able to look through newtypes transparently, but it + -- can only do that if it can "see" the newtype representation + + | otherwise + = False + where + data_cons = tyConDataCons tc + 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 @@ -144,6 +144,7 @@ import GHC.Types.Id import GHC.Types.ForeignStubs import GHC.Data.Maybe +import GHC.Data.FastString import Control.Monad.Trans.State.Strict import Data.List (intercalate) @@ -239,28 +240,33 @@ -- @fps@ is a list associating each binding corresponding to a static entry with -- its fingerprint. sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub -sptModuleInitCode _ _ [] = mempty -sptModuleInitCode platform this_mod entries = +sptModuleInitCode platform this_mod entries + -- no CStub if there is no entry + | [] <- entries = mempty + -- no CStub for the JS backend: it deals with it directly during JS code + -- generation + | ArchJavaScript <- platformArch platform = mempty + | otherwise = initializerCStub platform init_fn_nm empty init_fn_body `mappend` finalizerCStub platform fini_fn_nm empty fini_fn_body where - init_fn_nm = mkInitializerStubLabel this_mod "spt" + init_fn_nm = mkInitializerStubLabel this_mod (fsLit "spt") init_fn_body = vcat [ text "static StgWord64 k" <> int i <> text "[2] = " <> pprFingerprint fp <> semi $$ text "extern StgPtr " - <> (pdoc platform $ mkClosureLabel (idName n) (idCafInfo n)) <> semi + <> (pprCLabel platform $ mkClosureLabel (idName n) (idCafInfo n)) <> semi $$ text "hs_spt_insert" <> parens (hcat $ punctuate comma [ char 'k' <> int i - , char '&' <> pdoc platform (mkClosureLabel (idName n) (idCafInfo n)) + , char '&' <> pprCLabel platform (mkClosureLabel (idName n) (idCafInfo n)) ] ) <> semi | (i, SptEntry n fp) <- zip [0..] entries ] - fini_fn_nm = mkFinalizerStubLabel this_mod "spt" + fini_fn_nm = mkFinalizerStubLabel this_mod (fsLit "spt") fini_fn_body = vcat [ text "StgWord64 k" <> int i <> text "[2] = " <> pprFingerprint fp <> semi diff --git a/GHC/Iface/Type.hs b/GHC/Iface/Type.hs --- a/GHC/Iface/Type.hs +++ b/GHC/Iface/Type.hs @@ -28,7 +28,7 @@ IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, IfaceForAllSpecBndr, - IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..), ShowForAllFlag(..), + IfaceForAllBndr, ForAllTyFlag(..), FunTyFlag(..), ShowForAllFlag(..), mkIfaceForAllTvBndr, mkIfaceTyConKind, ifaceForAllSpecToBndrs, ifaceForAllSpecToBndr, @@ -39,8 +39,8 @@ -- Equality testing isIfaceLiftedTypeKind, - -- Conversion from IfaceAppArgs to IfaceTypes/ArgFlags - appArgsIfaceTypes, appArgsIfaceTypesArgFlags, + -- Conversion from IfaceAppArgs to IfaceTypes/ForAllTyFlags + appArgsIfaceTypes, appArgsIfaceTypesForAllTyFlags, -- Printing SuppressBndrSig(..), @@ -55,8 +55,7 @@ pprIfaceCoercion, pprParendIfaceCoercion, splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, - ppr_fun_arrow, - isIfaceTauType, + isIfaceRhoType, suppressIfaceInvisibles, stripIfaceInvisVars, @@ -64,18 +63,21 @@ mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst, - many_ty + many_ty, pprTypeArrow ) where import GHC.Prelude import {-# SOURCE #-} GHC.Builtin.Types ( coercibleTyCon, heqTyCon + , constraintKindTyConName , tupleTyConName - , manyDataConTyCon, oneDataConTyCon + , tupleDataConName + , manyDataConTyCon , liftedRepTyCon, liftedDataConTyCon ) -import GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy, isLevityTy ) - +import GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy, isLevityTy, funTyFlagTyCon ) +import GHC.Core.TyCo.Rep( CoSel ) +import GHC.Core.TyCo.Compare( eqForAllVis ) import GHC.Core.TyCon hiding ( pprPromotionQuote ) import GHC.Core.Coercion.Axiom import GHC.Types.Var @@ -161,7 +163,7 @@ -- See Note [Suppressing invisible arguments] for -- an explanation of why the second field isn't -- IfaceType, analogous to AppTy. - | IfaceFunTy AnonArgFlag IfaceMult IfaceType IfaceType + | IfaceFunTy FunTyFlag IfaceMult IfaceType IfaceType | IfaceForAllTy IfaceForAllBndr IfaceType | IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated -- Includes newtypes, synonyms, tuples @@ -191,11 +193,11 @@ deriving (Eq) type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis -type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag +type IfaceForAllBndr = VarBndr IfaceBndr ForAllTyFlag type IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity -- | Make an 'IfaceForAllBndr' from an 'IfaceTvBndr'. -mkIfaceForAllTvBndr :: ArgFlag -> IfaceTvBndr -> IfaceForAllBndr +mkIfaceForAllTvBndr :: ForAllTyFlag -> IfaceTvBndr -> IfaceForAllBndr mkIfaceForAllTvBndr vis var = Bndr (IfaceTvBndr var) vis -- | Build the 'tyConKind' from the binders and the result kind. @@ -219,7 +221,7 @@ = IA_Nil | IA_Arg IfaceType -- The type argument - ArgFlag -- The argument's visibility. We store this here so + ForAllTyFlag -- The argument's visibility. We store this here so -- that we can: -- -- 1. Avoid pretty-printing invisible (i.e., specified @@ -351,9 +353,13 @@ See Note [The equality types story] in GHC.Builtin.Types.Prim. -} -data IfaceTyConInfo -- Used to guide pretty-printing - -- and to disambiguate D from 'D (they share a name) +data IfaceTyConInfo -- Used only to guide pretty-printing = IfaceTyConInfo { ifaceTyConIsPromoted :: PromotionFlag + -- A PromotionFlag value of IsPromoted indicates + -- that the type constructor came from a data + -- constructor promoted by -XDataKinds, and thus + -- should be printed as 'D to distinguish it from + -- an existing type constructor D. , ifaceTyConSort :: IfaceTyConSort } deriving (Eq) @@ -384,7 +390,7 @@ | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType | IfaceSymCo IfaceCoercion | IfaceTransCo IfaceCoercion IfaceCoercion - | IfaceNthCo Int IfaceCoercion + | IfaceSelCo CoSel IfaceCoercion | IfaceLRCo LeftOrRight IfaceCoercion | IfaceInstCo IfaceCoercion IfaceCoercion | IfaceKindCo IfaceCoercion @@ -411,7 +417,7 @@ %************************************************************************ %* * - Functions over IFaceTypes + Functions over IfaceTypes * * ************************************************************************ -} @@ -419,36 +425,56 @@ ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key --- | Given a kind K, is K of the form (TYPE ('BoxedRep 'LiftedRep))? +-- | Returns true for Type or (TYPE LiftedRep) isIfaceLiftedTypeKind :: IfaceKind -> Bool -isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil) - = isLiftedTypeKindTyConName (ifaceTyConName tc) -isIfaceLiftedTypeKind (IfaceTyConApp tc1 args1) - = isIfaceTyConAppLiftedTypeKind tc1 args1 +isIfaceLiftedTypeKind (IfaceTyConApp tc args) + | tc `ifaceTyConHasKey` liftedTypeKindTyConKey + , IA_Nil <- args + = True -- Type + + | tc `ifaceTyConHasKey` tYPETyConKey + , IA_Arg arg1 Required IA_Nil <- args + , isIfaceLiftedRep arg1 + = True -- TYPE Lifted + isIfaceLiftedTypeKind _ = False --- | Given a kind constructor K and arguments A, returns true if --- both of the following statements are true: --- --- * K is TYPE --- * A is a singleton IfaceAppArgs of the form ('BoxedRep 'Lifted) --- --- For the second condition, we must also check for the type --- synonym LiftedRep. -isIfaceTyConAppLiftedTypeKind :: IfaceTyCon -> IfaceAppArgs -> Bool -isIfaceTyConAppLiftedTypeKind tc1 args1 - | tc1 `ifaceTyConHasKey` tYPETyConKey - , IA_Arg soleArg1 Required IA_Nil <- args1 - , IfaceTyConApp rep args2 <- soleArg1 = - if | rep `ifaceTyConHasKey` boxedRepDataConKey - , IA_Arg soleArg2 Required IA_Nil <- args2 - , IfaceTyConApp lev IA_Nil <- soleArg2 - , lev `ifaceTyConHasKey` liftedDataConKey -> True - | rep `ifaceTyConHasKey` liftedRepTyConKey - , IA_Nil <- args2 -> True - | otherwise -> False - | otherwise = False +-- | Returns true for Constraint or (CONSTRAINT LiftedRep) +isIfaceConstraintKind :: IfaceKind -> Bool +isIfaceConstraintKind (IfaceTyConApp tc args) + | tc `ifaceTyConHasKey` constraintKindTyConKey + , IA_Nil <- args + = True -- Type + | tc `ifaceTyConHasKey` cONSTRAINTTyConKey + , IA_Arg arg1 Required IA_Nil <- args + , isIfaceLiftedRep arg1 + = True -- TYPE Lifted + +isIfaceConstraintKind _ = False + +isIfaceLiftedRep :: IfaceKind -> Bool +-- Returns true for LiftedRep, or BoxedRep Lifted +isIfaceLiftedRep (IfaceTyConApp tc args) + | tc `ifaceTyConHasKey` liftedRepTyConKey + , IA_Nil <- args + = True -- LiftedRep + + | tc `ifaceTyConHasKey` boxedRepDataConKey + , IA_Arg arg1 Required IA_Nil <- args + , isIfaceLifted arg1 + = True -- TYPE Lifted + +isIfaceLiftedRep _ = False + +isIfaceLifted :: IfaceKind -> Bool +-- Returns true for Lifted +isIfaceLifted (IfaceTyConApp tc args) + | tc `ifaceTyConHasKey` liftedDataConKey + , IA_Nil <- args + = True +isIfaceLifted _ = False + splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) -- Mainly for printing purposes -- @@ -473,17 +499,18 @@ (theta, tau) = split_rho rho split_foralls (IfaceForAllTy bndr ty) - | isInvisibleArgFlag (binderArgFlag bndr) + | isInvisibleForAllTyFlag (binderFlag bndr) = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) } split_foralls rho = ([], rho) - split_rho (IfaceFunTy InvisArg _ ty1 ty2) + split_rho (IfaceFunTy af _ ty1 ty2) + | isInvisibleFunArg af = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } split_rho tau = ([], tau) splitIfaceReqForallTy :: IfaceType -> ([IfaceForAllBndr], IfaceType) splitIfaceReqForallTy (IfaceForAllTy bndr ty) - | isVisibleArgFlag (binderArgFlag bndr) + | isVisibleForAllTyFlag (binderFlag bndr) = case splitIfaceReqForallTy ty of { (bndrs, rho) -> (bndr:bndrs, rho) } splitIfaceReqForallTy rho = ([], rho) @@ -585,7 +612,7 @@ go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2) go_co (IfaceSymCo co) = IfaceSymCo (go_co co) go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) - go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co) + go_co (IfaceSelCo n co) = IfaceSelCo n (go_co co) go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co) go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2) go_co (IfaceKindCo co) = IfaceKindCo (go_co co) @@ -628,12 +655,12 @@ = case c of IA_Nil -> IA_Nil IA_Arg t argf ts - | isVisibleArgFlag argf + | isVisibleForAllTyFlag argf -> IA_Arg t argf $ suppress_invis ts -- Keep recursing through the remainder of the arguments, as it's -- possible that there are remaining invisible ones. -- See the "In type declarations" section of Note [VarBndrs, - -- TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. + -- ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. | otherwise -> suppress_invis ts @@ -641,17 +668,17 @@ appArgsIfaceTypes IA_Nil = [] appArgsIfaceTypes (IA_Arg t _ ts) = t : appArgsIfaceTypes ts -appArgsIfaceTypesArgFlags :: IfaceAppArgs -> [(IfaceType, ArgFlag)] -appArgsIfaceTypesArgFlags IA_Nil = [] -appArgsIfaceTypesArgFlags (IA_Arg t a ts) - = (t, a) : appArgsIfaceTypesArgFlags ts +appArgsIfaceTypesForAllTyFlags :: IfaceAppArgs -> [(IfaceType, ForAllTyFlag)] +appArgsIfaceTypesForAllTyFlags IA_Nil = [] +appArgsIfaceTypesForAllTyFlags (IA_Arg t a ts) + = (t, a) : appArgsIfaceTypesForAllTyFlags ts ifaceVisAppArgsLength :: IfaceAppArgs -> Int ifaceVisAppArgsLength = go 0 where go !n IA_Nil = n go n (IA_Arg _ argf rest) - | isVisibleArgFlag argf = go (n+1) rest + | isVisibleForAllTyFlag argf = go (n+1) rest | otherwise = go n rest {- @@ -741,7 +768,7 @@ Here, @{k} indicates that `k` is an inferred argument, and @k indicates that `k` is a specified argument. (See -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for +Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep for a lengthier explanation on what "inferred" and "specified" mean.) ************************************************************************ @@ -773,10 +800,10 @@ | otherwise = maybeParen ctxt_prec appPrec $ hang pp_fun 2 (sep pp_tys) -isIfaceTauType :: IfaceType -> Bool -isIfaceTauType (IfaceForAllTy _ _) = False -isIfaceTauType (IfaceFunTy InvisArg _ _ _) = False -isIfaceTauType _ = True +isIfaceRhoType :: IfaceType -> Bool +isIfaceRhoType (IfaceForAllTy _ _) = False +isIfaceRhoType (IfaceFunTy af _ _ _) = isVisibleFunArg af +isIfaceRhoType _ = True -- ----------------------------- Printing binders ------------------------------------ @@ -818,19 +845,28 @@ Note [Printing type abbreviations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Normally, we pretty-print `TYPE 'LiftedRep` as `Type` (or `*`) and -`FUN 'Many` as `(->)`. +Normally, we pretty-print + `TYPE 'LiftedRep` as `Type` (or `*`) + `CONSTRAINT 'LiftedRep` as `Constraint` + `FUN 'Many` as `(->)`. This way, error messages don't refer to representation polymorphism -or linearity if it is not necessary. +or linearity if it is not necessary. Normally we'd would represent +these types using their synonyms (see GHC.Core.Type +Note [Using synonyms to compress types]), but in the :kind! GHCi +command we specifically expand synonyms (see GHC.Tc.Module.tcRnExpr). +So here in the pretty-printing we effectively collapse back Type +and Constraint to their synonym forms. A bit confusing! -However, when printing the definition of Type or (->) with :info, +However, when printing the definition of Type, Constraint or (->) with :info, this would give confusing output: `type (->) = (->)` (#18594). Solution: detect when we are in :info and disable displaying the synonym with the SDoc option sdocPrintTypeAbbreviations. +If you are creating a similar synonym, make sure it is listed in pprIfaceDecl, +see reference to this Note. If there will be a need, in the future we could expose it as a flag --fprint-type-abbreviations or even two separate flags controlling -TYPE 'LiftedRep and FUN 'Many. +-fprint-type-abbreviations or even three separate flags controlling +TYPE 'LiftedRep, CONSTRAINT 'LiftedRep and FUN 'Many. -} -- | Do we want to suppress kind annotations on binders? @@ -857,9 +893,11 @@ go (Bndr (IfaceTvBndr bndr) vis) = -- See Note [Pretty-printing invisible arguments] case vis of - AnonTCB VisArg -> ppr_bndr (UseBndrParens True) - AnonTCB InvisArg -> char '@' <> braces (ppr_bndr (UseBndrParens False)) - -- The above case is rare. (See Note [AnonTCB InvisArg] in GHC.Core.TyCon.) + 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? NamedTCB Required -> ppr_bndr (UseBndrParens True) NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True) @@ -909,37 +947,51 @@ pprPrecIfaceType prec ty = hideNonStandardTypes (ppr_ty prec) ty -ppr_fun_arrow :: IfaceMult -> SDoc -ppr_fun_arrow w - | (IfaceTyConApp tc _) <- w - , tc `ifaceTyConHasKey` (getUnique manyDataConTyCon) = arrow - | (IfaceTyConApp tc _) <- w - , tc `ifaceTyConHasKey` (getUnique oneDataConTyCon) = lollipop - | otherwise = mulArrow (pprIfaceType w) +pprTypeArrow :: FunTyFlag -> IfaceMult -> SDoc +pprTypeArrow af mult + = pprArrow (mb_conc, pprPrecIfaceType) af mult + where + mb_conc (IfaceTyConApp tc _) = Just tc + mb_conc _ = Nothing -ppr_sigma :: PprPrec -> IfaceType -> SDoc -ppr_sigma ctxt_prec ty - = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty) +pprArrow :: (a -> Maybe IfaceTyCon, PprPrec -> a -> SDoc) + -> FunTyFlag -> a -> SDoc +-- Prints a thin arrow (->) with its multiplicity +-- Used for both FunTy and FunCo, hence higher order arguments +pprArrow (mb_conc, ppr_mult) af mult + | isFUNArg af + = case mb_conc mult of + Just tc | tc `ifaceTyConHasKey` manyDataConKey -> arrow + | tc `ifaceTyConHasKey` oneDataConKey -> lollipop + _ -> text "%" <> ppr_mult appPrec mult <+> arrow + | otherwise + = ppr (funTyFlagTyCon af) ppr_ty :: PprPrec -> IfaceType -> SDoc -ppr_ty ctxt_prec ty@(IfaceForAllTy {}) = ppr_sigma ctxt_prec ty -ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _ _) = ppr_sigma ctxt_prec ty - +ppr_ty ctxt_prec ty + | 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 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 _ (IfaceLitTy n) = pprIfaceTyLit n + -- Function types -ppr_ty ctxt_prec (IfaceFunTy _ w ty1 ty2) -- Should be VisArg - = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. +ppr_ty ctxt_prec ty@(IfaceFunTy af w ty1 ty2) -- Should be a visible argument + = assertPpr (isVisibleFunArg af) (ppr ty) $ -- Ensured by isIfaceRhoType above + -- We want to print a chain of arrows in a column + -- type1 + -- -> type2 + -- -> type3 maybeParen ctxt_prec funPrec $ sep [ppr_ty funPrec ty1, sep (ppr_fun_tail w ty2)] where - ppr_fun_tail wthis (IfaceFunTy VisArg wnext ty1 ty2) - = (ppr_fun_arrow wthis <+> ppr_ty funPrec ty1) : ppr_fun_tail wnext ty2 + ppr_fun_tail wthis (IfaceFunTy af wnext ty1 ty2) + | isVisibleFunArg af + = (pprTypeArrow af wthis <+> ppr_ty funPrec ty1) : ppr_fun_tail wnext ty2 ppr_fun_tail wthis other_ty - = [ppr_fun_arrow wthis <+> pprIfaceType other_ty] + = [pprTypeArrow af wthis <+> pprIfaceType other_ty] ppr_ty ctxt_prec (IfaceAppTy t ts) = if_print_coercions @@ -948,7 +1000,7 @@ where ppr_app_ty = sdocOption sdocPrintExplicitKinds $ \print_kinds -> - let tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs + let tys_wo_kinds = appArgsIfaceTypesForAllTyFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) ts in pprIfacePrefixApp ctxt_prec (ppr_ty funPrec t) @@ -1055,7 +1107,7 @@ -> IfaceType -> IfaceType go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) - | isInvisibleArgFlag argf -- Don't default *visible* quantification + | isInvisibleForAllTyFlag argf -- Don't default *visible* quantification -- or we get the mess in #13963 , Just substituted_ty <- check_substitution var_kind = let subs' = extendFsEnv subs var substituted_ty @@ -1150,9 +1202,8 @@ -- | The type 'Many :: Multiplicity'. many_ty :: IfaceType -many_ty = - IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon)) - IA_Nil +many_ty = IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon)) + IA_Nil where dc_name = getName manyDataConTyCon hideNonStandardTypes :: (IfaceType -> SDoc) -> IfaceType -> SDoc @@ -1181,7 +1232,7 @@ go (IA_Arg t argf ts) = ppr_app_arg ctx_prec (t, argf) <+> go ts -- See Note [Pretty-printing invisible arguments] -ppr_app_arg :: PprPrec -> (IfaceType, ArgFlag) -> SDoc +ppr_app_arg :: PprPrec -> (IfaceType, ForAllTyFlag) -> SDoc ppr_app_arg ctx_prec (t, argf) = sdocOption sdocPrintExplicitKinds $ \print_kinds -> case argf of @@ -1233,12 +1284,12 @@ -- Returns both the list of not-yet-rendered binders and the doc. -- No anonymous binders here! ppr_itv_bndrs :: [IfaceForAllBndr] - -> ArgFlag -- ^ visibility of the first binder in the list + -> ForAllTyFlag -- ^ visibility of the first binder in the list -> ([IfaceForAllBndr], [SDoc]) ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1 - | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in - (bndrs', pprIfaceForAllBndr bndr : doc) - | otherwise = (all_bndrs, []) + | vis `eqForAllVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in + (bndrs', pprIfaceForAllBndr bndr : doc) + | otherwise = (all_bndrs, []) ppr_itv_bndrs [] _ = ([], []) pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc @@ -1273,11 +1324,13 @@ pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc pprIfaceSigmaType show_forall ty - = hideNonStandardTypes ppr_fn ty - where - ppr_fn iface_ty = - let (invis_tvs, theta, tau) = splitIfaceSigmaTy iface_ty - (req_tvs, tau') = splitIfaceReqForallTy tau + = hideNonStandardTypes (ppr_sigma show_forall topPrec) ty + +ppr_sigma :: ShowForAllFlag -> PprPrec -> IfaceType -> SDoc +ppr_sigma show_forall ctxt_prec iface_ty + = maybeParen ctxt_prec funPrec $ + let (invis_tvs, theta, tau) = splitIfaceSigmaTy iface_ty + (req_tvs, tau') = splitIfaceReqForallTy tau -- splitIfaceSigmaTy is recursive, so it will gather the binders after -- the theta, i.e. forall a. theta => forall b. tau -- will give you ([a,b], theta, tau). @@ -1291,8 +1344,8 @@ -- non-recursive (see #18458). -- 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'] + in ppr_iface_forall_part show_forall invis_tvs theta $ + sep [pprIfaceForAll req_tvs, ppr tau'] pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc pprUserIfaceForAll tvs @@ -1307,7 +1360,7 @@ = not (ifTypeIsVarFree kind) tv_has_kind_var _ = False - tv_is_required = isVisibleArgFlag . binderArgFlag + tv_is_required = isVisibleForAllTyFlag . binderFlag {- Note [When to print foralls] @@ -1337,7 +1390,7 @@ because omitting it and printing "T :: k -> Type" would be utterly misleading. - See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] + See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. N.B. Until now (Aug 2018) we didn't check anything for coercion variables. @@ -1398,23 +1451,20 @@ Found hole: _ :: Proxy '['True] This would be bad, because the '[' looks like a character literal. + +A similar issue arises if the element is a character literal (#22488) + ghci> type T = '[ 'x' ] + ghci> :kind! T + T :: [Char] + = '['x'] + Solution: in type-level lists and tuples, add a leading space -if the first type is itself promoted. See pprSpaceIfPromotedTyCon. +if the first element is printed with a single quote. -} ------------------- --- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'. --- See Note [Printing promoted type constructors] -pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc -pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _) - = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of - IsPromoted -> (space <>) - _ -> id -pprSpaceIfPromotedTyCon _ - = id - -- See equivalent function in "GHC.Core.TyCo.Rep" pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc -- Given a type-level list (t1 ': t2), see if we can print @@ -1423,8 +1473,19 @@ pprIfaceTyList ctxt_prec ty1 ty2 = case gather ty2 of (arg_tys, Nothing) - -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep - (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys))))) + -> + sdocWithContext $ \ctx -> + let + items = ty1:arg_tys + eos = isListEmptyOrSingleton items + ticked = promTick (sdocStyle ctx) (PromotedItemListSyntax eos) + (preBracket, postBracket) = + if ticked + then (char '\'', spaceIfSingleQuote) + else (empty, id) + in + preBracket <> brackets (postBracket (fsep + (punctuate comma (map (ppr_ty topPrec) items)))) (arg_tys, Just tl) -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1) 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]]) @@ -1435,7 +1496,7 @@ gather (IfaceTyConApp tc tys) | tc `ifaceTyConHasKey` consDataConKey , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys - , isInvisibleArgFlag argf + , isInvisibleForAllTyFlag argf , (args, tl) <- gather ty2 = (ty1:args, tl) | tc `ifaceTyConHasKey` nilDataConKey @@ -1472,20 +1533,25 @@ | tc `ifaceTyConHasKey` consDataConKey , False <- print_kinds , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys - , isInvisibleArgFlag argf + , isInvisibleForAllTyFlag argf -> pprIfaceTyList ctxt_prec ty1 ty2 - | isIfaceTyConAppLiftedTypeKind tc tys + | isIfaceLiftedTypeKind (IfaceTyConApp tc tys) , print_type_abbreviations -- See Note [Printing type abbreviations] -> ppr_kind_type ctxt_prec - | tc `ifaceTyConHasKey` funTyConKey + | isIfaceConstraintKind (IfaceTyConApp tc tys) + , print_type_abbreviations -- See Note [Printing type abbreviations] + -> pprPrefixOcc constraintKindTyConName + + | tc `ifaceTyConHasKey` fUNTyConKey , IA_Arg (IfaceTyConApp rep IA_Nil) Required args <- tys , rep `ifaceTyConHasKey` manyDataConKey , print_type_abbreviations -- See Note [Printing type abbreviations] -> pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_app_arg appPrec) $ - appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) args) - -- Use appArgsIfaceTypesArgFlags to print invisible arguments + appArgsIfaceTypesForAllTyFlags $ + stripInvisArgs (PrintExplicitKinds print_kinds) args) + -- Use appArgsIfaceTypesForAllTyFlags to print invisible arguments -- correctly (#19310) | tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey @@ -1498,7 +1564,7 @@ | otherwise -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc $ - appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) tys + appArgsIfaceTypesForAllTyFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) tys where info = ifaceTyConInfo tc @@ -1608,29 +1674,29 @@ -- 1. Types (from `pprTyTcApp'`) -- -- 2. Coercions (from 'pprIfaceCoTcApp') -ppr_iface_tc_app :: (PprPrec -> (a, ArgFlag) -> SDoc) - -> PprPrec -> IfaceTyCon -> [(a, ArgFlag)] -> SDoc -ppr_iface_tc_app pp _ tc [ty] - | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty) +ppr_iface_tc_app :: (PprPrec -> (a, ForAllTyFlag) -> SDoc) + -> PprPrec -> IfaceTyCon -> [(a, ForAllTyFlag)] -> SDoc -ppr_iface_tc_app pp ctxt_prec tc tys - | tc `ifaceTyConHasKey` liftedTypeKindTyConKey - = ppr_kind_type ctxt_prec +ppr_iface_tc_app pp ctxt_prec tc tys = + sdocOption sdocListTuplePuns $ \listTuplePuns -> + if | listTuplePuns, tc `ifaceTyConHasKey` listTyConKey, [ty] <- tys + -> brackets (pp topPrec ty) - | not (isSymOcc (nameOccName (ifaceTyConName tc))) - = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) + | tc `ifaceTyConHasKey` liftedTypeKindTyConKey + -> ppr_kind_type ctxt_prec - | [ 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) + | not (isSymOcc (nameOccName (ifaceTyConName tc))) + -> pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) - | otherwise - = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) 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) + | otherwise + -> pprIfacePrefixApp ctxt_prec (parens (ppr 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. -- @@ -1657,12 +1723,9 @@ IsPromoted -> let tys = appArgsIfaceTypes args args' = drop (length tys `div` 2) tys - spaceIfPromoted = case args' of - arg0:_ -> pprSpaceIfPromotedTyCon arg0 - _ -> id in ppr_tuple_app args' $ pprPromotionQuoteI IsPromoted <> - tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args')) + tupleParens sort (spaceIfSingleQuote (pprWithCommas pprIfaceType args')) NotPromoted | ConstraintTuple <- sort @@ -1688,9 +1751,12 @@ -- `Solo x`, not `(x)` | [_] <- args_wo_runtime_reps , BoxedTuple <- sort - = let unit_tc_info = mkIfaceTyConInfo promoted IfaceNormalTyCon - unit_tc = IfaceTyCon (tupleTyConName sort 1) unit_tc_info in - pprPrecIfaceType ctxt_prec $ IfaceTyConApp unit_tc args + = 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 | otherwise = ppr_args_w_parens @@ -1710,16 +1776,21 @@ ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co)) = ppr_special_co ctxt_prec (text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co] -ppr_co ctxt_prec (IfaceFunCo r cow co1 co2) + +ppr_co ctxt_prec (IfaceFunCo r co_mult co1 co2) = maybeParen ctxt_prec funPrec $ - sep (ppr_co funPrec co1 : ppr_fun_tail cow co2) + sep (ppr_co funPrec co1 : ppr_fun_tail co_mult co2) where - ppr_fun_tail cow' (IfaceFunCo r cow co1 co2) - = (coercionArrow cow' <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail cow co2 - ppr_fun_tail cow' other_co - = [coercionArrow cow' <> ppr_role r <+> pprIfaceCoercion other_co] - coercionArrow w = mulArrow (ppr_co topPrec w) + ppr_fun_tail co_mult1 (IfaceFunCo r co_mult2 co1 co2) + = (ppr_arrow co_mult1 <> ppr_role r <+> ppr_co funPrec co1) + : ppr_fun_tail co_mult2 co2 + ppr_fun_tail co_mult1 other_co + = [ppr_arrow co_mult1 <> ppr_role r <+> pprIfaceCoercion other_co] + ppr_arrow = pprArrow (mb_conc, ppr_co) visArgTypeLike + mb_conc (IfaceTyConAppCo _ tc _) = Just tc + mb_conc _ = Nothing + ppr_co _ (IfaceTyConAppCo r tc cos) = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r ppr_co ctxt_prec (IfaceAppCo co1 co2) @@ -1765,8 +1836,8 @@ ppr_trans c = [semi <+> ppr_co opPrec c] in maybeParen ctxt_prec opPrec $ vcat (ppr_co topPrec co1 : ppr_trans co2) -ppr_co ctxt_prec (IfaceNthCo d co) - = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co] +ppr_co ctxt_prec (IfaceSelCo d co) + = ppr_special_co ctxt_prec (text "SelCo:" <> ppr d) [co] ppr_co ctxt_prec (IfaceLRCo lr co) = ppr_special_co ctxt_prec (ppr lr) [co] ppr_co ctxt_prec (IfaceSubCo co) @@ -1808,11 +1879,21 @@ pprPromotionQuote :: IfaceTyCon -> SDoc pprPromotionQuote tc = - pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc + getPprStyle $ \sty -> + let + name = getOccName (ifaceTyConName tc) + ticked = + case ifaceTyConIsPromoted (ifaceTyConInfo tc) of + NotPromoted -> False + IsPromoted -> promTick sty (PromotedItemDataCon name) + in + if ticked + then char '\'' + else empty pprPromotionQuoteI :: PromotionFlag -> SDoc pprPromotionQuoteI NotPromoted = empty -pprPromotionQuoteI IsPromoted = char '\'' +pprPromotionQuoteI IsPromoted = char '\'' instance Outputable IfaceCoercion where ppr = pprIfaceCoercion @@ -2056,7 +2137,7 @@ putByte bh 11 put_ bh a put_ bh b - put_ bh (IfaceNthCo a b) = do + put_ bh (IfaceSelCo a b) = do putByte bh 12 put_ bh a put_ bh b @@ -2093,10 +2174,10 @@ b <- get bh c <- get bh return $ IfaceGReflCo a b c - 3 -> do a <- get bh - w <- get bh - b <- get bh - c <- get bh + 3 -> do a <- get bh + w <- get bh + b <- get bh + c <- get bh return $ IfaceFunCo a w b c 4 -> do a <- get bh b <- get bh @@ -2127,7 +2208,7 @@ return $ IfaceTransCo a b 12-> do a <- get bh b <- get bh - return $ IfaceNthCo a b + return $ IfaceSelCo a b 13-> do a <- get bh b <- get bh return $ IfaceLRCo a b @@ -2213,7 +2294,7 @@ IfaceUnivCo f1 f2 f3 f4 -> rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 IfaceSymCo f1 -> rnf f1 IfaceTransCo f1 f2 -> rnf f1 `seq` rnf f2 - IfaceNthCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceSelCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceLRCo f1 f2 -> f1 `seq` rnf f2 IfaceInstCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceKindCo f1 -> rnf f1 diff --git a/GHC/IfaceToCore.hs b/GHC/IfaceToCore.hs --- a/GHC/IfaceToCore.hs +++ b/GHC/IfaceToCore.hs @@ -11,12 +11,13 @@ {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} module GHC.IfaceToCore ( tcLookupImported_maybe, importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, + typecheckWholeCoreBindings, typecheckIfacesForMerging, typecheckIfaceForInstantiate, tcIfaceDecl, tcIfaceDecls, @@ -24,7 +25,7 @@ tcIfaceAnnotations, tcIfaceCompleteMatches, tcIfaceExpr, -- Desired by HERMIT (#7683) tcIfaceGlobal, - tcIfaceOneShot, + tcIfaceOneShot, tcTopIfaceBindings, hydrateCgBreakInfo ) where @@ -36,6 +37,7 @@ import GHC.Driver.Env import GHC.Driver.Session +import GHC.Driver.Config.Core.Lint ( initLintConfig ) import GHC.Builtin.Types.Literals(typeNatCoAxiomRules) import GHC.Builtin.Types @@ -61,8 +63,9 @@ import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core -import GHC.Core.Unify( RoughMatchTc(..) ) +import GHC.Core.RoughMap( RoughMatchTc(..) ) import GHC.Core.Utils +import GHC.Core.Unfold( calcUnfoldingGuidance ) import GHC.Core.Unfold.Make import GHC.Core.Lint import GHC.Core.Make @@ -101,7 +104,9 @@ import GHC.Types.TypeEnv import GHC.Types.Unique.FM import GHC.Types.Unique.DSet ( mkUniqDSet ) +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import GHC.Types.Unique.Supply +import GHC.Types.Demand( isDeadEndSig ) import GHC.Types.Literal import GHC.Types.Var as Var import GHC.Types.Var.Set @@ -121,6 +126,10 @@ import Control.Monad import GHC.Parser.Annotation import GHC.Driver.Env.KnotVars +import GHC.Unit.Module.WholeCoreBindings +import Data.IORef +import Data.Foldable +import GHC.Builtin.Names (ioTyConName, rOOT_MAIN) {- This module takes @@ -237,6 +246,12 @@ } } +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 + + {- ************************************************************************ * * @@ -330,7 +345,7 @@ mergeRoles roles1 roles2 = zipWithEqual "mergeRoles" max roles1 roles2 isRepInjectiveIfaceDecl :: IfaceDecl -> Bool -isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True +isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon{} } = True isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True isRepInjectiveIfaceDecl _ = False @@ -581,9 +596,9 @@ Nothing -> return NoSelfBoot -- error cases Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of - IsBoot -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints (elaborate err)) + IsBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints (elaborate err)) -- The hi-boot file has mysteriously disappeared. - NotBoot -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints moduleLoop) + NotBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints moduleLoop) -- Someone below us imported us! -- This is a loop with no hi-boot in the way }}}} @@ -610,7 +625,7 @@ return $ SelfBoot { sb_mds = mds , sb_tcs = mkNameSet tcs } where - -- Retuerns @True@ if, when you call 'tcIfaceDecl' on + -- 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 @@ -876,7 +891,7 @@ , ifFieldLabels = field_labels }) = do { traceIf (text "tc_iface_decl" <+> ppr name) ; matcher <- tc_pr if_matcher - ; builder <- fmapMaybeM tc_pr if_builder + ; builder <- traverse tc_pr if_builder ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do { patsyn <- forkM (mk_doc name) $ @@ -895,6 +910,58 @@ tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm) ; return (nm, idType id, b) } +tcTopIfaceBindings :: IORef TypeEnv -> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] + -> IfL [CoreBind] +tcTopIfaceBindings ty_var ver_decls + = do + 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 + +tcTopBinders :: IfaceBindingX a IfaceTopBndrInfo -> IfL (IfaceBindingX a Id) +tcTopBinders = traverse mk_top_id + +tc_iface_bindings :: IfaceBindingX IfaceMaybeRhs Id -> IfL CoreBind +tc_iface_bindings (IfaceNonRec b rhs) = do + rhs' <- tc_iface_binding b rhs + return $ NonRec b rhs' +tc_iface_bindings (IfaceRec bs) = do + rs <- mapM (\(b, rhs) -> (b,) <$> tc_iface_binding b rhs) bs + return (Rec rs) + +-- | See Note [Interface File with Core: Sharing RHSs] +tc_iface_binding :: Id -> IfaceMaybeRhs -> IfL CoreExpr +tc_iface_binding i IfUseUnfoldingRhs = + case maybeUnfoldingTemplate $ realIdUnfolding i of + Just e -> return e + Nothing -> pprPanic "tc_iface_binding" (vcat [text "Binding" <+> quotes (ppr i) <+> text "had an unfolding when the interface file was created" + , text "which has now gone missing, something has badly gone wrong." + , text "Unfolding:" <+> ppr (realIdUnfolding i)]) + +tc_iface_binding _ (IfRhs rhs) = tcIfaceExpr rhs + +mk_top_id :: IfaceTopBndrInfo -> IfL Id +mk_top_id (IfGblTopBndr gbl_name) + -- See Note [Root-main Id] + -- This special binding is actually defined in the current module + -- (hence don't go looking for it externally) but the module name is rOOT_MAIN + -- rather than the current module so we need this special case. + -- See some similar logic in `GHC.Rename.Env`. + | Just rOOT_MAIN == nameModule_maybe gbl_name + = do + ATyCon ioTyCon <- tcIfaceGlobal ioTyConName + 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 + info' <- tcIdInfo False TopLevel name ty info + details' <- tcIdDetails ty details + let new_id = mkGlobalId details' name ty info' + return new_id + tcIfaceDecls :: Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name,TyThing)] @@ -1039,11 +1106,12 @@ = case if_cons of IfAbstractTyCon -> return AbstractTyCon - IfDataTyCon cons + IfDataTyCon type_data cons -> do { data_cons <- mapM tc_con_decl cons ; return $ mkLevPolyDataTyConRhs (isFixedRuntimeRepKind $ tyConResKind tycon) + type_data data_cons } IfNewTyCon con -> do { data_con <- tc_con_decl con @@ -1129,7 +1197,7 @@ tc_strict :: IfaceBang -> IfL HsImplBang tc_strict IfNoBang = return (HsLazy) - tc_strict IfStrict = return (HsStrict) + tc_strict IfStrict = return (HsStrict True) tc_strict IfUnpack = return (HsUnpack Nothing) tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co ; return (HsUnpack (Just co)) } @@ -1231,7 +1299,7 @@ (nonDetEltsUFM $ if_id_env lcl_env) ++ bndrs' ++ exprsFreeIdsList args') - ; case lintExpr dflags in_scope rhs' of + ; case lintExpr (initLintConfig dflags in_scope) rhs' of Nothing -> return () Just errs -> do logger <- getLogger @@ -1409,11 +1477,10 @@ go (IfaceReflCo t) = Refl <$> tcIfaceType t go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco - go (IfaceFunCo r w c1 c2) = mkFunCo r <$> go w <*> go c1 <*> go c2 - go (IfaceTyConAppCo r tc cs) - = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs + 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 k c) = do { k' <- go k ; bindIfaceBndr tv $ \ tv' -> ForAllCo tv' k' <$> go c } go (IfaceCoVarCo n) = CoVarCo <$> go_var n @@ -1425,8 +1492,8 @@ <*> go c2 go (IfaceInstCo c1 t2) = InstCo <$> go c1 <*> go t2 - go (IfaceNthCo d c) = do { c' <- go c - ; return $ mkNthCo (nthCoRole d c') d c' } + go (IfaceSelCo d c) = do { c' <- go c + ; return $ mkSelCo d c' } go (IfaceLRCo lr c) = LRCo lr <$> go c go (IfaceKindCo c) = KindCo <$> go c go (IfaceSubCo c) = SubCo <$> go c @@ -1468,9 +1535,9 @@ tcIfaceExpr (IfaceExt gbl) = Var <$> tcIfaceExtId gbl -tcIfaceExpr (IfaceLitRubbish rep) +tcIfaceExpr (IfaceLitRubbish tc rep) = do rep' <- tcIfaceType rep - return (Lit (LitRubbish rep')) + return (Lit (LitRubbish tc rep')) tcIfaceExpr (IfaceLit lit) = do lit' <- tcIfaceLit lit @@ -1515,7 +1582,7 @@ case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) let scrut_ty = exprType scrut' - case_mult = Many + case_mult = ManyTy case_bndr' = mkLocalIdOrCoVar case_bndr_name case_mult scrut_ty -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors -- (e.g. see test T15695). Ticket #17291 covers fixing this problem. @@ -1535,7 +1602,7 @@ ; ty' <- tcIfaceType ty ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} NotTopLevel name ty' info - ; let id = mkLocalIdWithInfo name Many ty' id_info + ; let id = mkLocalIdWithInfo name ManyTy ty' id_info `asJoinId_maybe` tcJoinInfo ji ; rhs' <- tcIfaceExpr rhs ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) @@ -1551,7 +1618,7 @@ tc_rec_bndr (IfLetBndr fs ty _ ji) = do { name <- newIfaceName (mkVarOccFS fs) ; ty' <- tcIfaceType ty - ; return (mkLocalId name Many ty' `asJoinId_maybe` tcJoinInfo ji) } + ; return (mkLocalId name ManyTy ty' `asJoinId_maybe` tcJoinInfo ji) } tc_pair (IfLetBndr _ _ info _, rhs) id = do { rhs' <- tcIfaceExpr rhs ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} @@ -1660,8 +1727,8 @@ need_prag :: IfaceInfoItem -> Bool -- Always read in compulsory unfoldings -- See Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy - need_prag (HsUnfold _ (IfCompulsory {})) = True - need_prag _ = False + need_prag (HsUnfold _ (IfCoreUnfold src _ _ _)) = isCompulsorySource src + need_prag _ = False tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) @@ -1669,7 +1736,6 @@ tcPrag info (HsDmdSig str) = return (info `setDmdSigInfo` str) tcPrag info (HsCprSig cpr) = return (info `setCprSigInfo` cpr) tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) - tcPrag info HsLevity = return (info `setNeverRepPoly` ty) tcPrag info (HsLFInfo lf_info) = do lf_info <- tcLFInfo lf_info return (info `setLFInfo` lf_info) @@ -1722,25 +1788,17 @@ tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding -- See Note [Lazily checking Unfoldings] -tcUnfolding toplvl name _ info (IfCoreUnfold stable cache if_expr) +tcUnfolding toplvl name _ info (IfCoreUnfold src cache if_guidance if_expr) = do { uf_opts <- unfoldingOpts <$> getDynFlags - ; expr <- tcUnfoldingRhs False toplvl name if_expr - ; let unf_src | stable = InlineStable - | otherwise = InlineRhs - ; return $ mkFinalUnfolding uf_opts unf_src strict_sig expr (Just cache) } + ; 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 + -- See Note [Tying the 'CoreUnfolding' knot] + ; return $ mkCoreUnfolding src True expr (Just cache) guidance } where -- Strictness should occur before unfolding! - strict_sig = dmdSigInfo info - -tcUnfolding toplvl name _ _ (IfCompulsory if_expr) - = do { expr <- tcUnfoldingRhs True toplvl name if_expr - ; return $ mkCompulsoryUnfolding' expr } - -tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) - = do { expr <- tcUnfoldingRhs False toplvl name if_expr - ; return $ mkCoreUnfolding InlineStable True expr Nothing guidance } - where - guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + is_top_bottoming = isTopLevel toplvl && isDeadEndSig (dmdSigInfo info) tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops) = bindIfaceBndrs bs $ \ bs' -> @@ -1814,7 +1872,7 @@ Conclusion: `tcUnfolding` must return an `Unfolding` whose `uf_src` field is readable without forcing the `uf_tmpl` field. In particular, all the functions used at the end of -`tcUnfolding` (such as `mkFinalUnfolding`, `mkCompulsoryUnfolding'`, `mkCoreUnfolding`) must be +`tcUnfolding` (such as `mkFinalUnfolding`, `mkCoreUnfolding`) must be lazy in `expr`. Ticket #21139 @@ -1831,10 +1889,10 @@ -- See Note [Linting Unfoldings from Interfaces] in GHC.Core.Lint when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do - in_scope <- get_in_scope + in_scope <- nonDetEltsUniqSet <$> get_in_scope dflags <- getDynFlags logger <- getLogger - case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of + case lintUnfolding is_compulsory (initLintConfig dflags in_scope) noSrcLoc core_expr' of Nothing -> return () Just errs -> liftIO $ displayLintResults logger False doc @@ -1903,7 +1961,7 @@ { mb_thing <- importDecl name -- It's imported; go get it ; case mb_thing of - Failed err -> failIfM err + Failed err -> failIfM (ppr name <+> err) Succeeded thing -> return thing }}} @@ -1966,11 +2024,12 @@ -- this expression *after* typechecking T. tcIfaceTyCon :: IfaceTyCon -> IfL TyCon -tcIfaceTyCon (IfaceTyCon name info) +tcIfaceTyCon (IfaceTyCon name _info) = do { thing <- tcIfaceGlobal name - ; return $ case ifaceTyConIsPromoted info of - NotPromoted -> tyThingTyCon thing - IsPromoted -> promoteDataCon $ tyThingDataCon thing } + ; case thing of + ATyCon tc -> return tc + AConLike (RealDataCon dc) -> return (promoteDataCon dc) + _ -> pprPanic "tcIfaceTyCon" (ppr thing) } tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name diff --git a/GHC/JS/Make.hs b/GHC/JS/Make.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Make.hs @@ -0,0 +1,715 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} -- only for Num, Fractional on JExpr + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Make +-- 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.Make defines helper functions to ease the creation of JavaScript +-- ASTs as defined in 'GHC.JS.Syntax'. Its purpose is twofold: make the EDSL +-- more ergonomic to program in, and make errors in the EDSL /look/ obvious +-- because the EDSL is untyped. It is primarily concerned with injecting +-- terms into the domain of the EDSL to construct JS programs in Haskell. +-- +-- * Strategy +-- +-- The strategy for this module comes straight from gentzen; where we have +-- two types of helper functions. Functions which inject terms into the +-- EDSL, and combinator functions which operate on terms in the EDSL to +-- 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. +-- +-- * /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. +-- +-- * /Combinator/ functions +-- +-- The rest of the module defines combinators which create terms in +-- the EDSL from terms in the EDSL. Notable examples are '|=' and +-- '||=', '|=' is sugar for 'AssignStat', it is a binding form that +-- declares @foo = bar@ /assuming/ foo has been already declared. +-- '||=' is more sugar on top of '|=', it is also a binding form that +-- declares the LHS of '|=' before calling '|=' to bind a value, bar, +-- to a variable foo. Other common examples are the 'if_' and 'math_' +-- helpers such as 'math_cos'. +-- +-- * Consumers +-- +-- The entire JS backend consumes this module, e.g., the modules in +-- GHC.StgToJS.\*. +-- +-- * Notation +-- +-- In this module we use @==>@ in docstrings to show the translation from +-- 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. +----------------------------------------------------------------------------- +module GHC.JS.Make + ( -- * Injection Type classes + -- $classes + ToJExpr(..) + , ToStat(..) + -- * Introduction functions + -- $intro_funcs + , var + , jString + , jLam, jVar, jFor, jForIn, jForEachIn, jTryCatchFinally + -- * Combinators + -- $combinators + , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!) + , (.>.), (.>=.), (.<.), (.<=.) + , (.<<.), (.>>.), (.>>>.) + , (.|.), (.||.), (.&&.) + , if_, if10, if01, ifS, ifBlockS + , jwhenS + , app, appS, returnS + , loop, loopBlockS + , preIncrS, postIncrS + , preDecrS, postDecrS + , off8, off16, off32, off64 + , mask8, mask16 + , signExtend8, signExtend16 + , typeof + , returnStack, assignAllEqual, assignAll, assignAllReverseOrder + , declAssignAll + , nullStat, (.^) + , trace + -- ** Hash combinators + , jhEmpty + , jhSingle + , jhAdd + , jhFromList + -- * Literals + -- $literals + , null_ + , undefined_ + , false_ + , true_ + , zero_ + , one_ + , two_ + , three_ + -- ** Math functions + -- $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 + -- * Statement helpers + , decl + -- * Miscellaneous + -- $misc + , allocData, allocClsA + , dataFieldName, dataFieldNames + ) +where + +import GHC.Prelude hiding ((.|.)) + +import GHC.JS.Syntax + +import Control.Arrow ((***)) + +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 + +-------------------------------------------------------------------------------- +-- Type Classes +-------------------------------------------------------------------------------- +-- $classes +-- The 'ToJExpr' class handles injection of of things into the EDSL as a JS +-- expression + +-- | Things that can be marshalled into javascript values. +-- Instantiate for any necessary data structures. +class ToJExpr a where + toJExpr :: a -> JExpr + toJExprFromList :: [a] -> JExpr + toJExprFromList = ValExpr . JList . map toJExpr + +instance ToJExpr a => ToJExpr [a] where + toJExpr = toJExprFromList + +instance ToJExpr JExpr where + toJExpr = id + +instance ToJExpr () where + toJExpr _ = ValExpr $ JList [] + +instance ToJExpr Bool where + toJExpr True = var "true" + toJExpr False = var "false" + +instance ToJExpr JVal where + toJExpr = ValExpr + +instance ToJExpr a => ToJExpr (UniqMap FastString a) where + toJExpr = ValExpr . JHash . mapUniqMap toJExpr + +instance ToJExpr a => ToJExpr (M.Map String a) where + toJExpr = ValExpr . JHash . listToUniqMap . map (mkFastString *** toJExpr) . M.toList + +instance ToJExpr Double where + toJExpr = ValExpr . JDouble . SaneDouble + +instance ToJExpr Int where + toJExpr = ValExpr . JInt . fromIntegral + +instance ToJExpr Integer where + toJExpr = ValExpr . JInt + +instance ToJExpr Char where + toJExpr = ValExpr . JStr . mkFastString . (:[]) + toJExprFromList = ValExpr . JStr . mkFastString +-- where escQuotes = tailDef "" . initDef "" . show + +instance ToJExpr Ident where + toJExpr = ValExpr . JVar + +instance ToJExpr FastString where + toJExpr = ValExpr . JStr + +instance (ToJExpr a, ToJExpr b) => ToJExpr (a,b) where + toJExpr (a,b) = ValExpr . JList $ [toJExpr a, toJExpr b] + +instance (ToJExpr a, ToJExpr b, ToJExpr c) => ToJExpr (a,b,c) where + toJExpr (a,b,c) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c] + +instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d) => ToJExpr (a,b,c,d) where + toJExpr (a,b,c,d) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d] +instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e) => ToJExpr (a,b,c,d,e) where + toJExpr (a,b,c,d,e) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e] +instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e, ToJExpr f) => ToJExpr (a,b,c,d,e,f) where + toJExpr (a,b,c,d,e,f) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f] + + +-- | The 'ToStat' class handles injection of of things into the EDSL as a JS +-- statement. This ends up being polymorphic sugar for JS blocks, see helper +-- function 'GHC.JS.Make.expr2stat'. Instantiate for any necessary data +-- structures. +class ToStat a where + toStat :: a -> JStat + +instance ToStat JStat where + toStat = id + +instance ToStat [JStat] where + toStat = BlockStat + +instance ToStat JExpr where + toStat = expr2stat + +instance ToStat [JExpr] where + toStat = BlockStat . map expr2stat + +-------------------------------------------------------------------------------- +-- Introduction Functions +-------------------------------------------------------------------------------- +-- $intro_functions +-- Introduction functions are functions that map values or terms in the Haskell +-- domain to the JS EDSL domain + +-- | Create a new anonymous function. The result is a 'GHC.JS.Syntax.JExpr' +-- expression. +-- Usage: +-- +-- > 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 + +-- | Introduce a new variable into scope for the duration +-- of the enclosed expression. The result is a block statement. +-- 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 + +-- | 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 + +-- | 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 + +-- | 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 + +-- | construct a JS variable reference +var :: FastString -> JExpr +var = ValExpr . JVar . TxtI + +-- | Convert a ShortText to a Javascript String +jString :: FastString -> JExpr +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 i = DeclStat i Nothing + +-- | The empty JS HashMap +jhEmpty :: M.Map k JExpr +jhEmpty = M.empty + +-- | A singleton JS HashMap +jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr +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 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 = JHash . listToUniqMap + +-- | The empty JS statement +nullStat :: JStat +nullStat = BlockStat [] + + +-------------------------------------------------------------------------------- +-- Combinators +-------------------------------------------------------------------------------- +-- $combinators +-- Combinators operate on terms in the JS EDSL domain to create new terms in the +-- EDSL domain. + +-- | JS infix Equality operators +(.==.), (.===.), (.!=.), (.!==.) :: JExpr -> JExpr -> JExpr +(.==.) = InfixExpr EqOp +(.===.) = InfixExpr StrictEqOp +(.!=.) = InfixExpr NeqOp +(.!==.) = InfixExpr StrictNeqOp + +infixl 6 .==., .===., .!=., .!==. + +-- | JS infix Ord operators +(.>.), (.>=.), (.<.), (.<=.) :: JExpr -> JExpr -> JExpr +(.>.) = InfixExpr GtOp +(.>=.) = InfixExpr GeOp +(.<.) = InfixExpr LtOp +(.<=.) = InfixExpr LeOp + +infixl 7 .>., .>=., .<., .<=. + +-- | JS infix bit operators +(.|.), (.||.), (.&&.) :: JExpr -> JExpr -> JExpr +(.|.) = InfixExpr BOrOp +(.||.) = InfixExpr LOrOp +(.&&.) = InfixExpr LAndOp + +infixl 8 .||., .&&. + +-- | JS infix bit shift operators +(.<<.), (.>>.), (.>>>.) :: JExpr -> JExpr -> JExpr +(.<<.) = InfixExpr LeftShiftOp +(.>>.) = InfixExpr RightShiftOp +(.>>>.) = InfixExpr ZRightShiftOp + +infixl 9 .<<., .>>., .>>>. + +-- | Given a 'JExpr', return the its type. +typeof :: JExpr -> JExpr +typeof = UOpExpr TypeofOp + +-- | JS if-expression +-- +-- > if_ e1 e2 e3 ==> e1 ? e2 : e3 +if_ :: JExpr -> JExpr -> JExpr -> JExpr +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 e s1 s2 = IfStat e s1 s2 + +-- | 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 + +-- | If-expression which returns blocks +-- +-- > ifBlockS e s1 s2 ==> if(e) { s1 } else { s2 } +ifBlockS :: JExpr -> [JStat] -> [JStat] -> JStat +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 e = IfExpr e one_ zero_ + +-- | if-expression that returns 0 if condition <=> true, 1 otherwise +-- +-- > if01 e ==> e ? 0 : 1 +if01 :: JExpr -> JExpr +if01 e = IfExpr e zero_ one_ + +-- | an expression application, see related 'appS' +-- +-- > app f xs ==> f(xs) +app :: FastString -> [JExpr] -> JExpr +app f xs = ApplExpr (var f) xs + +-- | A statement application, see the expression form 'app' +appS :: FastString -> [JExpr] -> JStat +appS f xs = ApplStat (var f) xs + +-- | Return a 'JExpr' +returnS :: JExpr -> JStat +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) + ] + +-- | "for" loop with increment at end of body +loopBlockS :: JExpr -> (JExpr -> JExpr) -> (JExpr -> [JStat]) -> JStat +loopBlockS initial test body = jVar $ \i -> + mconcat [ i |= initial + , WhileStat False (test i) (mconcat (body i)) + ] + +-- | Prefix-increment a 'JExpr' +preIncrS :: JExpr -> JStat +preIncrS x = UOpStat PreIncOp x + +-- | Postfix-increment a 'JExpr' +postIncrS :: JExpr -> JStat +postIncrS x = UOpStat PostIncOp x + +-- | Prefix-decrement a 'JExpr' +preDecrS :: JExpr -> JStat +preDecrS x = UOpStat PreDecOp x + +-- | Postfix-decrement a 'JExpr' +postDecrS :: JExpr -> JStat +postDecrS x = UOpStat PostDecOp x + +-- | Byte indexing of o with a 64-bit offset +off64 :: JExpr -> JExpr -> JExpr +off64 o i = Add o (i .<<. three_) + +-- | Byte indexing of o with a 32-bit offset +off32 :: JExpr -> JExpr -> JExpr +off32 o i = Add o (i .<<. two_) + +-- | Byte indexing of o with a 16-bit offset +off16 :: JExpr -> JExpr -> JExpr +off16 o i = Add o (i .<<. one_) + +-- | Byte indexing of o with a 8-bit offset +off8 :: JExpr -> JExpr -> JExpr +off8 o i = Add o i + +-- | a bit mask to retrieve the lower 8-bits +mask8 :: JExpr -> JExpr +mask8 x = BAnd x (Int 0xFF) + +-- | a bit mask to retrieve the lower 16-bits +mask16 :: JExpr -> JExpr +mask16 x = BAnd x (Int 0xFFFF) + +-- | Sign-extend/narrow a 8-bit value +signExtend8 :: JExpr -> JExpr +signExtend8 x = (BAnd x (Int 0x7F )) `Sub` (BAnd x (Int 0x80)) + +-- | Sign-extend/narrow a 16-bit value +signExtend16 :: JExpr -> JExpr +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) +infixl 8 .^ + +-- | Assign a variable to an expression +-- +-- > foo |= expr ==> var foo = expr; +(|=) :: JExpr -> JExpr -> JStat +(|=) = AssignStat + +-- | Declare a variable and then Assign the variable to an expression +-- +-- > foo |= expr ==> var foo; foo = expr; +(||=) :: Ident -> JExpr -> JStat +i ||= ex = DeclStat i (Just ex) + +infixl 2 ||=, |= + +-- | return the expression at idx of obj +-- +-- > obj .! idx ==> obj[idx] +(.!) :: JExpr -> JExpr -> JExpr +(.!) = IdxExpr + +infixl 8 .! + +assignAllEqual :: HasDebugCallStack => [JExpr] -> [JExpr] -> JStat +assignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" (|=) xs ys) + +assignAll :: [JExpr] -> [JExpr] -> JStat +assignAll xs ys = mconcat (zipWith (|=) xs ys) + +assignAllReverseOrder :: [JExpr] -> [JExpr] -> JStat +assignAllReverseOrder xs ys = mconcat (reverse (zipWith (|=) xs ys)) + +declAssignAll :: [Ident] -> [JExpr] -> JStat +declAssignAll xs ys = mconcat (zipWith (||=) xs ys) + +trace :: ToJExpr a => a -> JStat +trace ex = appS "h$log" [toJExpr ex] + + +-------------------------------------------------------------------------------- +-- Literals +-------------------------------------------------------------------------------- +-- $literals +-- Literals in the JS EDSL are constants in the Haskell domain. These are useful +-- helper values and never change + +-- | The JS literal 'null' +null_ :: JExpr +null_ = var "null" + +-- | The JS literal 0 +zero_ :: JExpr +zero_ = Int 0 + +-- | The JS literal 1 +one_ :: JExpr +one_ = Int 1 + +-- | The JS literal 2 +two_ :: JExpr +two_ = Int 2 + +-- | The JS literal 3 +three_ :: JExpr +three_ = Int 3 + +-- | The JS literal 'undefined' +undefined_ :: JExpr +undefined_ = var "undefined" + +-- | The JS literal 'true' +true_ :: JExpr +true_ = var "true" + +-- | The JS literal 'false' +false_ :: JExpr +false_ = var "false" + +returnStack :: JStat +returnStack = ReturnStat (ApplExpr (var "h$rs") []) + + +-------------------------------------------------------------------------------- +-- Math functions +-------------------------------------------------------------------------------- +-- $math +-- 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_ :: FastString -> [JExpr] -> JExpr +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_log = math_ "log" +math_sin = math_ "sin" +math_cos = math_ "cos" +math_tan = math_ "tan" +math_exp = math_ "exp" +math_acos = math_ "acos" +math_asin = math_ "asin" +math_atan = math_ "atan" +math_abs = math_ "abs" +math_pow = math_ "pow" +math_sign = math_ "sign" +math_sqrt = math_ "sqrt" +math_asinh = math_ "asinh" +math_acosh = math_ "acosh" +math_atanh = math_ "atanh" +math_sinh = math_ "sinh" +math_cosh = math_ "cosh" +math_tanh = math_ "tanh" +math_expm1 = math_ "expm1" +math_log1p = math_ "log1p" +math_fround = math_ "fround" + +instance Num JExpr where + x + y = InfixExpr AddOp x y + x - y = InfixExpr SubOp x y + x * y = InfixExpr MulOp x y + abs x = math_abs [x] + negate x = UOpExpr NegOp x + signum x = math_sign [x] + fromInteger x = ValExpr (JInt x) + +instance Fractional JExpr where + x / y = InfixExpr DivOp x y + fromRational x = ValExpr (JDouble (realToFrac x)) + + +-------------------------------------------------------------------------------- +-- Miscellaneous +-------------------------------------------------------------------------------- +-- $misc +-- Everything else, + +-- | Cache "dXXX" field names +dataFieldCache :: Array Int FastString +dataFieldCache = listArray (0,nFieldCache) (map (mkFastString . ('d':) . show) [(0::Int)..nFieldCache]) + +nFieldCache :: Int +nFieldCache = 16384 + +dataFieldName :: Int -> FastString +dataFieldName i + | i < 1 || i > nFieldCache = panic "dataFieldName" (ppr i) + | otherwise = dataFieldCache ! i + +dataFieldNames :: [FastString] +dataFieldNames = fmap dataFieldName [1..nFieldCache] + + +-- | Cache "h$dXXX" names +dataCache :: Array Int FastString +dataCache = listArray (0,1024) (map (mkFastString . ("h$d"++) . show) [(0::Int)..1024]) + +allocData :: Int -> JExpr +allocData i = toJExpr (TxtI (dataCache ! i)) + +-- | Cache "h$cXXX" names +clsCache :: Array Int FastString +clsCache = listArray (0,1024) (map (mkFastString . ("h$c"++) . show) [(0::Int)..1024]) + +allocClsA :: Int -> JExpr +allocClsA i = toJExpr (TxtI (clsCache ! i)) + + +-------------------------------------------------------------------------------- +-- New Identifiers +-------------------------------------------------------------------------------- + +-- | The 'ToSat' class is heavily used in the Introduction function. It ensures +-- that all identifiers in the EDSL are tracked and named with an 'IdentSupply'. +class ToSat a where + toSat_ :: a -> [Ident] -> IdentSupply (JStat, [Ident]) + +instance ToSat [JStat] where + toSat_ f vs = IS $ return $ (BlockStat f, reverse vs) + +instance ToSat JStat where + toSat_ f vs = IS $ return $ (f, reverse vs) + +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" + diff --git a/GHC/JS/Ppr.hs b/GHC/JS/Ppr.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Ppr.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} + +-- For Outputable instances for JS syntax +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Pretty-printing JavaScript +module GHC.JS.Ppr + ( renderJs + , renderJs' + , renderPrefixJs + , renderPrefixJs' + , JsToDoc(..) + , defaultRenderJs + , RenderJs(..) + , jsToDoc + , pprStringLit + , flattenBlocks + , braceNest + , hangBrace + ) +where + +import GHC.Prelude + +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.Data.FastString +import GHC.Types.Unique.Map + +instance Outputable JExpr where + ppr = docToSDoc . renderJs + +instance Outputable JVal where + ppr = docToSDoc . renderJs + + +($$$) :: Doc -> Doc -> Doc +x $$$ y = nest 2 $ x $+$ y + +-- | 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 = renderJs' defaultRenderJs + +renderJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc +renderJs' r = jsToDocR r . jsSaturate Nothing + +data RenderJs = RenderJs + { renderJsS :: !(RenderJs -> JStat -> Doc) + , renderJsE :: !(RenderJs -> JExpr -> Doc) + , renderJsV :: !(RenderJs -> JVal -> Doc) + , renderJsI :: !(RenderJs -> Ident -> Doc) + } + +defaultRenderJs :: RenderJs +defaultRenderJs = RenderJs defRenderJsS defRenderJsE defRenderJsV defRenderJsI + +jsToDoc :: JsToDoc a => a -> Doc +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) + +braceNest :: Doc -> Doc +braceNest x = char '{' <+> nest 2 x $$ char '}' + +-- | Hang with braces: +-- +-- hdr { +-- body +-- } +hangBrace :: Doc -> Doc -> Doc +hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ] + +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) + +defRenderJsS :: RenderJs -> 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) + 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 + where + printBS (BlockStat ss) = vcat $ interSemi $ flattenBlocks 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) + 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' + 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 + -- 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() + -- { + -- ... + -- }); + -- + 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 + 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) + +flattenBlocks :: [JStat] -> [JStat] +flattenBlocks = \case + BlockStat y:ys -> flattenBlocks y ++ flattenBlocks ys + y:ys -> y : flattenBlocks ys + [] -> [] + +optParens :: RenderJs -> JExpr -> Doc +optParens r x = case x of + UOpExpr _ _ -> parens (jsToDocR r x) + _ -> jsToDocR r x + +defRenderJsE :: RenderJs -> 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] + 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 + +defRenderJsV :: RenderJs -> JVal -> Doc +defRenderJsV r = \case + JVar i -> jsToDocR r i + JList xs -> brackets . hsep . punctuate comma $ map (jsToDocR r) xs + JDouble (SaneDouble d) + | d < 0 || isNegativeZero d -> parens (double d) + | otherwise -> double d + JInt i + | i < 0 -> parens (integer i) + | otherwise -> integer i + JStr s -> pprStringLit s + JRegEx s -> hcat [char '/',ftext s, char '/'] + 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 + -- 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 + +defRenderJsI :: RenderJs -> Ident -> Doc +defRenderJsI _ (TxtI t) = ftext t + + +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 = \case + NotOp -> "!" + BNotOp -> "~" + NegOp -> "-" + PlusOp -> "+" + NewOp -> "new" + TypeofOp -> "typeof" + DeleteOp -> "delete" + YieldOp -> "yield" + VoidOp -> "void" + PreIncOp -> "++" + PostIncOp -> "++" + PreDecOp -> "--" + PostDecOp -> "--" + +opText :: JOp -> FastString +opText = \case + EqOp -> "==" + StrictEqOp -> "===" + NeqOp -> "!=" + StrictNeqOp -> "!==" + GtOp -> ">" + GeOp -> ">=" + LtOp -> "<" + LeOp -> "<=" + AddOp -> "+" + SubOp -> "-" + MulOp -> "*" + DivOp -> "/" + ModOp -> "%" + LeftShiftOp -> "<<" + RightShiftOp -> ">>" + ZRightShiftOp -> ">>>" + BAndOp -> "&" + BOrOp -> "|" + BXorOp -> "^" + LAndOp -> "&&" + LOrOp -> "||" + InstanceofOp -> "instanceof" + InOp -> "in" + + +isPre :: JUOp -> Bool +isPre = \case + PostIncOp -> False + PostDecOp -> False + _ -> True + +isAlphaOp :: JUOp -> Bool +isAlphaOp = \case + NewOp -> True + TypeofOp -> True + DeleteOp -> True + YieldOp -> True + VoidOp -> True + _ -> False diff --git a/GHC/JS/Syntax.hs b/GHC/JS/Syntax.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Syntax.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE PatternSynonyms #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.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.Syntax defines the Syntax for the JS backend in GHC. It comports +-- with the [ECMA-262](https://tc39.es/ecma262/) although not every +-- production rule of the standard is represented. Code in this module is a +-- fork of [JMacro](https://hackage.haskell.org/package/jmacro) (BSD 3 +-- Clause) by Gershom Bazerman, heavily modified to accomodate GHC's +-- constraints. +-- +-- +-- * Strategy +-- +-- Nothing fancy in this module, this is a classic deeply embeded AST for +-- JS. We define numerous ADTs and pattern synonyms to make pattern matching +-- and constructing ASTs easier. +-- +-- +-- * Consumers +-- +-- The entire JS backend consumes this module, e.g., the modules in +-- GHC.StgToJS.\*. Please see 'GHC.JS.Make' for a module which provides +-- helper functions that use the deeply embedded DSL defined in this module +-- to provide some of the benefits of a shallow embedding. +----------------------------------------------------------------------------- +module GHC.JS.Syntax + ( -- * Deeply embedded JS datatypes + JStat(..) + , JExpr(..) + , JVal(..) + , JOp(..) + , JUOp(..) + , Ident(..) + , identFS + , JsLabel + -- * pattern synonyms over JS operators + , pattern New + , pattern Not + , pattern Negate + , pattern Add + , pattern Sub + , pattern Mul + , pattern Div + , pattern Mod + , pattern BOr + , pattern BAnd + , pattern BXor + , pattern BNot + , pattern LOr + , pattern LAnd + , pattern Int + , pattern String + , pattern PreInc + , pattern PostInc + , pattern PreDec + , pattern PostDec + -- * Ident supply + , IdentSupply(..) + , newIdentSupply + , pseudoSaturate + -- * Utility + , SaneDouble(..) + ) where + +import GHC.Prelude + +import Control.DeepSeq + +import Data.Function +import Data.Data +import Data.Word +import qualified Data.Semigroup as Semigroup + +import GHC.Generics + +import GHC.Data.FastString +import GHC.Utils.Monad.State.Strict +import GHC.Types.Unique +import GHC.Types.Unique.Map + +-- | A supply of identifiers, possibly empty +newtype IdentSupply a + = IS {runIdentSupply :: State [Ident] a} + deriving Typeable + +instance NFData (IdentSupply a) where rnf IS{} = () + +inIdentSupply :: (State [Ident] a -> State [Ident] b) -> IdentSupply a -> IdentSupply b +inIdentSupply f x = IS $ f (runIdentSupply x) + +instance Functor IdentSupply where + fmap f x = inIdentSupply (fmap f) x + +newIdentSupply :: Maybe FastString -> [Ident] +newIdentSupply Nothing = newIdentSupply (Just "jmId") +newIdentSupply (Just pfx) = [ TxtI (mconcat [pfx,"_",mkFastString (show x)]) + | x <- [(0::Word64)..] + ] + +-- | Given a Pseudo-saturate a value with garbage @<>@ identifiers. +pseudoSaturate :: IdentSupply a -> a +pseudoSaturate x = evalState (runIdentSupply x) $ newIdentSupply (Just "<>") + +instance Eq a => Eq (IdentSupply a) where + (==) = (==) `on` pseudoSaturate +instance Ord a => Ord (IdentSupply a) where + compare = compare `on` pseudoSaturate +instance Show a => Show (IdentSupply a) where + show x = "(" ++ show (pseudoSaturate x) ++ ")" + + +-------------------------------------------------------------------------------- +-- Statements +-------------------------------------------------------------------------------- +-- | JavaScript statements, see the [ECMA262 +-- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations) +-- for details +data JStat + = DeclStat !Ident !(Maybe JExpr) -- ^ Variable declarations: var foo [= e] + | ReturnStat JExpr -- ^ Return + | IfStat JExpr JStat JStat -- ^ If + | WhileStat Bool JExpr JStat -- ^ While, bool is "do" when True + | 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) + +-- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of +-- course 'LabelStat' +type JsLabel = LexicalFastString + +instance Semigroup JStat where + (<>) = appendJStat + +instance Monoid JStat where + mempty = BlockStat [] + +-- | Append a statement to another statement. 'appendJStat' only returns a +-- 'JStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty +-- 'BlockStat'. That is: +-- > (BlockStat [] , y ) = y +-- > (x , BlockStat []) = x +appendJStat :: JStat -> JStat -> JStat +appendJStat mx my = case (mx,my) of + (BlockStat [] , y ) -> y + (x , BlockStat []) -> x + (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys + (BlockStat xs , ys ) -> BlockStat $ xs ++ [ys] + (xs , BlockStat ys) -> BlockStat $ xs : ys + (xs , ys ) -> BlockStat [xs,ys] + + +-------------------------------------------------------------------------------- +-- Expressions +-------------------------------------------------------------------------------- +-- | JavaScript Expressions +data JExpr + = ValExpr JVal -- ^ All values are trivially expressions + | SelExpr JExpr Ident -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^' + | IdxExpr JExpr JExpr -- ^ Indexing: Obj[foo], see 'GHC.JS.Make..!' + | InfixExpr JOp JExpr JExpr -- ^ Infix Expressions, see 'JExpr' + -- pattern synonyms + | UOpExpr JUOp JExpr -- ^ Unary Expressions + | IfExpr JExpr JExpr JExpr -- ^ If-expression + | ApplExpr JExpr [JExpr] -- ^ Application + | UnsatExpr (IdentSupply JExpr) -- ^ An /Unsaturated/ expression. + -- See 'pseudoSaturate' + deriving (Eq, Typeable, Generic) + +-- * Useful pattern synonyms to ease programming with the deeply embedded JS +-- AST. Each pattern wraps @JUOp@ and @JOp@ into a @JExpr@s to save typing and +-- for convienience. In addition we include a string wrapper for JS string +-- and Integer literals. + +-- | pattern synonym for a unary operator new +pattern New :: JExpr -> JExpr +pattern New x = UOpExpr NewOp x + +-- | pattern synonym for prefix increment @++x@ +pattern PreInc :: JExpr -> JExpr +pattern PreInc x = UOpExpr PreIncOp x + +-- | pattern synonym for postfix increment @x++@ +pattern PostInc :: JExpr -> JExpr +pattern PostInc x = UOpExpr PostIncOp x + +-- | pattern synonym for prefix decrement @--x@ +pattern PreDec :: JExpr -> JExpr +pattern PreDec x = UOpExpr PreDecOp x + +-- | pattern synonym for postfix decrement @--x@ +pattern PostDec :: JExpr -> JExpr +pattern PostDec x = UOpExpr PostDecOp x + +-- | pattern synonym for logical not @!@ +pattern Not :: JExpr -> JExpr +pattern Not x = UOpExpr NotOp x + +-- | pattern synonym for unary negation @-@ +pattern Negate :: JExpr -> JExpr +pattern Negate x = UOpExpr NegOp x + +-- | pattern synonym for addition @+@ +pattern Add :: JExpr -> JExpr -> JExpr +pattern Add x y = InfixExpr AddOp x y + +-- | pattern synonym for subtraction @-@ +pattern Sub :: JExpr -> JExpr -> JExpr +pattern Sub x y = InfixExpr SubOp x y + +-- | pattern synonym for multiplication @*@ +pattern Mul :: JExpr -> JExpr -> JExpr +pattern Mul x y = InfixExpr MulOp x y + +-- | pattern synonym for division @*@ +pattern Div :: JExpr -> JExpr -> JExpr +pattern Div x y = InfixExpr DivOp x y + +-- | pattern synonym for remainder @%@ +pattern Mod :: JExpr -> JExpr -> JExpr +pattern Mod x y = InfixExpr ModOp x y + +-- | pattern synonym for Bitwise Or @|@ +pattern BOr :: JExpr -> JExpr -> JExpr +pattern BOr x y = InfixExpr BOrOp x y + +-- | pattern synonym for Bitwise And @&@ +pattern BAnd :: JExpr -> JExpr -> JExpr +pattern BAnd x y = InfixExpr BAndOp x y + +-- | pattern synonym for Bitwise XOr @^@ +pattern BXor :: JExpr -> JExpr -> JExpr +pattern BXor x y = InfixExpr BXorOp x y + +-- | pattern synonym for Bitwise Not @~@ +pattern BNot :: JExpr -> JExpr +pattern BNot x = UOpExpr BNotOp x + +-- | pattern synonym for logical Or @||@ +pattern LOr :: JExpr -> JExpr -> JExpr +pattern LOr x y = InfixExpr LOrOp x y + +-- | pattern synonym for logical And @&&@ +pattern LAnd :: JExpr -> JExpr -> JExpr +pattern LAnd x y = InfixExpr LAndOp x y + + +-- | pattern synonym to create integer values +pattern Int :: Integer -> JExpr +pattern Int x = ValExpr (JInt x) + +-- | pattern synonym to create string values +pattern String :: FastString -> JExpr +pattern String x = ValExpr (JStr x) + + +-------------------------------------------------------------------------------- +-- Values +-------------------------------------------------------------------------------- +-- | JavaScript values +data JVal + = JVar Ident -- ^ A variable reference + | JList [JExpr] -- ^ A JavaScript list, or what JS + -- calls an Array + | JDouble SaneDouble -- ^ A Double + | JInt Integer -- ^ A BigInt + | JStr FastString -- ^ A String + | JRegEx FastString -- ^ A Regex + | JHash (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@ + | JFunc [Ident] JStat -- ^ A function + | UnsatVal (IdentSupply JVal) -- ^ An /Unsaturated/ value, see 'pseudoSaturate' + deriving (Eq, Typeable, Generic) + +-------------------------------------------------------------------------------- +-- Operators +-------------------------------------------------------------------------------- +-- | JS Binary Operators. We do not deeply embed the comma operator and the +-- assignment operators +data JOp + = EqOp -- ^ Equality: `==` + | StrictEqOp -- ^ Strict Equality: `===` + | NeqOp -- ^ InEquality: `!=` + | StrictNeqOp -- ^ Strict InEquality `!==` + | GtOp -- ^ Greater Than: `>` + | GeOp -- ^ Greater Than or Equal: `>=` + | LtOp -- ^ Less Than: < + | LeOp -- ^ Less Than or Equal: <= + | AddOp -- ^ Addition: + + | SubOp -- ^ Subtraction: - + | MulOp -- ^ Multiplication \* + | DivOp -- ^ Division: \/ + | ModOp -- ^ Remainder: % + | LeftShiftOp -- ^ Left Shift: \<\< + | RightShiftOp -- ^ Right Shift: \>\> + | ZRightShiftOp -- ^ Unsigned RightShift: \>\>\> + | BAndOp -- ^ Bitwise And: & + | BOrOp -- ^ Bitwise Or: | + | BXorOp -- ^ Bitwise XOr: ^ + | LAndOp -- ^ Logical And: && + | LOrOp -- ^ Logical Or: || + | InstanceofOp -- ^ @instanceof@ + | InOp -- ^ @in@ + deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + +instance NFData JOp + +-- | JS Unary Operators +data JUOp + = NotOp -- ^ Logical Not: @!@ + | BNotOp -- ^ Bitwise Not: @~@ + | NegOp -- ^ Negation: @-@ + | PlusOp -- ^ Unary Plus: @+x@ + | NewOp -- ^ new x + | TypeofOp -- ^ typeof x + | DeleteOp -- ^ delete x + | YieldOp -- ^ yield x + | VoidOp -- ^ void x + | PreIncOp -- ^ Prefix Increment: @++x@ + | PostIncOp -- ^ Postfix Increment: @x++@ + | PreDecOp -- ^ Prefix Decrement: @--x@ + | PostDecOp -- ^ Postfix Decrement: @x--@ + deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic) + +instance NFData JUOp + +-- | 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) + +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 + + +-------------------------------------------------------------------------------- +-- Identifiers +-------------------------------------------------------------------------------- +-- We use FastString for identifiers in JS backend + +-- | A newtype wrapper around 'FastString' for JS identifiers. +newtype Ident = TxtI { itxt :: FastString } + deriving stock (Show, Eq) + deriving newtype (Uniquable) + +identFS :: Ident -> FastString +identFS = \case + TxtI fs -> fs diff --git a/GHC/JS/Transform.hs b/GHC/JS/Transform.hs new file mode 100644 --- /dev/null +++ b/GHC/JS/Transform.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE BlockArguments #-} + +module GHC.JS.Transform + ( mapIdent + , mapStatIdent + , mapExprIdent + , identsS + , identsV + , identsE + -- * Saturation + , jsSaturate + -- * Generic traversal (via compos) + , JMacro(..) + , JMGadt(..) + , Compos(..) + , composOp + , composOpM + , composOpM_ + , composOpFold + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax + +import Data.Functor.Identity +import Control.Monad +import Data.Bifunctor + +import GHC.Data.FastString +import GHC.Utils.Monad.State.Strict +import GHC.Types.Unique.Map + +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 = \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 + ForInStat _ i e s -> [i] ++ identsE e ++ identsS s + SwitchStat e xs s -> identsE e ++ concatMap traverseCase xs ++ identsS s + where traverseCase (e,s) = identsE e ++ identsS s + TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3 + BlockStat xs -> concatMap identsS xs + ApplStat e es -> identsE e ++ concatMap identsE es + UOpStat _op e -> identsE e + AssignStat e1 e2 -> identsE e1 ++ identsE e2 + UnsatBlock{} -> error "identsS: UnsatBlock" + LabelStat _l s -> identsS s + BreakStat{} -> [] + ContinueStat{} -> [] + +{-# INLINE identsE #-} +identsE :: JExpr -> [Ident] +identsE = \case + ValExpr v -> identsV v + SelExpr e _i -> identsE e -- do not rename properties + IdxExpr e1 e2 -> identsE e1 ++ identsE e2 + InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2 + UOpExpr _ e -> identsE e + IfExpr e1 e2 e3 -> identsE e1 ++ identsE e2 ++ identsE e3 + ApplExpr e es -> identsE e ++ concatMap identsE es + UnsatExpr{} -> error "identsE: UnsatExpr" + +{-# INLINE identsV #-} +identsV :: JVal -> [Ident] +identsV = \case + JVar i -> [i] + JList xs -> concatMap identsE xs + JDouble{} -> [] + JInt{} -> [] + JStr{} -> [] + JRegEx{} -> [] + JHash m -> concatMap (identsE . snd) (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) + +instance Compos JMGadt where + compos = jmcompos + +jmcompos :: forall m c. (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) -> (forall a. JMGadt a -> m (JMGadt a)) -> JMGadt c -> m (JMGadt c) +jmcompos ret app f' v = + case v of + JMGId _ -> ret v + JMGStat v' -> ret JMGStat `app` case v' of + DeclStat i e -> ret DeclStat `app` f i `app` mapMaybeM' f e + ReturnStat i -> ret ReturnStat `app` f i + IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s' + WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s + 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' + + where + mapM' :: forall a. (a -> m a) -> [a] -> m [a] + mapM' g = foldr (app . app (ret (:)) . g) (ret []) + mapMaybeM' :: forall a. (a -> m a) -> Maybe a -> m (Maybe a) + mapMaybeM' g = \case + Nothing -> ret Nothing + Just a -> app (ret Just) (g a) + f :: forall b. JMacro b => b -> m b + f x = ret jfromGADT `app` f' (jtoGADT x) + +{-------------------------------------------------------------------- + Saturation +--------------------------------------------------------------------} + +-- | Given an optional prefix, fills in all free variable names with a supply +-- of names generated by the prefix. +jsSaturate :: (JMacro a) => Maybe FastString -> a -> a +jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str) + +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 diff --git a/GHC/Linker/Config.hs b/GHC/Linker/Config.hs new file mode 100644 --- /dev/null +++ b/GHC/Linker/Config.hs @@ -0,0 +1,13 @@ +-- | Linker configuration + +module GHC.Linker.Config + ( FrameworkOpts(..) + ) where + +import GHC.Prelude + +-- used on darwin only +data FrameworkOpts = FrameworkOpts + { foFrameworkPaths :: [String] + , foCmdlineFrameworks :: [String] + } diff --git a/GHC/Linker/Dynamic.hs b/GHC/Linker/Dynamic.hs --- a/GHC/Linker/Dynamic.hs +++ b/GHC/Linker/Dynamic.hs @@ -12,6 +12,7 @@ import GHC.Platform import GHC.Platform.Ways +import GHC.Driver.Config.Linker import GHC.Driver.Session import GHC.Unit.Env @@ -23,6 +24,7 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs +import Control.Monad (when) import System.FilePath linkDynLib :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () @@ -83,7 +85,10 @@ | gopt Opt_LinkRts dflags = pkgs_with_rts | otherwise = pkgs_without_rts pkg_link_opts = package_hs_libs ++ extra_libs ++ other_flags - where (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs + where + namever = ghcNameVersion dflags + ways_ = ways dflags + (package_hs_libs, extra_libs, other_flags) = collectLinkOpts namever ways_ pkgs -- probably _stub.o files -- and last temporary shared object file @@ -91,7 +96,7 @@ -- frameworks pkg_framework_opts <- getUnitFrameworkOpts unit_env (map unitId pkgs) - let framework_opts = getFrameworkOpts dflags platform + let framework_opts = getFrameworkOpts (initFrameworkOpts dflags) platform case os of OSMinGW32 -> do @@ -190,7 +195,9 @@ -- See Note [Dynamic linking on macOS] ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ] ) - runInjectRPaths logger dflags pkg_lib_paths output_fn + -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004 + when (gopt Opt_RPath dflags) $ + runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn _ -> do ------------------------------------------------------------------- -- Making a DSO diff --git a/GHC/Linker/ExtraObj.hs b/GHC/Linker/ExtraObj.hs --- a/GHC/Linker/ExtraObj.hs +++ b/GHC/Linker/ExtraObj.hs @@ -124,13 +124,13 @@ text " __conf.rts_opts_enabled = " <> text (show (rtsOptsEnabled dflags)) <> semi, text " __conf.rts_opts_suggestions = " - <> text (if rtsOptsSuggestions dflags - then "true" - else "false") <> semi, + <> (if rtsOptsSuggestions dflags + then text "true" + else text "false") <> semi, text "__conf.keep_cafs = " - <> text (if gopt Opt_KeepCAFs dflags - then "true" - else "false") <> semi, + <> (if gopt Opt_KeepCAFs dflags + then text "true" + else text "false") <> semi, case rtsOpts dflags of Nothing -> Outputable.empty Just opts -> text " __conf.rts_opts= " <> @@ -192,7 +192,7 @@ -- See Note [LinkInfo section] getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String getLinkInfo dflags unit_env dep_packages = do - package_link_opts <- getUnitLinkOpts dflags unit_env dep_packages + package_link_opts <- getUnitLinkOpts (ghcNameVersion dflags) (ways dflags) unit_env dep_packages pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env)) then return [] else do diff --git a/GHC/Linker/Loader.hs b/GHC/Linker/Loader.hs --- a/GHC/Linker/Loader.hs +++ b/GHC/Linker/Loader.hs @@ -77,6 +77,7 @@ import GHC.Unit.Finder import GHC.Unit.Module import GHC.Unit.Module.ModIface +import GHC.Unit.Module.WholeCoreBindings import GHC.Unit.Module.Deps import GHC.Unit.Home.ModInfo import GHC.Unit.State as Packages @@ -837,11 +838,17 @@ while_linking_expr = text "while linking an interpreted expression" - -- This one is a build-system bug + -- 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" (hm_linkable mod_info)) + = 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... @@ -886,8 +893,35 @@ 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 @@ -916,7 +950,7 @@ new_bindings <- linkSomeBCOs bco_opts interp le2 [cbc] 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 } } return (pls2, (nms_fhvs, links_needed, units_needed)) where free_names = uniqDSetToList $ @@ -1131,7 +1165,7 @@ unlinkeds = concatMap linkableUnlinked new_bcos cbcs :: [CompiledByteCode] - cbcs = map byteCodeOfObject unlinkeds + cbcs = concatMap byteCodeOfObject unlinkeds le1 = linker_env pls @@ -1150,7 +1184,7 @@ 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 } } -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: BCOOpts @@ -1499,7 +1533,7 @@ else when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts) $ logMsg logger - (mkMCDiagnostic diag_opts $ WarningWithFlag Opt_WarnMissedExtraSharedLib) + (mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing) noSrcSpan $ withPprStyle defaultUserStyle (note err) where diag_opts = initDiagOpts (hsc_dflags hsc_env) @@ -1687,7 +1721,7 @@ , not loading_dynamic_hs_libs , interpreterProfiled interp = do - let diag = mkMCDiagnostic diag_opts WarningWithoutFlag + let diag = mkMCDiagnostic diag_opts WarningWithoutFlag Nothing logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $ text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ text " \tTrying dynamic library instead. If this fails try to rebuild" <+> @@ -1747,7 +1781,7 @@ -- fork/exec is expensive on Windows, for each time we ask GCC for a library we -- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1. -- So instead get a list of location that GCC would search and use findDirs --- which hopefully is written in an optimized mannor to take advantage of +-- which hopefully is written in an optimized manner to take advantage of -- caching. At the very least we remove the overhead of the fork/exec and waits -- which dominate a large percentage of startup time on Windows. getGccSearchDirectory :: Logger -> DynFlags -> String -> IO [FilePath] @@ -1773,9 +1807,9 @@ find :: String -> String -> String find r x = let lst = lines x val = filter (r `isPrefixOf`) lst - in if null val - then [] - else case break (=='=') (head val) of + in case val of + [] -> [] + x:_ -> case break (=='=') x of (_ , []) -> [] (_, (_:xs)) -> xs diff --git a/GHC/Linker/MacOS.hs b/GHC/Linker/MacOS.hs --- a/GHC/Linker/MacOS.hs +++ b/GHC/Linker/MacOS.hs @@ -9,12 +9,15 @@ import GHC.Prelude import GHC.Platform +import GHC.Linker.Config + import GHC.Driver.Session import GHC.Unit.Types import GHC.Unit.State import GHC.Unit.Env +import GHC.Settings import GHC.SysTools.Tasks import GHC.Runtime.Interpreter @@ -36,7 +39,7 @@ -- macOS Sierra (10.14). -- -- @-dead_strip_dylibs@ does not dead strip @-rpath@ entries, as such passing --- @-l@ and @-rpath@ to the linker will result in the unnecesasry libraries not +-- @-l@ and @-rpath@ to the linker will result in the unnecessary libraries not -- being included in the load commands, however the @-rpath@ entries are all -- forced to be included. This can lead to 100s of @-rpath@ entries being -- included when only a handful of libraries end up being truly linked. @@ -46,15 +49,13 @@ -- dynamic library through @-add_rpath@. -- -- See Note [Dynamic linking on macOS] -runInjectRPaths :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO () --- Make sure to honour -fno-use-rpaths if set on darwin as well see #20004 -runInjectRPaths _ dflags _ _ | not (gopt Opt_RPath dflags) = return () -runInjectRPaths logger dflags lib_paths dylib = do - info <- lines <$> askOtool logger dflags Nothing [Option "-L", Option dylib] +runInjectRPaths :: Logger -> ToolSettings -> [FilePath] -> FilePath -> IO () +runInjectRPaths logger toolSettings lib_paths dylib = do + info <- lines <$> askOtool logger toolSettings Nothing [Option "-L", Option dylib] -- filter the output for only the libraries. And then drop the @rpath prefix. let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info -- find any pre-existing LC_PATH items - info <- lines <$> askOtool logger dflags Nothing [Option "-l", Option dylib] + info <- lines <$> askOtool logger toolSettings Nothing [Option "-l", Option dylib] let paths = mapMaybe get_rpath info lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ] -- only find those rpaths, that aren't already in the library. @@ -62,7 +63,7 @@ -- inject the rpaths case rpaths of [] -> return () - _ -> runInstallNameTool logger dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] + _ -> runInstallNameTool logger toolSettings $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] get_rpath :: String -> Maybe FilePath get_rpath l = case readP_to_S rpath_parser l of @@ -96,15 +97,15 @@ | otherwise = return [] -getFrameworkOpts :: DynFlags -> Platform -> [String] -getFrameworkOpts dflags platform +getFrameworkOpts :: FrameworkOpts -> Platform -> [String] +getFrameworkOpts fwOpts platform | platformUsesFrameworks platform = framework_path_opts ++ framework_opts | otherwise = [] where - framework_paths = frameworkPaths dflags + framework_paths = foFrameworkPaths fwOpts framework_path_opts = map ("-F" ++) framework_paths - frameworks = cmdlineFrameworks dflags + frameworks = foCmdlineFrameworks fwOpts -- reverse because they're added in reverse order from the cmd line: framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ] diff --git a/GHC/Linker/Static.hs b/GHC/Linker/Static.hs --- a/GHC/Linker/Static.hs +++ b/GHC/Linker/Static.hs @@ -1,6 +1,5 @@ module GHC.Linker.Static ( linkBinary - , linkBinary' , linkStaticLib ) where @@ -30,6 +29,7 @@ import GHC.Linker.Windows import GHC.Linker.Static.Utils +import GHC.Driver.Config.Linker import GHC.Driver.Session import System.FilePath @@ -73,23 +73,26 @@ unit_state = ue_units unit_env toolSettings' = toolSettings dflags verbFlags = getVerbFlags dflags - output_fn = exeFileName platform staticLink (outputFile_ dflags) - - -- get the full list of packages to link with, by combining the - -- explicit packages with the auto packages and all of their - -- dependencies, and eliminating duplicates. + arch_os = platformArchOS platform + output_fn = exeFileName arch_os staticLink (outputFile_ dflags) + namever = ghcNameVersion dflags + ways_ = ways dflags full_output_fn <- if isAbsolute output_fn then return output_fn else do d <- getCurrentDirectory return $ normalise (d output_fn) + + -- get the full list of packages to link with, by combining the + -- explicit packages with the auto packages and all of their + -- dependencies, and eliminating duplicates. pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units) - let pkg_lib_paths = collectLibraryDirs (ways dflags) pkgs + let pkg_lib_paths = collectLibraryDirs ways_ pkgs let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths get_pkg_lib_path_opts l | osElfTarget (platformOS platform) && dynLibLoader dflags == SystemDependent && - ways dflags `hasWay` WayDyn + ways_ `hasWay` WayDyn = let libpath = if gopt Opt_RelativeDynlibPaths dflags then "$ORIGIN" (l `makeRelativeTo` full_output_fn) @@ -110,7 +113,7 @@ in ["-L" ++ l] ++ rpathlink ++ rpath | osMachOTarget (platformOS platform) && dynLibLoader dflags == SystemDependent && - ways dflags `hasWay` WayDyn && + ways_ `hasWay` WayDyn && useXLinkerRPath dflags (platformOS platform) = let libpath = if gopt Opt_RelativeDynlibPaths dflags then "@loader_path" @@ -122,7 +125,7 @@ pkg_lib_path_opts <- if gopt Opt_SingleLibFolder dflags then do - libs <- getLibs dflags unit_env dep_units + libs <- getLibs namever ways_ unit_env dep_units tmpDir <- newTempDir logger tmpfs (tmpDir dflags) sequence_ [ copyFile lib (tmpDir basename) | (lib, basename) <- libs] @@ -152,14 +155,8 @@ = ([],[]) pkg_link_opts <- do - (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags unit_env dep_units - return $ if staticLink - then package_hs_libs -- If building an executable really means making a static - -- library (e.g. iOS), then we only keep the -l options for - -- HS packages, because libtool doesn't accept other options. - -- In the case of iOS these need to be added by hand to the - -- final link in Xcode. - else other_flags ++ dead_strip + (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 -- -Wl,-u, contained in other_flags @@ -175,7 +172,7 @@ -- frameworks pkg_framework_opts <- getUnitFrameworkOpts unit_env dep_units - let framework_opts = getFrameworkOpts dflags platform + let framework_opts = getFrameworkOpts (initFrameworkOpts dflags) platform -- probably _stub.o files let extra_ld_inputs = ldInputs dflags @@ -184,11 +181,12 @@ OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger tmpfs dflags output_fn _ -> return [] - let link dflags args | staticLink = GHC.SysTools.runLibtool logger dflags args - | platformOS platform == OSDarwin + let link dflags args | platformOS platform == OSDarwin = do GHC.SysTools.runLink logger tmpfs dflags args - GHC.Linker.MacOS.runInjectRPaths logger dflags pkg_lib_paths output_fn + -- 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 @@ -220,7 +218,6 @@ -- on x86. ++ (if not (gopt Opt_CompactUnwind dflags) && toolSettings_ldSupportsCompactUnwind toolSettings' && - not staticLink && (platformOS platform == OSDarwin) && case platformArch platform of ArchX86 -> True @@ -238,8 +235,7 @@ -- whether this is something we ought to fix, but -- for now this flags silences them. ++ (if platformOS platform == OSDarwin && - platformArch platform == ArchX86 && - not staticLink + platformArch platform == ArchX86 then ["-Wl,-read_only_relocs,suppress"] else []) @@ -278,7 +274,10 @@ let platform = ue_platform unit_env extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] modules = o_files ++ extra_ld_inputs - output_fn = exeFileName platform True (outputFile_ dflags) + arch_os = platformArchOS platform + output_fn = exeFileName arch_os True (outputFile_ dflags) + namever = ghcNameVersion dflags + ways_ = ways dflags full_output_fn <- if isAbsolute output_fn then return output_fn @@ -295,7 +294,7 @@ | otherwise = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init - archives <- concatMapM (collectArchives dflags) pkg_cfgs + archives <- concatMapM (collectArchives namever ways_) pkg_cfgs ar <- foldl mappend <$> (Archive <$> mapM loadObj modules) diff --git a/GHC/Linker/Static/Utils.hs b/GHC/Linker/Static/Utils.hs --- a/GHC/Linker/Static/Utils.hs +++ b/GHC/Linker/Static/Utils.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiWayIf #-} + module GHC.Linker.Static.Utils where import GHC.Prelude @@ -12,20 +14,18 @@ -- Use the provided filename (if any), otherwise use "main.exe" (Windows), -- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the -- extension if it is missing. -exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath -exeFileName platform staticLink output_fn - | Just s <- output_fn = - case platformOS platform of - OSMinGW32 -> s "exe" - _ -> if staticLink - then s "a" - else s - | otherwise = - if platformOS platform == OSMinGW32 - then "main.exe" - else if staticLink - then "liba.a" - else "a.out" +exeFileName :: ArchOS -> Bool -> Maybe FilePath -> FilePath +exeFileName (ArchOS arch os) staticLink output_fn + | Just s <- output_fn = if + | OSMinGW32 <- os -> s "exe" + | ArchJavaScript <- arch -> s "jsexe" + | ArchWasm32 <- arch -> s "wasm" + | staticLink -> s "a" + | otherwise -> s + | otherwise = if + | OSMinGW32 <- os -> "main.exe" + | ArchJavaScript <- arch -> "main.jsexe" + | staticLink -> "liba.a" + | otherwise -> "a.out" where s ext | null (takeExtension s) = s <.> ext | otherwise = s - diff --git a/GHC/Linker/Types.hs b/GHC/Linker/Types.hs --- a/GHC/Linker/Types.hs +++ b/GHC/Linker/Types.hs @@ -5,7 +5,7 @@ -- (c) The University of Glasgow 2019 -- ----------------------------------------------------------------------------- - +{-# LANGUAGE TypeApplications #-} module GHC.Linker.Types ( Loader (..) , LoaderState (..) @@ -55,6 +55,7 @@ import GHC.Unit.Module.Env import GHC.Types.Unique.DSet import GHC.Types.Unique.DFM +import GHC.Unit.Module.WholeCoreBindings {- ********************************************************************** @@ -107,7 +108,7 @@ 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 @@ -192,6 +193,10 @@ = 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. | BCOs CompiledByteCode [SptEntry] -- ^ A byte-code object, lives only in memory. Also -- carries some static pointer table entries which @@ -204,6 +209,8 @@ 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" -- | An entry to be inserted into a module's static pointer table. -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". @@ -241,6 +248,8 @@ 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 -- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object @@ -248,8 +257,9 @@ nameOfObject o = fromMaybe (pprPanic "nameOfObject" (ppr o)) (nameOfObject_maybe o) -- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable -byteCodeOfObject :: Unlinked -> CompiledByteCode -byteCodeOfObject (BCOs bc _) = bc +byteCodeOfObject :: Unlinked -> [CompiledByteCode] +byteCodeOfObject (BCOs bc _) = [bc] +byteCodeOfObject (LoadedBCOs ul) = concatMap byteCodeOfObject ul byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) {- ********************************************************************** @@ -280,7 +290,7 @@ | Framework String -- Only used for darwin, but does no harm instance Outputable LibrarySpec where - ppr (Objects objs) = text "Objects" <+> ppr objs + ppr (Objects objs) = text "Objects" <+> ppr (map (text @SDoc) objs) ppr (Archive a) = text "Archive" <+> text a ppr (DLL s) = text "DLL" <+> text s ppr (DLLPath f) = text "DLLPath" <+> text f diff --git a/GHC/Linker/Unit.hs b/GHC/Linker/Unit.hs --- a/GHC/Linker/Unit.hs +++ b/GHC/Linker/Unit.hs @@ -18,7 +18,7 @@ import qualified GHC.Data.ShortText as ST -import GHC.Driver.Session +import GHC.Settings import Control.Monad import System.Directory @@ -26,26 +26,26 @@ -- | Find all the link options in these and the preload packages, -- returning (package hs lib options, extra library options, other flags) -getUnitLinkOpts :: DynFlags -> UnitEnv -> [UnitId] -> IO ([String], [String], [String]) -getUnitLinkOpts dflags unit_env pkgs = do +getUnitLinkOpts :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO ([String], [String], [String]) +getUnitLinkOpts namever ways unit_env pkgs = do ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs - return (collectLinkOpts dflags ps) + return (collectLinkOpts namever ways ps) -collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String]) -collectLinkOpts dflags ps = +collectLinkOpts :: GhcNameVersion -> Ways -> [UnitInfo] -> ([String], [String], [String]) +collectLinkOpts namever ways ps = ( - concatMap (map ("-l" ++) . unitHsLibs (ghcNameVersion dflags) (ways dflags)) ps, + concatMap (map ("-l" ++) . unitHsLibs namever ways) ps, concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps, concatMap (map ST.unpack . unitLinkerOptions) ps ) -collectArchives :: DynFlags -> UnitInfo -> IO [FilePath] -collectArchives dflags pc = +collectArchives :: GhcNameVersion -> Ways -> UnitInfo -> IO [FilePath] +collectArchives namever ways pc = filterM doesFileExist [ searchPath ("lib" ++ lib ++ ".a") | searchPath <- searchPaths , lib <- libs ] - where searchPaths = ordNub . filter notNull . libraryDirsForWay (ways dflags) $ pc - libs = unitHsLibs (ghcNameVersion dflags) (ways dflags) pc ++ map ST.unpack (unitExtDepLibsSys pc) + where searchPaths = ordNub . filter notNull . libraryDirsForWay ways $ pc + libs = unitHsLibs namever ways pc ++ map ST.unpack (unitExtDepLibsSys pc) -- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. libraryDirsForWay :: Ways -> UnitInfo -> [String] @@ -53,11 +53,11 @@ | hasWay ws WayDyn = map ST.unpack . unitLibraryDynDirs | otherwise = map ST.unpack . unitLibraryDirs -getLibs :: DynFlags -> UnitEnv -> [UnitId] -> IO [(String,String)] -getLibs dflags unit_env pkgs = do +getLibs :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO [(String,String)] +getLibs namever ways unit_env pkgs = do ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs fmap concat . forM ps $ \p -> do - let candidates = [ (l f, f) | l <- collectLibraryDirs (ways dflags) [p] - , f <- (\n -> "lib" ++ n ++ ".a") <$> unitHsLibs (ghcNameVersion dflags) (ways dflags) p ] + let candidates = [ (l f, f) | l <- collectLibraryDirs ways [p] + , f <- (\n -> "lib" ++ n ++ ".a") <$> unitHsLibs namever ways p ] filterM (doesFileExist . fst) candidates diff --git a/GHC/Llvm/Ppr.hs b/GHC/Llvm/Ppr.hs --- a/GHC/Llvm/Ppr.hs +++ b/GHC/Llvm/Ppr.hs @@ -517,8 +517,8 @@ ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc ppPlainName opts v = case v of (LMGlobalVar x _ _ _ _ _) -> ftext x - (LMLocalVar x LMLabel ) -> text (show x) - (LMLocalVar x _ ) -> text ('l' : show x) + (LMLocalVar x LMLabel ) -> pprUniqueAlways x + (LMLocalVar x _ ) -> char 'l' <> pprUniqueAlways x (LMNLocalVar x _ ) -> ftext x (LMLitVar x ) -> ppLit opts x diff --git a/GHC/Llvm/Types.hs b/GHC/Llvm/Types.hs --- a/GHC/Llvm/Types.hs +++ b/GHC/Llvm/Types.hs @@ -181,7 +181,7 @@ getLitType (LMIntLit _ t) = t getLitType (LMFloatLit _ t) = t getLitType (LMVectorLit []) = panic "getLitType" -getLitType (LMVectorLit ls) = LMVector (length ls) (getLitType (head ls)) +getLitType (LMVectorLit ls@(l:_)) = LMVector (length ls) (getLitType l) getLitType (LMNullLit t) = t getLitType (LMUndefLit t) = t diff --git a/GHC/Parser.hs b/GHC/Parser.hs --- a/GHC/Parser.hs +++ b/GHC/Parser.hs @@ -8,12919 +8,12969 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} - --- | 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, mkVarOcc, occNameString) -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 ( unrestrictedFunTyCon, 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) - -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) -happyIn34 :: (Located HsModule) -> (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) -happyIn35 :: (Located HsModule) -> (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)) -happyIn39 :: ((AnnList - ,([LImportDecl GhcPs], [LHsDecl GhcPs]) - ,LayoutInfo)) -> (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)) -happyIn40 :: ((AnnList - ,([LImportDecl GhcPs], [LHsDecl GhcPs]) - ,LayoutInfo)) -> (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) -happyIn43 :: (Located HsModule) -> (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 (Bool, LocatedL [LIE GhcPs]))) -happyIn68 :: (Located (Maybe (Bool, 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 (Bool, LocatedL [LIE GhcPs])) -happyIn69 :: (Located (Bool, 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, NewOrData)) -happyIn99 :: (Located (AddEpAnn, 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], Maybe (LHsKind GhcPs))) -happyIn100 :: (Located ([AddEpAnn], Maybe (LHsKind 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 (Located ([AddEpAnn], LFamilyResultSig GhcPs)) -happyIn101 :: (Located ([AddEpAnn], LFamilyResultSig 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 - , Maybe (LInjectivityAnn GhcPs)))) -happyIn103 :: (Located ([AddEpAnn], ( LFamilyResultSig GhcPs - , Maybe (LInjectivityAnn 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 (Maybe (LHsContext GhcPs), LHsType GhcPs)) -happyIn104 :: (Located (Maybe (LHsContext GhcPs), LHsType 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), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs)) -happyIn105 :: (Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs 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 (Maybe (LocatedP CType)) -happyIn106 :: (Maybe (LocatedP CType)) -> (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 (LDerivDecl GhcPs) -happyIn107 :: (LDerivDecl 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 (LRoleAnnotDecl GhcPs) -happyIn108 :: (LRoleAnnotDecl 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 [Located (Maybe FastString)]) -happyIn109 :: (Located [Located (Maybe FastString)]) -> (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 (Maybe FastString)) -happyIn111 :: (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 (LHsDecl GhcPs) -happyIn112 :: (LHsDecl 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 ((LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn])) -happyIn113 :: ((LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn])) -> (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]) -happyIn114 :: ([LocatedN RdrName]) -> (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 ([RecordPatSynField GhcPs]) -happyIn115 :: ([RecordPatSynField 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 (LocatedL (OrdList (LHsDecl GhcPs))) -happyIn116 :: (LocatedL (OrdList (LHsDecl 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 (LSig GhcPs) -happyIn117 :: (LSig GhcPs) -> (HappyAbsSyn ) -happyIn117 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap117 x) -{-# INLINE happyIn117 #-} -happyOut117 :: (HappyAbsSyn ) -> HappyWrap117 -happyOut117 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut117 #-} -newtype HappyWrap118 = HappyWrap118 (LocatedN RdrName) -happyIn118 :: (LocatedN RdrName) -> (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 (Located ([AddEpAnn],OrdList (LHsDecl GhcPs))) -happyIn120 :: (Located ([AddEpAnn],OrdList (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) - , LayoutInfo)) -happyIn121 :: (Located ([AddEpAnn] - , OrdList (LHsDecl GhcPs) - , LayoutInfo)) -> (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)) -- Reversed - ,LayoutInfo)) -happyIn122 :: (Located ([AddEpAnn] - ,(OrdList (LHsDecl GhcPs)) -- Reversed - ,LayoutInfo)) -> (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 (OrdList (LHsDecl GhcPs))) -happyIn123 :: (Located (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 (Located ([AddEpAnn],OrdList (LHsDecl GhcPs))) -happyIn124 :: (Located ([AddEpAnn],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 ([TrailingAnn], OrdList (LHsDecl GhcPs))) -happyIn127 :: (Located ([TrailingAnn], 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 (AnnList,Located (OrdList (LHsDecl GhcPs)))) -happyIn128 :: (Located (AnnList,Located (OrdList (LHsDecl GhcPs)))) -> (HappyAbsSyn ) -happyIn128 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap128 x) -{-# INLINE happyIn128 #-} -happyOut128 :: (HappyAbsSyn ) -> HappyWrap128 -happyOut128 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut128 #-} -newtype HappyWrap129 = HappyWrap129 (Located (HsLocalBinds GhcPs)) -happyIn129 :: (Located (HsLocalBinds 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 (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments ))) -happyIn130 :: (Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments ))) -> (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 ([LRuleDecl GhcPs]) -happyIn131 :: ([LRuleDecl 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 (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 (([AddEpAnn],Maybe Activation)) -happyIn133 :: (([AddEpAnn],Maybe Activation)) -> (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]) -happyIn134 :: ([AddEpAnn]) -> (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] - ,Activation)) -happyIn135 :: (([AddEpAnn] - ,Activation)) -> (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] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs])) -happyIn136 :: (([AddEpAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr 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 ([LRuleTyTmVar]) -happyIn137 :: ([LRuleTyTmVar]) -> (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 (OrdList (LWarnDecl GhcPs)) -happyIn139 :: (OrdList (LWarnDecl 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 (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 (Located ([AddEpAnn],[Located StringLiteral])) -happyIn143 :: (Located ([AddEpAnn],[Located StringLiteral])) -> (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 (OrdList (Located StringLiteral))) -happyIn144 :: (Located (OrdList (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 (LHsDecl GhcPs) -happyIn145 :: (LHsDecl GhcPs) -> (HappyAbsSyn ) -happyIn145 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap145 x) -{-# INLINE happyIn145 #-} -happyOut145 :: (HappyAbsSyn ) -> HappyWrap145 -happyOut145 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut145 #-} -newtype HappyWrap146 = HappyWrap146 (Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl GhcPs)) -happyIn146 :: (Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl 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 CCallConv) -happyIn147 :: (Located CCallConv) -> (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 Safety) -happyIn148 :: (Located Safety) -> (HappyAbsSyn ) -happyIn148 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap148 x) -{-# INLINE happyIn148 #-} -happyOut148 :: (HappyAbsSyn ) -> HappyWrap148 -happyOut148 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut148 #-} -newtype HappyWrap149 = HappyWrap149 (Located ([AddEpAnn] - ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs))) -happyIn149 :: (Located ([AddEpAnn] - ,(Located StringLiteral, LocatedN RdrName, LHsSigType 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 (Maybe (AddEpAnn, LHsType GhcPs)) -happyIn150 :: (Maybe (AddEpAnn, LHsType 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 (([AddEpAnn], Maybe (LocatedN RdrName))) -happyIn151 :: (([AddEpAnn], Maybe (LocatedN RdrName))) -> (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 (LHsSigType GhcPs) -happyIn152 :: (LHsSigType 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 (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 (Located [LocatedN RdrName]) -happyIn154 :: (Located [LocatedN RdrName]) -> (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 (OrdList (LHsSigType GhcPs)) -happyIn155 :: (OrdList (LHsSigType GhcPs)) -> (HappyAbsSyn ) -happyIn155 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap155 x) -{-# INLINE happyIn155 #-} -happyOut155 :: (HappyAbsSyn ) -> HappyWrap155 -happyOut155 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut155 #-} -newtype HappyWrap156 = HappyWrap156 (Located UnpackednessPragma) -happyIn156 :: (Located UnpackednessPragma) -> (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 (HsForAllTelescope GhcPs)) -happyIn157 :: (Located (HsForAllTelescope GhcPs)) -> (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 (LHsType GhcPs) -happyIn158 :: (LHsType 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 (LHsContext GhcPs) -happyIn160 :: (LHsContext 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 (LHsType GhcPs) -happyIn161 :: (LHsType GhcPs) -> (HappyAbsSyn ) -happyIn161 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap161 x) -{-# INLINE happyIn161 #-} -happyOut161 :: (HappyAbsSyn ) -> HappyWrap161 -happyOut161 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut161 #-} -newtype HappyWrap162 = HappyWrap162 (Located (LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs)) -happyIn162 :: (Located (LHsUniToken "->" "\8594" GhcPs -> HsArrow 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 (LHsType GhcPs) -happyIn163 :: (LHsType 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 (forall b. DisambTD b => PV (LocatedA b)) -happyIn164 :: (forall b. DisambTD b => PV (LocatedA b)) -> (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 (LHsType GhcPs) -happyIn166 :: (LHsType GhcPs) -> (HappyAbsSyn ) -happyIn166 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap166 x) -{-# INLINE happyIn166 #-} -happyOut166 :: (HappyAbsSyn ) -> HappyWrap166 -happyOut166 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut166 #-} -newtype HappyWrap167 = HappyWrap167 ((LocatedN RdrName, PromotionFlag)) -happyIn167 :: ((LocatedN RdrName, PromotionFlag)) -> (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 (LHsSigType GhcPs) -happyIn169 :: (LHsSigType 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 ([LHsType GhcPs]) -happyIn171 :: ([LHsType 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 ([LHsTyVarBndr Specificity GhcPs]) -happyIn174 :: ([LHsTyVarBndr Specificity 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 (Located ([AddEpAnn],[LHsFunDep GhcPs])) -happyIn177 :: (Located ([AddEpAnn],[LHsFunDep 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 [LHsFunDep GhcPs]) -happyIn178 :: (Located [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 (LHsFunDep GhcPs) -happyIn179 :: (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 (Located [LocatedN RdrName]) -happyIn180 :: (Located [LocatedN RdrName]) -> (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 (LHsKind GhcPs) -happyIn181 :: (LHsKind 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 (Located ([AddEpAnn] - ,[LConDecl GhcPs])) -happyIn182 :: (Located ([AddEpAnn] - ,[LConDecl 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 [LConDecl GhcPs]) -happyIn183 :: (Located [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 (LConDecl GhcPs) -happyIn184 :: (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 (Located ([AddEpAnn],[LConDecl GhcPs])) -happyIn185 :: (Located ([AddEpAnn],[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 [LConDecl GhcPs]) -happyIn186 :: (Located [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 (LConDecl GhcPs) -happyIn187 :: (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 (Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs])) -happyIn188 :: (Located ([AddEpAnn], Maybe [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 (LocatedN RdrName, HsConDeclH98Details GhcPs)) -happyIn189 :: (Located (LocatedN RdrName, HsConDeclH98Details 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 ([LConDeclField GhcPs]) -happyIn190 :: ([LConDeclField 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 (Located (HsDeriving GhcPs)) -happyIn193 :: (Located (HsDeriving 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 (LHsDerivingClause GhcPs) -happyIn195 :: (LHsDerivingClause 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 (LDerivClauseTys GhcPs) -happyIn196 :: (LDerivClauseTys 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 (LHsDecl GhcPs) -happyIn197 :: (LHsDecl 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 (Located (GRHSs GhcPs (LHsExpr GhcPs))) -happyIn199 :: (Located (GRHSs GhcPs (LHsExpr 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 [LGRHS GhcPs (LHsExpr GhcPs)]) -happyIn200 :: (Located [LGRHS 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 (LGRHS GhcPs (LHsExpr GhcPs)) -happyIn201 :: (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 (LHsDecl GhcPs) -happyIn202 :: (LHsDecl 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 (([AddEpAnn],Maybe Activation)) -happyIn203 :: (([AddEpAnn],Maybe Activation)) -> (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],Activation)) -happyIn204 :: (([AddEpAnn],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 (Located (HsSplice GhcPs)) -happyIn205 :: (Located (HsSplice 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 (ECP) -happyIn206 :: (ECP) -> (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 ((Maybe EpaLocation,Bool)) -happyIn210 :: ((Maybe EpaLocation,Bool)) -> (HappyAbsSyn ) -happyIn210 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap210 x) -{-# INLINE happyIn210 #-} -happyOut210 :: (HappyAbsSyn ) -> HappyWrap210 -happyOut210 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut210 #-} -newtype HappyWrap211 = HappyWrap211 (Located (HsPragE GhcPs)) -happyIn211 :: (Located (HsPragE GhcPs)) -> (HappyAbsSyn ) -happyIn211 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap211 x) -{-# INLINE happyIn211 #-} -happyOut211 :: (HappyAbsSyn ) -> HappyWrap211 -happyOut211 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut211 #-} -newtype HappyWrap212 = HappyWrap212 (ECP) -happyIn212 :: (ECP) -> (HappyAbsSyn ) -happyIn212 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap212 x) -{-# INLINE happyIn212 #-} -happyOut212 :: (HappyAbsSyn ) -> HappyWrap212 -happyOut212 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut212 #-} -newtype HappyWrap213 = HappyWrap213 (ECP) -happyIn213 :: (ECP) -> (HappyAbsSyn ) -happyIn213 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap213 x) -{-# INLINE happyIn213 #-} -happyOut213 :: (HappyAbsSyn ) -> HappyWrap213 -happyOut213 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut213 #-} -newtype HappyWrap214 = HappyWrap214 (ECP) -happyIn214 :: (ECP) -> (HappyAbsSyn ) -happyIn214 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap214 x) -{-# INLINE happyIn214 #-} -happyOut214 :: (HappyAbsSyn ) -> HappyWrap214 -happyOut214 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut214 #-} -newtype HappyWrap215 = HappyWrap215 (ECP) -happyIn215 :: (ECP) -> (HappyAbsSyn ) -happyIn215 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap215 x) -{-# INLINE happyIn215 #-} -happyOut215 :: (HappyAbsSyn ) -> HappyWrap215 -happyOut215 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut215 #-} -newtype HappyWrap216 = HappyWrap216 (Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)))) -happyIn216 :: (Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc 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 (LHsExpr GhcPs) -happyIn217 :: (LHsExpr 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 (Located (HsSplice GhcPs)) -happyIn218 :: (Located (HsSplice 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 (HsSplice GhcPs)) -happyIn219 :: (Located (HsSplice 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 ([LHsCmdTop GhcPs]) -happyIn220 :: ([LHsCmdTop 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 (([AddEpAnn],[LHsDecl GhcPs])) -happyIn222 :: (([AddEpAnn],[LHsDecl 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 ([LHsDecl GhcPs]) -happyIn223 :: ([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 (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 (forall b. DisambECP b => PV (SumOrTuple b)) -happyIn225 :: (forall b. DisambECP b => PV (SumOrTuple b)) -> (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 (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)])) -happyIn226 :: (forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA 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 [Either (EpAnn EpaLocation) (LocatedA b)]) -happyIn227 :: (forall b. DisambECP b => PV [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 => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (LocatedA b)) -happyIn228 :: (forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (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 => PV [LocatedA b]) -happyIn229 :: (forall b. DisambECP b => 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 (Located [LStmt GhcPs (LHsExpr GhcPs)]) -happyIn230 :: (Located [LStmt GhcPs (LHsExpr GhcPs)]) -> (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 (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs))) -happyIn233 :: (Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt 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 [LStmt GhcPs (LHsExpr GhcPs)]) -happyIn234 :: (Located [LStmt 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 (forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b)))) -happyIn236 :: (forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b)))) -> (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 [LGRHS GhcPs (LocatedA b)])) -happyIn237 :: (forall b. DisambECP b => PV (Located [LGRHS 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 (Located ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)])) -happyIn239 :: (Located ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)])) -> (HappyAbsSyn ) -happyIn239 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap239 x) -{-# INLINE happyIn239 #-} -happyOut239 :: (HappyAbsSyn ) -> HappyWrap239 -happyOut239 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut239 #-} -newtype HappyWrap240 = HappyWrap240 (forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b))) -happyIn240 :: (forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b))) -> (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 (LPat GhcPs) -happyIn241 :: (LPat GhcPs) -> (HappyAbsSyn ) -happyIn241 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap241 x) -{-# INLINE happyIn241 #-} -happyOut241 :: (HappyAbsSyn ) -> HappyWrap241 -happyOut241 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut241 #-} -newtype HappyWrap242 = HappyWrap242 ([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 (forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))])) -happyIn246 :: (forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))])) -> (HappyAbsSyn ) -happyIn246 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap246 x) -{-# INLINE happyIn246 #-} -happyOut246 :: (HappyAbsSyn ) -> HappyWrap246 -happyOut246 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut246 #-} -newtype HappyWrap247 = HappyWrap247 (forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)]))) -happyIn247 :: (forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt 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 (Maybe (LStmt GhcPs (LHsExpr GhcPs))) -happyIn248 :: (Maybe (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 (LStmt GhcPs (LHsExpr GhcPs)) -happyIn249 :: (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 (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -happyIn250 :: (forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b))) -> (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 ([Fbind b], Maybe SrcSpan)) -happyIn252 :: (forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan)) -> (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)) -happyIn254 :: (forall b. DisambECP b => PV (Fbind 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 (Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]) -happyIn255 :: (Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]) -> (HappyAbsSyn ) -happyIn255 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap255 x) -{-# INLINE happyIn255 #-} -happyOut255 :: (HappyAbsSyn ) -> HappyWrap255 -happyOut255 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut255 #-} -newtype HappyWrap256 = HappyWrap256 (Located [LIPBind GhcPs]) -happyIn256 :: (Located [LIPBind 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 (LIPBind GhcPs) -happyIn257 :: (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 (Located HsIPName) -happyIn258 :: (Located HsIPName) -> (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 FastString) -happyIn259 :: (Located FastString) -> (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 (LBooleanFormula (LocatedN RdrName)) -happyIn260 :: (LBooleanFormula (LocatedN RdrName)) -> (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 (Located [LocatedN RdrName]) -happyIn265 :: (Located [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 (LocatedN RdrName) -happyIn266 :: (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 (Located [LocatedN RdrName]) -happyIn271 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) -happyIn271 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap271 x) -{-# INLINE happyIn271 #-} -happyOut271 :: (HappyAbsSyn ) -> HappyWrap271 -happyOut271 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut271 #-} -newtype HappyWrap272 = HappyWrap272 (Located [LocatedN RdrName]) -happyIn272 :: (Located [LocatedN RdrName]) -> (HappyAbsSyn ) -happyIn272 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap272 x) -{-# INLINE happyIn272 #-} -happyOut272 :: (HappyAbsSyn ) -> HappyWrap272 -happyOut272 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut272 #-} -newtype HappyWrap273 = HappyWrap273 (LocatedN DataCon) -happyIn273 :: (LocatedN DataCon) -> (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 RdrName) -happyIn275 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn275 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap275 x) -{-# INLINE happyIn275 #-} -happyOut275 :: (HappyAbsSyn ) -> HappyWrap275 -happyOut275 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut275 #-} -newtype HappyWrap276 = HappyWrap276 (LocatedN RdrName) -happyIn276 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn276 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap276 x) -{-# INLINE happyIn276 #-} -happyOut276 :: (HappyAbsSyn ) -> HappyWrap276 -happyOut276 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut276 #-} -newtype HappyWrap277 = HappyWrap277 (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 (forall b. DisambInfixOp b => PV (LocatedN b)) -happyIn289 :: (forall b. DisambInfixOp b => PV (LocatedN b)) -> (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 (Located b)) -happyIn291 :: (forall b. DisambInfixOp b => PV (Located 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 (LocatedN RdrName) -happyIn292 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn292 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap292 x) -{-# INLINE happyIn292 #-} -happyOut292 :: (HappyAbsSyn ) -> HappyWrap292 -happyOut292 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut292 #-} -newtype HappyWrap293 = HappyWrap293 (LocatedN RdrName) -happyIn293 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn293 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap293 x) -{-# INLINE happyIn293 #-} -happyOut293 :: (HappyAbsSyn ) -> HappyWrap293 -happyOut293 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut293 #-} -newtype HappyWrap294 = HappyWrap294 (LocatedN RdrName) -happyIn294 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn294 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap294 x) -{-# INLINE happyIn294 #-} -happyOut294 :: (HappyAbsSyn ) -> HappyWrap294 -happyOut294 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut294 #-} -newtype HappyWrap295 = HappyWrap295 (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 (Located FastString) -happyIn299 :: (Located FastString) -> (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 (Located FastString) -happyIn307 :: (Located FastString) -> (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 (LocatedN RdrName) -happyIn309 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn309 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap309 x) -{-# INLINE happyIn309 #-} -happyOut309 :: (HappyAbsSyn ) -> HappyWrap309 -happyOut309 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut309 #-} -newtype HappyWrap310 = HappyWrap310 (LocatedN RdrName) -happyIn310 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn310 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap310 x) -{-# INLINE happyIn310 #-} -happyOut310 :: (HappyAbsSyn ) -> HappyWrap310 -happyOut310 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut310 #-} -newtype HappyWrap311 = HappyWrap311 (LocatedN RdrName) -happyIn311 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn311 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap311 x) -{-# INLINE happyIn311 #-} -happyOut311 :: (HappyAbsSyn ) -> HappyWrap311 -happyOut311 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut311 #-} -newtype HappyWrap312 = HappyWrap312 (LocatedN RdrName) -happyIn312 :: (LocatedN RdrName) -> (HappyAbsSyn ) -happyIn312 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap312 x) -{-# INLINE happyIn312 #-} -happyOut312 :: (HappyAbsSyn ) -> HappyWrap312 -happyOut312 x = Happy_GHC_Exts.unsafeCoerce# x -{-# INLINE happyOut312 #-} -newtype HappyWrap313 = HappyWrap313 (Located (HsLit GhcPs)) -happyIn313 :: (Located (HsLit GhcPs)) -> (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 (()) -happyIn314 :: (()) -> (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 (LocatedA ModuleName) -happyIn315 :: (LocatedA ModuleName) -> (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 (([SrcSpan],Int)) -happyIn316 :: (([SrcSpan],Int)) -> (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 (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)])) -happyIn319 :: (forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)])) -> (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 (ECP) -happyIn321 :: (ECP) -> (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 (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -happyIn323 :: (forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)]))) -> (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 (LMatch GhcPs (LocatedA b))) -happyIn327 :: (forall b. DisambECP b => PV (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 #-} -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\x02\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x0c\x44\xf4\xff\x8f\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\x7f\xf3\x55\xff\xff\xf2\xff\x9e\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\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\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\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\x07\x03\x11\xfd\xff\xe3\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\x40\x00\x44\xff\x9f\xf0\x03\x00\x80\x80\x88\x10\xa0\x82\xfe\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x04\x00\x00\x00\x00\x00\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\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x06\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\x30\x10\x00\xc1\xcf\x27\xfc\x00\x06\x20\x00\x2e\xa4\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x10\xfc\x7c\xc2\x0f\x00\x00\x00\x00\x00\x08\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc0\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\xb0\x00\xa2\x02\x47\xe0\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\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\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\x80\x00\xb8\x10\xe2\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\x30\x10\x00\xd1\xcf\x27\xfc\x00\x06\x20\x20\x2e\x84\xe8\xf0\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\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\x02\x01\x10\xfc\x7c\xc2\x0f\x00\x00\x00\x00\x00\x00\x00\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\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x80\x00\x88\x10\xa0\x82\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x0a\x67\xf8\xff\xd7\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x02\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x88\x1f\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\x01\x82\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\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\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x00\x09\x1e\x80\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\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\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\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\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\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\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\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x70\xc0\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\xc0\xc1\x40\x44\xff\xbf\xf8\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\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\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\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\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\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x04\xf8\x10\xe0\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\x70\x30\x10\xd1\xff\x2f\xfe\x40\x00\x20\x09\x3e\x0c\xe8\xf2\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x48\x82\x0f\x01\xea\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\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\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\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\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\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\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\x07\x03\x11\xfd\xff\xe2\x0f\x00\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\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\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\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\x03\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\x80\x2a\x9c\xe1\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\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x02\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\x00\x00\x00\xa8\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\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\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x92\xe0\xc3\x80\x2e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\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\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\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\x0c\x04\x42\xf0\xff\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\x04\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\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\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\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\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\x80\x40\x80\x54\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\xa0\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc2\x0f\x00\x00\x10\xc0\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\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\x20\x00\x22\x04\x40\x10\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\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\x20\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x08\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\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\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\x00\x00\x80\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\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\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x41\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\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\xc0\x40\x00\x44\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\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\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\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x03\x01\x10\xfc\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\x87\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x30\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\x00\x00\x00\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\x0c\x04\x40\xf0\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x18\x80\xf8\x01\x00\x88\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x12\xe0\x43\x80\x2e\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\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\x1c\x0c\x44\xf4\xff\x8b\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x60\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x10\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x08\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\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x08\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\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\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\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\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\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\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\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\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\x80\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x02\x20\x42\x00\x00\x62\x06\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\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\x1c\x0c\x44\xf4\xff\x8f\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\x07\x03\x11\xfd\xff\xe3\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\x02\x20\x42\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xf3\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc2\x0f\x00\x00\x10\xc0\x01\x82\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\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\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\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\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\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x10\x00\xd1\xff\x27\xfc\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\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\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\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\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\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\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\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\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\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\x0c\x04\x40\xf4\xf3\x09\x3f\x80\x01\x08\x80\x0b\x21\x3a\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\x02\x01\x10\xfd\x7f\xc2\x0f\x00\x00\x00\x00\x00\x00\x00\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\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\x02\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x88\x10\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\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x00\x00\x00\x00\x2a\x60\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\x01\x10\xfc\x7c\xc2\x0f\x00\x00\x00\x00\x00\x08\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\x08\x04\x40\xf0\xf3\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x30\x10\x00\xc1\xcf\x27\xfc\x00\x00\x00\x00\x2c\x80\xa8\xc0\x11\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\x03\x01\x10\xfc\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\x87\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\x30\x10\x00\xc1\xcf\x27\xfc\x00\x00\x00\x00\x2c\x80\xa8\xc0\x11\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\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\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\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\x30\x10\x00\xc1\xcf\x27\xfc\x00\x00\x00\x00\x2c\x80\xa8\xc0\x11\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\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\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\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\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\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\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\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\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x08\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\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x48\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\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\xc0\xc1\x40\x44\xff\xbf\xf0\x03\x00\x00\x04\x70\x00\xb0\x2a\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\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x40\xaa\x72\xe6\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\x07\x03\x11\xfd\xff\xe2\x0f\x04\x00\x10\xe0\x01\xc0\xaa\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x70\x30\x10\xd3\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x01\x80\x04\xf8\x10\xa0\xca\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\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\x07\x03\x11\xfd\xff\xc2\x0f\x00\x00\x10\xc0\x01\x80\x6a\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\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\x40\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\xf3\x55\xff\xff\xf2\xff\x9e\x41\x10\xe0\x01\x80\x2a\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\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x2a\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x0a\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x80\x00\x08\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\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\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\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\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\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\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\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x02\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\x04\x00\x00\x00\x02\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x20\x10\x00\xd1\xff\x27\xfc\x00\x00\x00\x00\x00\x00\xa8\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\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\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\x02\x20\x40\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xcd\x57\xfd\xff\xcb\xff\x7b\x06\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\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\x40\x80\x54\xff\x9f\xf4\x03\x00\x00\x00\x00\x00\x80\x40\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xc1\x40\x44\xff\xbf\xf8\x03\x00\x00\x04\x78\x00\xa0\x0a\x67\xfe\xff\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\x20\x10\x00\xd1\xff\x27\xfc\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x20\x10\x00\xc1\xcf\x27\xfc\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\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\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\x80\x40\x00\x04\x3f\x9f\xf0\x03\x00\x00\x80\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\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\x20\x10\x00\xc1\xcf\x27\xfc\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x20\x22\x04\x00\x20\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8f\x3f\x10\x00\x40\x80\x07\x00\xaa\x70\xe6\xff\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\x10\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x8b\x3f\x10\x00\x40\x80\x07\x00\xaa\x72\xe6\xff\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\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\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x0c\x44\xf4\xff\x0b\x3f\x00\x00\x40\x00\x07\x00\xaa\x72\xe6\xff\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x08\x04\x40\xf4\xff\x09\x3f\x00\x00\x04\x00\x00\x00\x08\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x70\x30\x10\xd3\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\x1c\x0c\xc4\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\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\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x60\x00\x02\xe0\x42\x88\x0a\x7e\x87\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x10\x00\xc1\xcf\x27\xfc\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x10\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x08\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\xcc\x55\xf5\xff\xcb\xff\x13\x04\x41\x80\x07\x00\xaa\x70\xe6\xff\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x0c\x04\x40\xf0\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\xa0\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x22\x04\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\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\x01\x50\xfd\x7f\xc2\x0f\x00\x00\x01\x00\x00\x00\x02\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\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\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\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\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\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\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\x07\x73\x11\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x10\x00\xc1\xcf\x27\xfc\x00\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\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\xc0\x40\x20\x44\x7f\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x83\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x03\x01\x10\xfc\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\x87\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x80\x40\x00\x44\xff\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x80\x40\x00\x04\x07\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x06\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x80\x40\x00\x04\x07\x9f\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x06\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x03\x01\x10\xfc\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\x87\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\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\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x03\x01\x10\xfc\x7c\xc2\x0f\x60\x00\x02\xe0\x42\x88\x0a\x7e\x87\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\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\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\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\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x03\xe0\x42\x88\x0a\x7e\x87\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\xc0\x40\x00\x44\x3f\x9f\xf0\x03\x18\xc0\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\x20\x10\x00\xc1\xcf\x27\xfc\x00\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\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x50\xfd\x7f\xc2\x0f\x00\x00\x01\x00\x00\x00\x02\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\x10\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\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x87\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\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x0c\x04\x40\xf0\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\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\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\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\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\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\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x03\x01\x10\xfd\x7c\xc2\x0f\x60\x00\x02\xe2\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\x3f\x00\x00\x00\x00\x00\x00\x08\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xc0\x40\x00\x44\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x20\x10\x20\xd5\xff\x27\xfd\x00\x00\x00\x00\x00\x00\x20\x90\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\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\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x04\x40\xf0\xf3\x09\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x08\x04\x40\x70\xf0\x09\x3f\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\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\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\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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"# - -{-# 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","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.* 478 - bit_end = (st Prelude.+ 1) Prelude.* 478 - read_bit = readArrayBit happyExpList - bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1] - bits_indexed = Prelude.zip bits [0..477] - token_strs_expected = Prelude.concatMap f bits_indexed - f (Prelude.False, _) = [] - f (Prelude.True, nr) = [token_strs Prelude.!! nr] - -happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x46\x00\x37\x00\x67\x00\xbb\x29\xed\x1c\xa4\x2c\xa4\x2c\xe9\x23\xbb\x29\xa6\x48\x93\x3f\x54\x00\x41\x00\x1f\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\x52\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x02\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x2d\x03\x2d\x03\x00\x00\xa4\x00\x7f\x01\x7f\x01\x04\x45\x93\x3f\x5b\x01\xc7\x01\xea\x01\x00\x00\xdc\x18\x00\x00\x17\x17\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x17\x00\x00\x45\x18\x00\x00\x00\x00\x00\x00\x00\x00\x15\x61\x00\x00\x00\x00\x00\x00\x43\x02\x7a\x02\x00\x00\x00\x00\x7f\x45\x7f\x45\x00\x00\x00\x00\x55\x60\x9c\x3d\x94\x3b\x16\x3c\x9e\x39\x0d\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x3a\x00\x00\x00\x00\x5e\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x02\x3c\x06\x49\x00\x10\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x02\x73\x19\x00\x00\xa4\x2c\x0a\x1a\x00\x00\x3f\x02\x00\x00\x00\x00\x00\x00\xe4\x02\xfc\x02\x00\x00\x00\x00\xe9\x15\x00\x00\x00\x00\xdc\x02\x00\x00\x00\x00\x00\x00\xa4\x2c\x91\x28\xeb\x02\x72\x39\xf2\x02\x72\x39\x99\x00\xe1\x31\xb3\x37\x72\x39\x72\x39\x72\x39\xd2\x26\x6b\x20\xbf\x22\x72\x39\xe5\x49\xf2\x02\xf2\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x2c\x76\x32\x93\x3f\x8a\x03\xa4\x2c\xff\x3a\x80\x16\xef\x02\x00\x00\x13\x03\xf3\x07\x42\x03\x53\x03\x00\x00\x00\x00\x00\x00\x95\x03\xd0\x03\x11\x4a\x1f\x4c\x72\x4b\xae\x4b\x1f\x4c\x81\x5e\xfe\x03\x6b\x20\x00\x00\x44\x03\x44\x03\x44\x03\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x08\x04\x45\xbc\x03\x7c\x03\xfb\x02\xd5\x06\x00\x00\x17\x3e\xa3\x01\xde\x5e\x70\x03\x0a\x5f\x0a\x5f\x55\x5e\x66\x03\x00\x00\x66\x03\xdc\x03\x89\x03\x5a\x03\x89\x03\x00\x00\x00\x00\x5a\x03\x00\x00\xc7\x03\xc5\x03\x9c\x02\x00\x00\x00\x00\x52\x00\x9c\x02\x24\x04\x03\x04\x72\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x39\x14\x01\xc6\x02\x85\x00\x00\x00\xfc\xff\xf6\x03\xcf\x00\x00\x00\xfc\xff\x34\x01\x00\x00\x0b\x33\x11\x02\x1c\x60\x0c\x04\x15\x00\x88\x01\x00\x00\xf4\x04\xf4\x04\x83\x00\x3a\x04\x97\x02\xbf\x00\x95\x42\x04\x45\x4a\x02\x93\x3f\x54\x04\x59\x04\x5f\x04\x71\x04\x00\x00\xc7\x04\x00\x00\x00\x00\x00\x00\x93\x3f\x93\x3f\x04\x45\x96\x04\x9f\x04\x00\x00\x99\x03\x00\x00\xa4\x2c\x00\x00\x00\x00\x93\x3f\x2b\x3b\x04\x45\xbb\x04\x7f\x04\xb2\x04\x32\x47\x84\x01\xc4\x01\xa1\x04\x00\x00\xa0\x33\x00\x00\x00\x00\x00\x00\xb1\x04\xb8\x04\xc0\x04\xc3\x04\x7e\x24\x67\x27\x00\x00\xb3\x37\x92\x4d\x00\x00\x00\x00\x2b\x3b\xc5\x04\xee\x04\xd2\x00\xfd\x04\x00\x00\xf2\x04\x00\x00\xd9\x04\x00\x00\x53\x4c\x0d\x00\x1f\x4c\x00\x00\x65\x00\x1f\x4c\x93\x3f\x1d\x05\x73\x4a\xdd\x04\x00\x00\x55\x05\x13\x25\x13\x25\x55\x60\x93\x3f\xf1\x04\x00\x00\x00\x00\x00\x00\x00\x00\x04\x05\xe2\x04\xb5\x01\x00\x00\x00\x00\xf9\x04\x00\x05\x00\x00\x00\x00\x05\x05\x39\x07\x08\x05\x00\x00\xbb\x29\xbb\x29\x00\x00\x00\x00\x00\x00\x64\x06\x00\x00\xe4\x01\x36\x05\x00\x00\x00\x00\xa8\x25\x00\x00\x44\x05\x10\x00\x49\x05\x4f\x05\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x1a\x00\x00\x72\x39\x65\x05\xa2\x03\xb4\x03\x9b\x05\x9f\x05\x00\x00\x00\x00\x9d\x05\xfe\x05\xac\x05\x2f\x00\x00\x00\x00\x00\x39\x2d\xbd\x05\x18\x06\x72\x39\xce\x2d\x92\x4d\xea\x4b\x00\x00\x7f\x45\x00\x00\x93\x3f\xce\x2d\xce\x2d\xce\x2d\xce\x2d\xbe\x05\xe9\x05\xc0\x03\xee\x05\xfc\x05\xa5\x00\xff\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x3f\x1a\x3d\x46\x4b\xed\x05\x04\x06\xfa\xff\xba\x05\xf5\x05\xe5\x03\x8d\x00\x00\x00\x2c\x03\x07\x3a\x47\x03\x03\x06\x00\x00\xfd\xff\x00\x00\x48\x01\x1a\x06\x00\x00\x26\x06\x00\x00\x1d\x02\x00\x00\xe4\x4a\x00\x00\x00\x00\x00\x00\x3e\x02\x15\x61\x00\x00\x00\x00\x75\x61\x75\x61\x93\x3f\x7f\x45\x00\x00\x04\x45\x00\x00\x7f\x45\x3a\x06\x93\x3f\x93\x3f\x7f\x45\x93\x3f\x93\x3f\x00\x00\x00\x00\xc0\x01\x00\x00\x61\x34\x39\x00\x00\x00\x2d\x06\x9c\x02\x9c\x02\x00\x00\x42\x06\xfc\xff\xfc\xff\x42\x06\x00\x00\x00\x00\xbe\x06\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x06\xba\x06\x7d\x02\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\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x06\x43\x01\x00\x00\x00\x00\x00\x00\x76\x06\x55\x60\x00\x00\x93\x3f\x55\x60\x00\x00\x93\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x3f\x93\x3f\x00\x00\x00\x00\x6a\x06\x72\x06\x80\x06\x88\x06\x8a\x06\x93\x06\x98\x06\x9c\x06\x9f\x06\x9d\x06\xab\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\xc6\x06\x00\x00\xbc\x06\xe3\x06\xd4\x06\xd9\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x03\x9c\x01\xec\x06\xd1\x06\x00\x00\x00\x00\x00\x00\x2b\x07\x00\x00\xce\x2d\xce\x2d\x00\x00\x00\x00\x00\x00\x35\x34\xce\x1b\x00\x00\x26\x29\x38\x1b\xce\x2d\x00\x00\xfc\x27\x00\x00\xce\x2d\x50\x2a\xfc\x27\x00\x00\xd2\x06\x00\x00\x00\x00\x00\x00\x54\x23\xf4\x06\x00\x00\x48\x38\x7e\x00\x00\x00\xc9\x02\x00\x00\x00\x00\x00\x00\x00\x00\xed\x1c\x52\x00\xe2\x06\x00\x00\x00\x00\x00\x00\xda\x06\x00\x00\xdc\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x5f\x00\x00\x00\x00\x5a\x01\x82\x00\x00\x00\x00\x00\x70\x0a\x00\x00\x00\x21\x95\x21\x59\x01\x00\x00\x2a\x22\xe9\x02\x07\x03\xd0\x03\x02\x07\x00\x00\x00\x00\x00\x00\x00\x00\x03\x07\x05\x07\xd3\x06\x00\x00\x00\x00\xea\x06\x09\x07\x00\x00\x0e\x07\xf2\x06\xf5\x06\x67\x5f\x67\x5f\x00\x00\x0f\x07\x50\x04\x09\x05\xed\x06\xf0\x06\x00\x00\x16\x07\xf8\x06\x57\x07\x00\x00\x00\x00\x92\x4d\x00\x00\xce\x2d\xfc\x27\x33\x00\x12\x43\x05\x04\x15\x04\x00\x00\x00\x00\xce\x2d\x00\x00\x00\x00\x6b\x00\x00\x00\xce\x2d\x63\x2e\x04\x45\x52\x07\x00\x00\x20\x07\x01\x07\x00\x00\x00\x00\x22\x07\xd5\x06\x00\x00\x00\x00\x00\x00\x00\x00\x56\x07\x2b\x00\xfa\x01\x45\x04\x00\x00\x25\x07\x15\x61\x93\x3f\x93\x3f\x4a\x02\xab\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x46\x92\x4d\xfd\x06\x93\x3f\x00\x00\x92\x4d\x55\x60\xf8\x2e\xf8\x2e\xca\x34\x00\x00\x9d\x01\x00\x00\xff\x06\x00\x00\x04\x07\x00\x00\x00\x00\x93\x5f\x93\x5f\x00\x00\x00\x00\x93\x5f\x00\x00\x72\x39\x3e\x01\x2d\x07\x2e\x07\x00\x00\x64\x07\x00\x00\x18\x07\x00\x00\x18\x07\x00\x00\x00\x00\x7b\x07\x00\x00\x1a\x07\x00\x00\xed\x1c\x73\x07\x7c\x49\x76\x07\x10\x07\x00\x00\x00\x00\x00\x00\x27\x07\x48\x07\x00\x00\x00\x00\x00\x00\x29\x01\x00\x00\x00\x00\x81\x01\x30\x07\x5f\x35\x81\x60\x7d\x07\x00\x00\x31\x07\x2a\x07\x00\x00\x00\x00\x32\x07\x00\x00\x40\x46\x00\x00\x5a\x07\x5b\x07\x5c\x07\x5d\x07\xb5\x60\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x07\x93\x3f\x59\x07\x93\x3f\x15\x61\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x04\x93\x3f\x93\x3f\x00\x00\x00\x00\x93\x3f\x3b\x07\x00\x00\x07\x4e\x00\x00\x5a\x04\x00\x00\x5e\x07\x96\x07\x00\x00\x00\x00\x6d\x04\x00\x00\x9a\x07\xae\x07\x93\x3f\x9e\x07\x93\x04\x65\x07\x00\x00\x15\x61\x00\x00\x71\x07\x00\x00\x00\x00\x00\x00\x6b\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x3f\x00\x00\x55\x07\x93\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x44\x07\x00\x00\x3d\x26\xf8\x2e\x00\x00\x00\x00\x93\x3f\xf1\x04\x00\x00\x00\x00\x5f\x07\x00\x00\xe5\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x02\x00\x00\x00\x00\x00\x00\x05\x01\x00\x00\x00\x00\x8d\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x04\x00\x00\x52\x00\x60\x07\x00\x00\x7a\x2b\x61\x07\x00\x00\x2b\x04\x00\x00\x52\x00\x63\x07\x00\x00\xdd\x38\x66\x07\x00\x00\x00\x00\x00\x00\x22\x30\xb7\x30\x4c\x31\x00\x00\x00\x00\x92\x4d\xfc\x27\xea\x4b\x00\x00\x00\x00\x93\x3f\x00\x00\x00\x00\x75\x07\x00\x00\x69\x07\x6f\x07\x00\x00\x00\x00\x00\x00\x00\x00\x93\x3f\x00\x00\x93\x3f\x00\x00\x1f\x5e\x00\x00\x00\x00\x00\x00\xfa\x04\x00\x00\xb4\x07\x98\x07\x99\x07\xc6\x07\x80\x05\x00\x00\x00\x00\x80\x05\x00\x00\xf7\x01\xf7\x01\x00\x00\x77\x07\x7e\x07\x00\x00\x00\x00\x79\x07\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x7a\x07\x00\x00\x00\x00\xf4\x35\x00\x00\x00\x00\xcd\x07\x9c\x07\x4c\x31\x00\x00\x00\x00\x4c\x31\x00\x00\x00\x00\xc3\x07\x82\x1d\x0f\x2c\x0f\x2c\x4c\x31\x00\x00\x80\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x07\x81\x07\xad\x07\x00\x00\xaf\x07\x00\x00\x9b\x07\x04\x45\xe0\x07\xf2\x07\xab\x07\x00\x00\x04\x45\x15\x61\x00\x00\x00\x00\xf5\x07\x00\x00\xa2\x02\xf5\x07\x96\x05\x00\x00\x00\x00\x4c\x31\x00\x00\x17\x1e\x17\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x1e\xac\x1e\x00\x00\x00\x00\x00\x00\xe5\x07\x75\x61\x00\x00\x04\x45\xb5\x07\x93\x3f\x00\x00\x00\x00\xb5\x60\x00\x00\x00\x00\x99\x05\xa0\x07\xe1\x60\x00\x00\x92\x4d\xc5\x05\x00\x00\x00\x00\x9f\x07\x00\x00\x83\x07\x00\x00\x00\x00\x07\x04\x00\x00\x9e\x05\xa2\x07\x90\x07\x00\x00\xa4\x07\x00\x00\x00\x00\x00\x00\x00\x00\x07\x04\x4a\x02\x09\x05\x95\x07\x00\x00\x9e\x05\xa3\x07\x00\x00\xa9\x07\x00\x00\xa9\x07\x00\x00\x00\x00\x00\x00\xb0\x07\xb1\x07\xb3\x07\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x4a\xa8\x49\x00\x00\x00\x00\x05\x08\x00\x00\x00\x00\x4c\x31\xd4\x07\x00\x00\x89\x36\x3d\x26\x3d\x26\x00\x00\x00\x00\x93\x3f\xda\x07\x00\x00\xd8\x07\x00\x00\xa1\x05\x00\x00\x1d\x08\x00\x00\x5c\x01\x00\x00\x00\x00\x1d\x08\x08\x03\x00\x00\x75\x61\x00\x00\x00\x00\x63\x01\x00\x00\x0f\x08\x1e\x37\x94\x3e\x09\x03\x00\x00\x0a\x05\x0a\x05\x00\x00\xd0\x02\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x11\x3f\x00\x00\xd5\x07\xe6\x07\x00\x00\xea\x07\x00\x00\x27\x08\x00\x00\x33\x08\x00\x00\x04\x45\x00\x00\x00\x00\x93\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x31\x4c\x31\x4c\x31\x00\x00\x00\x00\x00\x00\x00\x00\x39\x08\xfc\x27\x92\x4d\x00\x00\x00\x00\x00\x00\x66\x01\x00\x00\x0c\x08\x07\x04\x74\x38\x1e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x01\xdc\x07\xdf\x07\x09\x39\xcb\x04\x07\x04\x00\x00\x00\x00\x00\x00\x4c\x31\x00\x00\x00\x00\x1c\x08\x00\x00\xf6\x07\x00\x00\x00\x00\x00\x00\x04\x45\x00\x00\xd9\x07\xe1\x07\x00\x00\x00\x00\x00\x00\x52\x00\xde\x07\xd0\x03\xee\x07\x00\x00\x41\x1f\x00\x00\xc8\x04\x8f\x43\x04\x45\xcb\x0d\x04\x45\x00\x00\x00\x00\x00\x00\xd6\x1f\x8f\x43\x00\x00\x00\x00\x14\x08\x00\x00\x15\x40\x92\x40\x75\x61\x0f\x41\x00\x00\x69\x01\x21\x03\xe1\x60\x0f\x41\x00\x00\x58\x08\x00\x00\xf4\x07\xec\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\xfb\x07\x00\x00\x00\x00\xa6\x4a\x00\x00\x29\x00\x07\x04\xf7\x07\x02\x08\x00\x00\x00\x00\x00\x00\x75\x61\x00\x00\x7d\x01\x00\x00\x52\x00\x28\x03\xfe\x07\x0c\x44\x00\x00\x00\x00\x19\x08\x0f\x41\x06\x05\x00\x00\x00\x00\x0f\x41\x91\x41\x00\x00\x00\x00\x1b\x08\x0a\x05\x00\x00\x00\x00\x13\x42\x00\x00\x00\x00\x04\x45\x4c\x31\x00\x00\x62\x05\xfd\x07\x00\x00\x07\x04\x00\x00\x07\x04\x00\x00\x54\x03\x00\x00\x66\x08\x2b\x02\x00\x00\x93\x00\x53\x08\x06\x08\x00\x00\x00\x00\x00\x00\x00\x00\x13\x42\x1f\x08\x64\x1c\x98\x3c\x00\x00\x00\x00\x41\x61\x00\x00\x00\x00\x81\x05\x00\x00\x00\x00\x89\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x08\x7c\x49\x00\x00\x01\x08\x7c\x49\x00\x00\x5a\x08\x6c\x08\x82\x3a\x75\x61\x00\x00\x5c\x08\xbc\x05\xab\x14\x07\x04\x00\x00\x07\x04\x07\x04\x00\x00\x07\x04\x00\x00\x00\x00\x00\x00\x04\x08\x2b\x08\x00\x00\x07\x04\x00\x00\xbc\x05\x00\x00\x00\x00\x6f\x08\x15\x08\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x08\x07\x04\x00\x00\x00\x00\x00\x00\x00\x00"# - -happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\xe3\x02\x65\x08\x54\x08\x3a\x52\x7c\x01\xda\x55\x08\x55\x35\x06\x82\x52\x01\x00\x92\x0e\x8e\x01\x1b\x03\x51\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\x11\x04\x00\x00\x00\x00\x9a\x02\x00\x00\x00\x00\x62\x07\x6d\x07\x9e\x02\x00\x00\xdd\x05\xf0\x05\xf1\x13\x3d\x03\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x07\x00\x00\x69\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x03\x17\x04\x00\x00\x00\x00\x94\xff\xc6\x0e\x68\x08\x21\x08\xbd\x00\x3c\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\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\xeb\x05\x58\x07\x98\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x0b\x00\x00\x20\x56\xa6\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\x66\x56\xec\x53\x86\x05\xdf\x62\xa1\x07\xf0\x62\x00\x00\xe4\x61\x5c\x62\x29\x63\x62\x63\x73\x63\xc3\x4d\x64\x4c\x4e\x4d\xac\x63\x0f\x0c\xb6\x07\xbc\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x56\xf2\x60\xd9\x0e\xb7\x07\xf2\x56\xe0\x64\x72\x04\x50\x08\x00\x00\x00\x00\x99\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x05\x79\x00\x78\x05\x78\x03\xb5\x05\xe7\x05\x8e\x04\x88\x0e\xde\x01\xd9\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x01\x2c\x07\x00\x00\x00\x00\xf7\x05\x5f\x08\x00\x00\x04\x01\x17\x08\xa5\xff\xe1\x05\x89\x00\x62\x01\x61\x03\x00\x00\x00\x00\x00\x00\x75\x08\x00\x00\x7c\x07\x00\x00\x4f\x00\x00\x00\x88\x07\x97\x01\x00\x00\xec\x01\x8f\x08\x00\x00\x00\x00\x7f\x07\x90\x08\x78\x08\x00\x00\xe5\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\x63\x6f\x02\x08\x06\x00\x00\x00\x00\x3b\x08\x00\x00\x00\x00\x00\x00\x3c\x08\x00\x00\x00\x00\xe0\x04\x00\x00\xc5\xff\x00\x00\x62\xff\xa6\x03\x00\x00\x3d\x08\x3e\x08\x00\x00\x00\x00\x2d\x08\x00\x00\x7a\x04\x82\x12\x65\x03\xa8\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x09\xe1\x0c\x95\x12\x22\x08\x00\x00\x00\x00\x38\x04\x00\x00\xdb\x4b\x00\x00\x00\x00\x44\x0b\x98\x02\x72\x07\x6a\x08\x00\x00\x00\x00\xd2\x0d\x00\x00\x82\xff\x00\x00\x00\x00\x03\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x4e\x10\x4f\x00\x00\x5c\x62\xba\x01\x00\x00\x00\x00\xaa\x03\x00\x00\x3f\x08\x02\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x31\x00\x00\x68\x05\x00\x00\x4c\x08\x82\x05\x0c\x0a\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\xe6\x02\x5c\x03\xf6\xff\x88\x0b\xf0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x01\x16\x05\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\x0f\x00\x00\x00\x29\x0e\x00\x00\x00\x00\xca\x52\x12\x53\x00\x00\x00\x00\x00\x00\xeb\x05\xf9\x07\x82\xff\x00\x00\x00\x00\x00\x00\x32\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x64\x00\x00\xf5\x61\x00\x00\x97\x07\x9d\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x08\x81\xff\x00\x00\x00\x00\x59\x53\x6a\x05\x00\x00\x68\x64\x38\x57\x01\x03\x0d\x04\x00\x00\xe3\x04\x00\x00\x26\x11\x7e\x57\xc4\x57\x0a\x58\x50\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\xf4\x0c\x55\x08\x9e\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\x78\x04\x00\x00\xdb\x04\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x00\x00\x53\x01\xf5\x01\x39\x11\x2b\x05\x00\x00\x35\x14\x00\x00\x8e\x05\x00\x00\x7d\x11\x90\x11\x69\x06\xd4\x11\x2f\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\xaa\x07\x00\x00\x85\x02\xb2\x08\xbd\x08\x00\x00\xb5\x08\x57\x08\x59\x08\xb7\x08\x00\x00\x00\x00\xab\x08\x00\x00\x00\x00\x00\x00\x00\x00\xda\x08\x00\x00\xd5\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\xe7\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x2b\x12\x42\x02\x00\x00\x28\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x0d\xd5\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\xbe\x07\x11\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x58\xdc\x58\x00\x00\x00\x00\x00\x00\x22\x47\xdb\x46\x00\x00\x06\x46\xbc\x45\x22\x59\x00\x00\x7f\x4f\x00\x00\x68\x59\xaa\x51\xee\x4f\x00\x00\x5f\xff\x00\x00\x00\x00\x00\x00\xa1\x4e\x00\x00\x00\x00\x6d\x62\xc5\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x02\xc8\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\xdb\x02\x00\x00\x00\x00\x00\x00\xc9\x07\x00\x00\x00\x00\xa6\x01\x00\x00\x00\x00\x00\x00\xd0\x07\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x08\x17\x14\x00\x00\x00\x00\xca\x04\xdf\x02\x00\x00\x00\x00\x00\x00\x7b\x05\x00\x00\x29\x0e\x00\x00\x00\x00\xc8\x03\x00\x00\xdb\x4b\x5d\x50\x00\x00\x94\x07\xe6\xff\x00\x00\x00\x00\x00\x00\x1e\x4c\x00\x00\x00\x00\x13\x00\x00\x00\xae\x59\xa0\x53\xd9\x12\x76\x08\x19\x05\xa9\x08\x00\x00\x00\x00\x00\x00\x00\x00\xac\x08\x00\x00\x00\x00\x00\x00\x00\x00\x93\x08\xdb\x05\xa8\x05\xad\x08\x00\x00\x00\x00\x26\x01\x73\x0f\xee\x09\x82\x03\x8f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\xff\xc1\x02\xe7\x07\x9b\x0b\x00\x00\xce\xff\xde\xff\x4e\x55\x94\x55\x8a\x08\x00\x00\x8e\x08\x00\x00\x9d\x08\x00\x00\x87\x08\x00\x00\x00\x00\xe1\x00\xf1\x02\x00\x00\x00\x00\x90\x01\x00\x00\x79\x64\x0b\x08\x00\x00\x00\x00\x00\x00\xe7\x08\x00\x00\xfb\x08\x00\x00\xfc\x08\x00\x00\x00\x00\xca\x02\x00\x00\xf3\x08\x00\x00\x31\x01\x00\x00\x24\x00\x00\x00\xef\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\x6e\x61\xa1\xff\xc0\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x0f\xd9\x08\xca\x0f\x98\x01\x00\x00\xc7\x08\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x08\x44\x0a\xdd\x0f\x00\x00\x00\x00\x21\x10\x00\x00\x00\x00\x1c\x02\x00\x00\xc6\x08\x00\x00\x00\x00\xbe\x08\x00\x00\x00\x00\x48\x06\x00\x00\x8b\x08\x14\x05\x34\x10\xd0\x05\xec\xff\x00\x00\x00\x00\x49\x01\x00\x00\x00\x00\x00\x00\x00\x00\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\x0a\x00\x00\x00\x00\xe0\x0a\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x05\x00\x00\x23\x06\xf4\x59\x00\x00\x00\x00\xdf\x0b\x5a\x02\x00\x00\x00\x00\x09\x09\x00\x00\x34\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\x3a\x5a\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x04\x00\x00\x0a\x08\x00\x00\x00\x00\x4f\x46\x00\x00\x00\x00\x69\x05\x00\x00\x12\x08\x00\x00\x00\x00\x68\x47\x00\x00\x00\x00\x00\x00\x00\x00\x80\x5a\xc2\x54\xc6\x5a\x00\x00\x00\x00\xe5\x00\xcc\x50\xda\x02\x00\x00\x00\x00\xf7\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x10\x00\x00\x8b\x10\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x26\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x09\x00\x00\x00\x00\x24\x09\x00\x00\xe0\x06\xe7\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\x7f\x08\x00\x00\x00\x00\x97\x47\x00\x00\x00\x00\xd0\x08\x63\x08\x0c\x5b\x00\x00\x00\x00\x98\x46\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x51\x7b\x54\x52\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\xec\x12\x9f\x08\x0a\x06\x00\x00\x00\x00\x95\x0a\x77\x01\x00\x00\x00\x00\x95\x08\x00\x00\xc8\xff\x0f\x06\x00\x00\x00\x00\x00\x00\x98\x5b\x00\x00\xd9\x03\x23\x04\x00\x00\xa2\x08\x6d\x06\x00\x00\x00\x00\x00\x00\x00\x00\xd3\xff\x9d\x02\x00\x00\x00\x00\x00\x00\xfe\x08\xbe\xff\x00\x00\x30\x13\x00\x00\xf2\x0b\x00\x00\x00\x00\xeb\xff\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xff\x00\x00\xf0\x02\x29\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x08\x00\x00\x33\x09\x00\x00\x00\x00\x00\x00\x28\x09\x00\x00\x00\x00\x00\x00\x00\x00\x23\x08\xa9\x03\xaa\x01\x6f\x05\x00\x00\x39\x09\x27\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x02\x59\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x44\x00\x00\x00\x00\x00\x20\x09\x00\x00\x00\x00\xde\x5b\x00\x00\x00\x00\x00\x00\x64\x05\xae\x05\x00\x00\x00\x00\x36\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x07\x09\x00\x00\x03\x09\x00\x00\x2c\x08\x00\x00\x00\x00\x04\x09\x00\x00\x00\x00\x1c\x02\x00\x00\x00\x00\x2e\x08\x00\x00\x0d\x09\x7f\x61\x46\x05\x00\x00\x00\x00\x0f\x01\xab\x01\x00\x00\x97\xff\x11\x09\x00\x00\x00\x00\x00\x00\x00\x00\x17\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x06\x00\x00\x13\x06\x00\x00\xff\x07\x00\x00\x00\x00\xf3\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x24\x5c\x6a\x5c\xb0\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x51\xe6\x03\x00\x00\x00\x00\x00\x00\x2f\x08\x00\x00\x34\x09\x3a\x08\x0e\x00\x00\x00\x00\x00\xf6\x02\x29\x03\x00\x00\x00\x00\x00\x00\x00\x00\x53\x09\x5a\x09\x00\x00\x14\x00\x51\x09\x45\x08\x00\x00\x00\x00\x00\x00\xf6\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x08\x00\x00\xbf\x01\x00\x00\x00\x00\xef\x04\x00\x00\x12\x09\x71\x06\x43\x13\x29\x0e\x87\x13\x00\x00\x00\x00\x00\x00\xa5\x04\xd0\x06\x00\x00\x00\x00\x0e\x09\x00\x00\x7e\x02\x9f\x03\xc1\xff\xcf\x10\x00\x00\x51\x08\x00\x00\xbd\xff\x3e\x12\x00\x00\x47\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x08\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\xe8\x06\x64\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x02\x00\x00\x6e\x08\x00\x00\x70\x08\x00\x00\x00\x00\xc4\x07\x00\x00\x00\x00\x2d\x09\x49\x0c\x2c\x09\x00\x00\x00\x00\xe2\x10\x2b\x0e\x00\x00\x00\x00\x00\x00\xd9\x01\x00\x00\x00\x00\x3e\x09\x00\x00\x00\x00\x9a\x13\x3c\x5d\x00\x00\x6e\x09\x76\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\x7b\x09\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x0c\x00\x00\x00\x00\xf9\x08\x00\x00\x00\x00\x6e\xff\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x0b\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\xf8\x08\x1b\x06\x00\x00\xc0\xff\x00\x00\x00\x00\x8a\x09\x08\x00\x77\x08\x00\x00\x02\x00\x7a\x08\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x08\x00\x00\x96\x09\x00\x00\x00\x00\x70\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\x8e\xfd\x00\x00\x00\x00\xbf\xff\xc0\xff\x00\x00\xf2\xff\x1b\xfd\x17\xfd\x14\xfd\x04\xfd\x02\xfd\x03\xfd\x10\xfd\x01\xfd\x00\xfd\xff\xfc\x12\xfd\x11\xfd\x13\xfd\x0f\xfd\x0e\xfd\xfe\xfc\xfd\xfc\xfc\xfc\xfb\xfc\xfa\xfc\xf9\xfc\xf8\xfc\xf7\xfc\xf6\xfc\xf5\xfc\xf3\xfc\xf4\xfc\x00\x00\x15\xfd\x16\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\x9b\xfe\x00\x00\x96\xfe\x94\xfe\x8f\xfe\x8e\xfe\x8a\xfe\x8b\xfe\x74\xfe\x73\xfe\x00\x00\x81\xfe\x4f\xfd\x85\xfe\x49\xfd\x40\xfd\x43\xfd\x3c\xfd\x80\xfe\x84\xfe\x24\xfd\x21\xfd\x6a\xfe\x5f\xfe\x1f\xfd\x1e\xfd\x20\xfd\x00\x00\x00\x00\x39\xfd\x38\xfd\x00\x00\x00\x00\x7f\xfe\x37\xfd\x42\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\xfd\x3f\xfd\x3a\xfd\x3b\xfd\x41\xfd\x3d\xfd\x3e\xfd\x78\xfd\x6c\xfe\x6b\xfe\x6d\xfe\x00\x00\x18\xfe\x17\xfe\x00\x00\xf1\xff\x67\xfd\x58\xfd\x66\xfd\xef\xff\xf0\xff\x28\xfd\x0c\xfd\x0d\xfd\x08\xfd\x05\xfd\x65\xfd\xf0\xfc\x54\xfd\xed\xfc\xea\xfc\xed\xff\x07\xfd\xf1\xfc\xf2\xfc\x00\x00\x00\x00\x00\x00\x00\x00\xee\xfc\x06\xfd\xeb\xfc\xef\xfc\x09\xfd\xec\xfc\xd5\xfd\x89\xfd\x11\xfe\x0f\xfe\x00\x00\x0a\xfe\x02\xfe\xf3\xfd\xf0\xfd\xe1\xfd\xe0\xfd\x00\x00\x00\x00\x8f\xfd\x8c\xfd\xed\xfd\xec\xfd\xee\xfd\xef\xfd\xeb\xfd\x10\xfe\xe2\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\xfd\xe9\xfc\xe8\xfc\xea\xfd\xe9\xfd\xe5\xfc\xe4\xfc\xe7\xfc\xe6\xfc\xe3\xfc\xe2\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\x7c\xff\x26\xfe\x00\x00\x00\x00\x00\x00\x17\xfd\x7a\xff\x79\xff\x78\xff\x00\x00\x00\x00\x1c\xfe\x00\x00\x1c\xfe\x1c\xfe\x00\x00\x75\xfd\x00\x00\x00\x00\x9b\xfd\x00\x00\x00\x00\x00\x00\x6e\xff\x6d\xff\x6c\xff\x6b\xff\x14\xff\x6a\xff\x69\xff\x31\xfe\x63\xff\x62\xff\x33\xfe\x61\xff\x00\x00\x28\xff\x00\x00\x46\xff\x4f\xff\x27\xff\x00\x00\x00\x00\x00\x00\xd9\xfe\xc1\xfe\xc6\xfe\x00\x00\x00\x00\x8d\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\xdf\xfc\xde\xfc\x00\x00\xbc\xff\x87\xff\x00\x00\x00\x00\x6a\xfd\x61\xfd\x6b\xfd\x1d\xfd\x63\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xc7\xfe\x00\x00\x6d\xfd\x00\x00\xc2\xfe\x00\x00\x00\x00\xda\xfe\xd7\xfe\x00\x00\x60\xfd\x00\x00\x00\x00\x00\x00\x67\xff\x00\x00\x00\x00\x00\x00\x00\x00\x94\xfe\x4f\xfd\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\x65\xfe\x00\x00\x59\xfe\x00\x00\x1b\xff\x00\x00\x2e\xfd\x00\x00\x2d\xfd\x2f\xfd\x00\x00\x00\x00\x00\x00\x14\xff\x00\x00\xc6\xfd\x11\xfe\x00\x00\x00\x00\x00\x00\x2b\xfd\x00\x00\x2a\xfd\x2c\xfd\x26\xfd\x0a\xfd\x00\x00\x0b\xfd\x54\xfd\x00\x00\x00\x00\xd8\xfc\x07\xfd\x00\x00\x5c\xfd\xdc\xfc\x00\x00\x5e\xfd\xa8\xfe\x00\x00\x00\x00\x76\xfd\x74\xfd\x72\xfd\x71\xfd\x6e\xfd\x00\x00\x00\x00\x00\x00\x1b\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\xfd\xe1\xfe\x00\x00\xe4\xfe\xe4\xfe\x00\x00\x00\x00\x00\x00\x7b\xff\xdc\xfd\x52\xfd\xdd\xfd\x00\x00\x00\x00\x00\x00\xce\xfd\xef\xfd\x00\x00\x00\x00\x73\xff\x73\xff\x00\x00\x00\x00\x00\x00\xf5\xfd\x90\xfd\x90\xfd\xf6\xfd\xde\xfd\xdf\xfd\x00\x00\xcc\xfd\x00\x00\x00\x00\x0a\xfd\x0b\xfd\x00\x00\x5a\xfd\x00\x00\xba\xfd\x00\x00\xb9\xfd\x57\xfd\xfe\xfd\xff\xfd\x00\xfe\x0b\xfe\x98\xfd\x96\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\xfe\x8b\xfd\x00\x00\x88\xfd\x08\xfe\x00\x00\xf8\xfd\x9f\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\xfd\x05\xfe\x00\x00\xcf\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\xcf\xfd\x72\xfe\x69\xfd\x68\xfd\x83\xfe\x82\xfe\x6f\xfe\x31\xfd\x65\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x64\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x79\xfe\x00\x00\x43\xfd\x00\x00\x00\x00\x7b\xfe\x00\x00\x4a\xfd\x00\x00\x00\x00\x41\xfe\x3f\xfe\xa2\xfe\x00\x00\x7d\xfe\x00\x00\x7e\xfe\x9e\xfe\x9f\xfe\x00\x00\x5f\xfe\x5e\xfe\x5b\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x89\xfe\x00\x00\x87\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\xfe\x8c\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\xe0\xfc\xe1\xfc\xe9\xff\x00\x00\xd5\xff\xdc\xff\xd9\xff\xdb\xff\xda\xff\xdd\xff\xeb\xff\x52\xfe\x9a\xfe\x98\xfe\x90\xfe\x91\xfe\x93\xfe\x00\x00\x88\xfe\x8d\xfe\x86\xfe\x97\xfe\x00\x00\x00\x00\x60\xfe\x9c\xfe\x9d\xfe\x00\x00\x00\x00\x7c\xfe\x00\x00\x00\x00\x76\xfe\x00\x00\x4b\xfd\x4e\xfd\xdd\xfc\x48\xfd\x75\xfe\x00\x00\xd9\xfc\x4c\xfd\x4d\xfd\x77\xfe\x78\xfe\x00\x00\x00\x00\x23\xfd\x42\xfd\x00\x00\x00\x00\x39\xfd\x38\xfd\x7f\xfe\x37\xfd\x3a\xfd\x3b\xfd\x3e\xfd\x64\xfe\x00\x00\x66\xfe\xee\xff\x5b\xfd\x64\xfd\x19\xfd\x59\xfd\x53\xfd\x27\xfd\x12\xfe\x13\xfe\x14\xfe\x15\xfe\x16\xfe\x04\xfe\x00\x00\x87\xfd\x84\xfd\x81\xfd\x00\x00\x17\xfd\x83\xfd\xf1\xfd\x18\xfd\x8a\xfd\x01\xfe\x00\x00\x00\x00\x00\x00\xa6\xfd\xa4\xfd\xa0\xfd\x9d\xfd\x00\x00\x09\xfe\x00\x00\x00\x00\x07\xfe\x06\xfe\xfa\xfd\x96\xfd\x00\x00\xfb\xfd\x00\x00\x00\x00\x00\x00\x97\xfd\x00\x00\xe3\xfd\xb8\xfd\x00\x00\x00\x00\x1a\xfd\xbc\xfd\xc1\xfd\xe4\xfd\xc2\xfd\xbb\xfd\xc0\xfd\xe5\xfd\x00\x00\x00\x00\x91\xfd\x00\x00\xda\xfd\xd7\xfd\xd8\xfd\xc7\xfd\xc8\xfd\x00\x00\x00\x00\xd6\xfd\xd9\xfd\x50\xfd\x00\x00\x51\xfd\x27\xfe\x33\xfd\x76\xff\x34\xfd\x56\xfd\x32\xfd\x00\x00\x29\xfe\xa4\xfe\x00\x00\x00\x00\x30\xfe\xe5\xfe\xaa\xfe\x2f\xfe\xd1\xfd\xd0\xfd\x00\x00\x7a\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xfd\xfe\xfe\xfe\x23\xfe\x69\xfe\x00\x00\x00\x00\x00\x00\xd5\xfe\xd4\xfe\x00\x00\x00\x00\x22\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd2\xfd\xda\xfc\x1a\xfd\xc4\xfd\xe7\xfd\xe8\xfd\x00\x00\xe6\xfd\xc5\xfd\x00\x00\x00\x00\x00\x00\x26\xff\xa4\xfe\x0e\xfe\x0d\xfe\x00\x00\x0c\xfe\x32\xfe\xdd\xfe\x2b\xfe\x00\x00\x00\x00\x00\x00\xf2\xfe\x54\xfe\x24\xff\x00\x00\x4b\xff\xa6\xfe\xa4\xfe\x4f\xff\x50\xff\x51\xff\x53\xff\x52\xff\xe8\xfe\x11\xff\x00\x00\x22\xff\x56\xff\x00\x00\x5f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfe\xb3\xfe\xb2\xfe\xb1\xfe\xb0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x08\xff\x05\xff\x00\x00\x00\x00\x00\x00\xce\xfe\xd6\xfe\x00\x00\x64\xff\xdb\xfe\xc0\xfe\xbb\xfe\xbf\xfe\x66\xff\xc3\xfe\x00\x00\xc5\xfe\x65\xff\xc8\xfe\x36\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\xba\xfe\xb8\xfe\x00\x00\x00\x00\xc9\xfe\x6c\xfd\xc4\xfe\x00\x00\xbc\xfe\xdc\xfe\x00\x00\x00\x00\x00\x00\xcc\xfe\x0a\xff\x0b\xff\x00\x00\x03\xff\x04\xff\xff\xfe\x00\x00\x07\xff\x00\x00\xb6\xfe\x00\x00\xae\xfe\xad\xfe\xaf\xfe\x00\x00\xb5\xfe\x59\xff\x5a\xff\x5f\xff\x00\x00\x00\x00\x45\xff\x00\x00\x00\x00\x12\xff\x10\xff\x0f\xff\x0c\xff\x0d\xff\x57\xff\x00\x00\x00\x00\x00\x00\x68\xff\x5b\xff\x00\x00\x58\xfe\x56\xfe\x00\x00\x60\xff\x00\x00\x1c\xff\x00\x00\xdd\xfe\x2d\xfe\x2c\xfe\x00\x00\xce\xfc\x4f\xfe\x3d\xfe\x00\x00\x44\xfe\x26\xff\x00\x00\x17\xff\x5f\xfe\x15\xff\x00\x00\xc3\xfd\xd3\xfd\xbf\xfd\xdb\xfc\x29\xfd\x25\xfd\x5d\xfd\xa7\xfe\x25\xfe\x73\xfd\x70\xfd\x62\xfd\x6f\xfd\x21\xfe\x00\x00\x1a\xfe\x00\x00\x00\x00\x1e\xfe\x24\xfe\x5f\xfd\xe0\xfe\x7b\xfd\xe3\xfe\xe6\xfe\x00\x00\xdf\xfe\xe2\xfe\x00\x00\x00\x00\xca\xfd\xc9\xfd\x75\xff\x95\xfd\x92\xfd\x94\xfd\xcb\xfd\xcd\xfd\xd4\xfd\xbe\xfd\xbd\xfd\xc6\xfd\xb2\xfd\xb4\xfd\xb1\xfd\xaf\xfd\xac\xfd\xab\xfd\x00\x00\xb6\xfd\xb3\xfd\xfd\xfd\x9a\xfd\x00\x00\xd0\xfc\x00\x00\xcb\xfc\xc4\xfc\x00\x00\x00\x00\xd1\xfc\x00\x00\xd4\xfc\x00\x00\xcd\xfc\xc7\xfc\x96\xfd\x00\x00\xd5\xfc\xf4\xfd\xfc\xfd\x00\x00\x00\x00\x00\x00\x9e\xfd\xf7\xfd\x00\x00\x00\x00\x00\x00\xf2\xfd\x70\xfe\x00\x00\x30\xfd\x63\xfe\x62\xfe\x61\xfe\x00\x00\x00\x00\xa3\xfe\x3e\xfe\x40\xfe\x1c\xfd\x00\x00\x5d\xfe\x00\x00\x92\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\x6e\xfe\x7a\xfe\x00\x00\x85\xfd\x82\xfd\x7f\xfd\x7d\xfd\x9c\xfd\xa5\xfd\x08\xfe\xd7\xfc\xcc\xfc\xc8\xfc\xd6\xfc\xc3\xfc\xdd\xfe\xa1\xfd\x00\x00\xd3\xfc\xca\xfc\xc5\xfc\xd2\xfc\xc2\xfc\xaa\xfd\xf9\xfc\x00\x00\x00\x00\xb7\xfd\x93\xfd\x74\xff\x91\xff\x77\xff\x28\xfe\x79\xfd\xe7\xfe\x7c\xfd\x00\x00\xa1\xfe\x00\x00\x19\xfe\x00\x00\x16\xff\x00\x00\x00\x00\x4f\xfe\x3d\xfe\x4a\xfe\x48\xfe\x00\x00\x5f\xfe\x25\xff\x5d\xff\x3c\xfe\x3a\xfe\x00\x00\x3d\xfe\x00\x00\xde\xfe\x2e\xfe\x00\x00\xf3\xfe\xf6\xfe\xf6\xfe\x53\xfe\x54\xfe\x54\xfe\x23\xff\xa5\xfe\x13\xff\xe9\xfe\xec\xfe\xec\xfe\x0e\xff\x20\xff\x21\xff\x40\xff\x00\x00\x35\xff\x00\x00\x00\x00\x00\x00\xb7\xfe\x55\xfd\x00\x00\x06\xff\x09\xff\x00\x00\x00\x00\xcc\xfe\xcb\xfe\x00\x00\x00\x00\xd3\xfe\xd1\xfe\x00\x00\xbe\xfe\x00\x00\xb9\xfe\x35\xfd\x00\x00\x86\xff\x00\x00\x00\x00\xa7\xff\xa2\xff\x9e\xff\x96\xff\x93\xff\x47\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\xbd\xfe\xd2\xfe\x00\x00\x00\x00\xcd\xfe\xcf\xfe\xe4\xfe\xe4\xfe\x02\xff\xab\xfe\x00\x00\x00\x00\x44\xff\x00\x00\x5e\xff\x00\x00\xf1\xfe\x2d\xff\xed\xfe\x00\x00\xf0\xfe\x28\xff\x2d\xff\x00\x00\x57\xfe\x55\xfe\xfc\xfe\xf7\xfe\x00\x00\xfb\xfe\x2f\xff\x00\x00\x00\x00\x00\x00\x2a\xfe\x4c\xfe\x4c\xfe\x5c\xff\x00\x00\x39\xfe\x36\xfe\x4c\xff\x4e\xff\x4d\xff\x00\x00\x3b\xfe\x00\x00\x00\x00\x95\xfe\x43\xfe\x46\xfe\x44\xfe\x55\xff\x3d\xfe\x18\xff\x00\x00\x1f\xfe\x20\xfe\x00\x00\xb5\xfd\xae\xfd\xad\xfd\xb0\xfd\x00\x00\x00\x00\x00\x00\xc6\xfc\xa2\xfd\xa3\xfd\xc9\xfc\x00\x00\x00\x00\x00\x00\x71\xfe\x5c\xfe\x5a\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\xf3\xfc\xbc\xff\x00\x00\xcb\xff\x7e\xfd\x80\xfd\x00\x00\xa9\xfd\xa8\xfd\x00\x00\xa0\xfe\x00\x00\x19\xff\x54\xff\x49\xfe\x00\x00\x45\xfe\x68\xfe\x00\x00\x35\xfe\x37\xfe\x38\xfe\x00\x00\x4d\xfe\x00\x00\x00\x00\xf5\xfe\xf8\xfe\x31\xff\x1f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x2e\xff\xf4\xfe\xeb\xfe\xee\xfe\x00\x00\x2c\xff\xea\xfe\x14\xff\x3f\xff\x37\xff\x37\xff\x00\x00\x00\x00\xac\xfe\x00\x00\x00\x00\xcc\xfe\x00\x00\xd8\xfe\x81\xff\xa3\xff\x00\x00\x9b\xff\x99\xff\x98\xff\x97\xff\x46\xfd\x45\xfd\x44\xfd\x00\x00\x00\x00\xbb\xff\xba\xff\x00\x00\x9d\xff\x7f\xff\x00\x00\x00\x00\x00\x00\x01\xff\x00\xff\x36\xff\x43\xff\x41\xff\x00\x00\x38\xff\x00\x00\x00\x00\x00\x00\x00\x00\x2b\xff\xef\xfe\x24\xff\x00\x00\x1f\xff\x30\xff\x33\xff\x00\x00\x00\x00\xf9\xfe\x51\xfe\x00\x00\x4c\xfe\x50\xfe\x34\xfe\x00\x00\x43\xfe\x47\xfe\x00\x00\x00\x00\xf9\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\xa7\xfd\x1a\xff\x67\xfe\x4e\xfe\x00\x00\x00\x00\x80\xfe\x00\x00\x1e\xff\x32\xff\x00\x00\xfa\xfe\x34\xff\x26\xff\x3c\xff\x3e\xff\x39\xff\x3b\xff\x3d\xff\x42\xff\xd0\xfe\xca\xfe\x82\xff\x8b\xff\x80\xff\x00\x00\xa6\xff\x9a\xff\x00\x00\xa6\xff\x3a\xff\x4f\xfe\x3d\xfe\x80\xfe\x00\x00\x4b\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\x1d\xff\x2a\xff\x3d\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\x61\x00\x49\x00\x06\x00\x49\x00\x37\x00\x4a\x00\x04\x00\x45\x00\xa0\x00\x07\x00\x08\x00\x09\x00\x04\x00\x0b\x00\x85\x00\x0e\x00\x08\x00\x09\x00\x04\x00\x0b\x00\x79\x00\x7a\x00\x08\x00\x09\x00\x8a\x00\x0b\x00\x08\x00\x09\x00\x09\x00\x0b\x00\x0b\x00\x52\x00\x53\x00\x62\x00\x38\x00\x85\x00\x84\x00\x85\x00\x01\x00\x79\x00\x7a\x00\x00\x00\x62\x00\xd2\x00\x09\x00\x60\x00\x39\x00\x3a\x00\x79\x00\x7a\x00\x65\x00\x00\x00\x54\x00\x9e\x00\x9f\x00\xa0\x00\x6b\x00\x6c\x00\x54\x00\x63\x00\xae\x00\xaf\x00\xb0\x00\x21\x00\x22\x00\x23\x00\x39\x00\x3a\x00\x50\x00\xb4\x00\x28\x00\x29\x00\x63\x00\x21\x00\x22\x00\x23\x00\x00\x00\x12\x00\xd2\x00\x48\x00\x28\x00\x29\x00\x12\x00\x49\x00\x54\x00\x21\x00\x22\x00\x23\x00\x4c\x00\x4a\x00\x50\x00\xe0\x00\x28\x00\x29\x00\x68\x00\x03\x01\x69\x00\x23\x00\x19\x00\x10\x00\x33\x00\x71\x00\x28\x00\x29\x00\x71\x00\x27\x00\x28\x00\x29\x00\x0b\x00\x61\x00\x33\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2b\x00\x48\x00\xb4\x00\x81\x00\x00\x00\x50\x00\x8a\x00\x71\x00\x00\x00\x18\x00\x16\x01\x72\x00\x18\x01\x72\x00\xb5\x00\xb6\x00\x28\x01\x2c\x01\x77\x00\xba\x00\x81\x00\xa9\x00\xbd\x00\x23\x01\xbf\x00\x6a\x00\xc1\x00\xa9\x00\x67\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x42\x00\xc9\x00\xca\x00\xcb\x00\x74\x00\x67\x00\x0a\x01\x0b\x01\xfe\x00\xff\x00\x64\x00\x01\x01\x02\x01\x19\x01\x70\x00\x64\x00\x2a\x01\x1d\x01\x19\x01\x2c\x01\xa9\x00\x2e\x01\x1d\x01\x23\x01\x16\x01\x81\x00\x18\x01\x6d\x00\x23\x01\x64\x00\x67\x00\x71\x00\x50\x00\x57\x00\x19\x01\x1d\x01\x19\x01\x23\x01\x1d\x01\x1d\x01\x1d\x01\x23\x01\xf2\x00\xf3\x00\x23\x01\x23\x01\x23\x01\xcf\x00\x26\x01\xb9\x00\x48\x00\x4b\x00\xfc\x00\xfd\x00\x1d\x01\x0a\x01\x0b\x01\x01\x01\x02\x01\x18\x01\x23\x01\x18\x01\x18\x01\x1d\x01\x76\x00\x00\x00\x50\x00\xcf\x00\x4c\x00\x23\x01\x23\x01\x1d\x01\x23\x01\x23\x01\x67\x00\x8a\x00\x82\x00\x23\x01\x67\x00\x66\x00\x1d\x01\x19\x01\x1a\x01\x70\x00\x1c\x01\x1d\x01\x23\x01\x70\x00\x03\x01\x71\x00\x70\x00\x23\x01\x19\x01\x25\x01\x26\x01\x6d\x00\x1d\x01\x29\x01\xfc\x00\xfd\x00\x0f\x01\x10\x01\x23\x01\x01\x01\x02\x01\x19\x01\x04\x01\x7d\x00\x7e\x00\x1d\x01\x76\x00\x4b\x00\xaf\x00\xb0\x00\x74\x00\x23\x01\x19\x01\x6b\x00\x21\x01\x22\x01\x1d\x01\x24\x01\x14\x01\x71\x00\x48\x00\x28\x01\x23\x01\x81\x00\x1a\x01\x4a\x00\x1c\x01\x1d\x01\x1e\x01\x2b\x01\x20\x01\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x2b\x01\x23\x01\x08\x01\x2b\x01\x0a\x01\x0b\x01\x71\x00\x23\x01\x2b\x01\x9e\x00\x9f\x00\xa0\x00\x08\x01\x23\x01\x0a\x01\x0b\x01\x96\x00\x23\x01\x23\x01\x6b\x00\x1a\x01\x70\x00\x1c\x01\x1d\x01\x08\x01\x71\x00\x0a\x01\x0b\x01\x42\x00\x23\x01\x1a\x01\x77\x00\x1c\x01\x1d\x01\x08\x01\x7b\x00\x0a\x01\x0b\x01\x08\x01\x23\x01\x0a\x01\x0b\x01\x1a\x01\x50\x00\x1c\x01\x1d\x01\x08\x01\x00\x00\x0a\x01\x0b\x01\x00\x00\x23\x01\x1a\x01\x7e\x00\x1c\x01\x1d\x01\x1a\x01\x00\x00\x1c\x01\x1d\x01\x00\x00\x23\x01\x37\x00\x00\x00\x1a\x01\x23\x01\x1c\x01\x1d\x01\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x23\x01\x43\x00\x19\x01\x71\x00\xfe\x00\xff\x00\x1d\x01\x01\x01\x02\x01\x48\x00\x00\x00\x6a\x00\x23\x01\xfc\x00\xfd\x00\xf9\x00\xfa\x00\x53\x00\x01\x01\x02\x01\xfe\x00\x4a\x00\x75\x00\x01\x01\x02\x01\x5b\x00\x5c\x00\x4b\x00\x01\x00\x8c\x00\x60\x00\x69\x00\x4b\x00\x56\x00\x91\x00\x65\x00\x93\x00\x94\x00\x95\x00\x71\x00\x97\x00\x98\x00\x5f\x00\x1a\x01\x26\x01\x1c\x01\x1d\x01\x19\x01\x15\x00\x70\x00\x4b\x00\x1d\x01\x23\x01\x65\x00\x25\x01\x26\x01\x16\x01\x23\x01\x18\x01\x0b\x00\x26\x01\x19\x00\x32\x00\x81\x00\x37\x00\x76\x00\x77\x00\xa7\x00\xa8\x00\x23\x01\x71\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x1b\x00\x43\x00\x67\x00\xbd\x00\x2b\x00\x67\x00\x9e\x00\x9f\x00\xa0\x00\x0a\x01\x0b\x01\x70\x00\x67\x00\x71\x00\x70\x00\x67\x00\xca\x00\x53\x00\x67\x00\xc2\x00\x4a\x00\x70\x00\xef\x00\x18\x01\x70\x00\x5b\x00\x5c\x00\x70\x00\xf9\x00\xfa\x00\x60\x00\x7b\x00\x7c\x00\xfe\x00\x23\x01\x65\x00\x01\x01\x02\x01\x67\x00\x61\x00\xb5\x00\x9e\x00\x9f\x00\xa0\x00\x69\x00\xba\x00\x50\x00\x70\x00\xbd\x00\x6b\x00\xbf\x00\x96\x00\xc1\x00\x6b\x00\x57\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x71\x00\x19\x01\xca\x00\xcb\x00\x81\x00\x1d\x01\x77\x00\x1b\x01\x65\x00\x1d\x01\x82\x00\x23\x01\x50\x00\x1a\x00\x26\x01\x23\x01\x12\x00\x06\x01\x07\x01\x7c\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x4b\x00\x76\x00\x50\x00\x9e\x00\x9f\x00\xa0\x00\x2c\x00\x2d\x00\x16\x01\x17\x01\x18\x01\xfe\x00\xff\x00\x82\x00\x01\x01\x02\x01\x6d\x00\xf2\x00\xf3\x00\x65\x00\x71\x00\x23\x01\x0c\x01\x0d\x01\x33\x00\x34\x00\x86\x00\xfc\x00\xfd\x00\x6b\x00\x70\x00\xb5\x00\x01\x01\x02\x01\x50\x00\x71\x00\xba\x00\x9f\x00\xa0\x00\xbd\x00\x19\x00\xbf\x00\x16\x01\xc1\x00\x18\x01\x55\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x4a\x00\x26\x01\xca\x00\xcb\x00\x2c\x01\x23\x01\x19\x01\x1a\x01\x2b\x00\x1c\x01\x1d\x01\x49\x00\x56\x00\x6d\x00\xa7\x00\xa8\x00\x23\x01\x71\x00\x25\x01\x26\x01\x52\x00\x5f\x00\x29\x01\xf9\x00\xfa\x00\x4c\x00\x37\x00\x16\x01\xfe\x00\x18\x01\x51\x00\x01\x01\x02\x01\x3e\x00\x3f\x00\x40\x00\x41\x00\x16\x01\x43\x00\x18\x01\x23\x01\xc2\x00\xf2\x00\xf3\x00\x76\x00\x77\x00\x19\x00\x56\x00\x7a\x00\x7b\x00\x23\x01\x5a\x00\xfc\x00\xfd\x00\x53\x00\x19\x01\x5f\x00\x01\x01\x02\x01\x1d\x01\xa7\x00\xa8\x00\x5b\x00\x5c\x00\x2b\x00\x23\x01\x4b\x00\x60\x00\x26\x01\xf9\x00\xfa\x00\x48\x00\x65\x00\x16\x01\xfe\x00\x18\x01\x52\x00\x01\x01\x02\x01\x76\x00\x69\x00\x19\x01\x1a\x01\x00\x00\x1c\x01\x1d\x01\x23\x01\xc2\x00\x71\x00\x5f\x00\x07\x00\x23\x01\x61\x00\x25\x01\x26\x01\x64\x00\x1f\x00\x29\x01\xfc\x00\xfd\x00\x81\x00\x19\x01\x04\x01\x01\x01\x02\x01\x1d\x01\x16\x01\x18\x00\x18\x01\x2c\x00\x2d\x00\x23\x01\x6a\x00\x13\x00\x26\x01\x11\x01\x1e\x00\x13\x01\x14\x01\x23\x01\x1e\x00\xfe\x00\xff\x00\x75\x00\x01\x01\x02\x01\x48\x00\x79\x00\x1e\x01\x2b\x00\x20\x01\x21\x01\x22\x01\x2b\x00\x24\x01\x4d\x00\x4e\x00\x27\x01\x28\x01\x25\x01\x26\x01\x2f\x00\x30\x00\x56\x00\x37\x00\x1b\x01\x59\x00\x1d\x01\x3c\x00\x3d\x00\xfc\x00\xfd\x00\xb5\x00\x23\x01\x00\x01\x01\x01\x02\x01\xba\x00\x4b\x00\x4c\x00\xbd\x00\x26\x01\xbf\x00\x50\x00\xc1\x00\x52\x00\x53\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x52\x00\x53\x00\xca\x00\xcb\x00\x76\x00\x96\x00\x8c\x00\x13\x00\x14\x00\x2e\x00\x69\x00\x63\x00\x18\x00\x65\x00\x60\x00\x67\x00\x96\x00\x97\x00\x98\x00\x65\x00\x25\x01\x26\x01\x3b\x00\x3c\x00\x70\x00\x6b\x00\x6c\x00\x8c\x00\x16\x01\x6a\x00\x18\x01\x13\x00\x91\x00\x4a\x00\x93\x00\x94\x00\x95\x00\x1e\x00\x97\x00\x98\x00\x75\x00\x23\x01\xf2\x00\xf3\x00\x79\x00\x56\x00\x37\x00\x56\x00\x51\x00\x5a\x00\x2b\x00\x5a\x00\xfc\x00\xfd\x00\x5f\x00\xbd\x00\x5f\x00\x01\x01\x02\x01\x2f\x00\x30\x00\x31\x00\x96\x00\x65\x00\x14\x00\x54\x00\x6b\x00\x16\x01\xca\x00\x18\x01\x51\x00\x1b\x00\x71\x00\x1d\x00\x70\x00\x6a\x00\xbd\x00\x76\x00\x77\x00\x76\x00\x23\x01\x19\x01\x1a\x01\x7a\x00\x1c\x01\x1d\x01\x75\x00\x60\x00\x1e\x00\xca\x00\x79\x00\x23\x01\x65\x00\x25\x01\x26\x01\x65\x00\x64\x00\x29\x01\x66\x00\xb5\x00\xb6\x00\x2b\x00\x6f\x00\x64\x00\xba\x00\x66\x00\x70\x00\xbd\x00\x19\x01\xbf\x00\x03\x01\xc1\x00\x1d\x01\x18\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x23\x01\xc9\x00\xca\x00\xcb\x00\x0f\x01\x10\x01\x23\x01\x65\x00\x65\x00\x65\x00\x06\x01\x07\x01\x82\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x70\x00\x70\x00\x70\x00\x0b\x01\x21\x01\x22\x01\x0e\x01\x24\x01\x16\x01\x17\x01\x18\x01\x28\x01\x65\x00\x06\x01\x07\x01\x65\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x23\x01\x65\x00\x70\x00\xf2\x00\xf3\x00\x70\x00\x96\x00\x37\x00\x16\x01\x17\x01\x18\x01\x6b\x00\x70\x00\xfc\x00\xfd\x00\xb5\x00\xb6\x00\x71\x00\x01\x01\x02\x01\xba\x00\x23\x01\x75\x00\xbd\x00\x19\x01\xbf\x00\x79\x00\xc1\x00\x1d\x01\x96\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x23\x01\xc9\x00\xca\x00\xcb\x00\x6b\x00\x71\x00\x1c\x01\x1d\x01\x19\x01\x1a\x01\x71\x00\x1c\x01\x1d\x01\x23\x01\x60\x00\x25\x01\x26\x01\x6b\x00\x23\x01\x65\x00\x25\x01\x26\x01\x71\x00\x71\x00\x29\x01\xed\x00\xee\x00\x8c\x00\x8d\x00\x6f\x00\x8f\x00\x90\x00\x91\x00\x75\x00\x93\x00\x94\x00\x95\x00\x79\x00\x97\x00\x98\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\x96\x00\xfc\x00\xfd\x00\x21\x00\x1d\x01\x00\x01\x01\x01\x02\x01\xfc\x00\xfd\x00\x23\x01\x4c\x00\x6a\x00\x01\x01\x02\x01\x50\x00\xf9\x00\xfa\x00\x4d\x00\x4e\x00\x64\x00\xfe\x00\x66\x00\x81\x00\x01\x01\x02\x01\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x1d\x01\x64\x00\xbd\x00\x66\x00\x96\x00\x23\x01\x23\x01\x19\x01\x1a\x01\x26\x01\x1c\x01\x1d\x01\x25\x01\x26\x01\x64\x00\xca\x00\x66\x00\x23\x01\x19\x01\x25\x01\x26\x01\x1d\x01\x1d\x01\x29\x01\x37\x00\xb5\x00\xb6\x00\x23\x01\x23\x01\x39\x00\xba\x00\x26\x01\x64\x00\xbd\x00\x66\x00\xbf\x00\x1b\x01\xc1\x00\x1d\x01\x96\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x23\x01\xc9\x00\xca\x00\xcb\x00\x4f\x00\x27\x01\x28\x01\x8c\x00\x65\x00\x6d\x00\x2c\x01\xf2\x00\x91\x00\x71\x00\x93\x00\x94\x00\x95\x00\x70\x00\x97\x00\x98\x00\x68\x00\x60\x00\x6a\x00\x64\x00\x6c\x00\x66\x00\x65\x00\x98\x00\x67\x00\x68\x00\x1e\x00\x06\x01\x07\x01\x75\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x48\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\x4b\x00\x4c\x00\x6d\x00\x16\x01\x17\x01\x18\x01\x71\x00\x4b\x00\xfc\x00\xfd\x00\x37\x00\xfa\x00\xbd\x00\x01\x01\x02\x01\xfe\x00\x23\x01\x4c\x00\x01\x01\x02\x01\xbd\x00\x50\x00\x68\x00\x71\x00\x6a\x00\xca\x00\x6c\x00\x1a\x01\x07\x01\x1c\x01\x1d\x01\x0a\x01\x0b\x01\xca\x00\x4f\x00\x75\x00\x23\x01\x19\x01\x1a\x01\x79\x00\x1c\x01\x1d\x01\x19\x01\x50\x00\x75\x00\x52\x00\x1d\x01\x23\x01\x79\x00\x25\x01\x26\x01\x60\x00\x23\x01\x29\x01\x4c\x00\x26\x01\x65\x00\x07\x01\x67\x00\x68\x00\x0a\x01\x0b\x01\xb5\x00\xb6\x00\x4b\x00\x4c\x00\x1a\x01\xba\x00\x1c\x01\x1d\x01\xbd\x00\x64\x00\xbf\x00\x66\x00\xc1\x00\x23\x01\x48\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x48\x00\xc9\x00\xca\x00\xcb\x00\x06\x01\x07\x01\x48\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x06\x01\x07\x01\x98\x00\x07\x01\x0a\x01\x0b\x01\x0a\x01\x0b\x01\x16\x01\x17\x01\x18\x01\x68\x00\x48\x00\x6a\x00\x1d\x01\x6c\x00\x16\x01\x64\x00\x18\x01\x66\x00\x23\x01\x23\x01\x25\x01\x26\x01\x75\x00\x1c\x01\x1d\x01\x4e\x00\x79\x00\x23\x01\xf2\x00\xf3\x00\x23\x01\x28\x01\x25\x01\x26\x01\x64\x00\x2c\x01\x66\x00\xbd\x00\xfc\x00\xfd\x00\x10\x00\xb5\x00\xb6\x00\x01\x01\x02\x01\x37\x00\xba\x00\x4b\x00\x4c\x00\xbd\x00\xca\x00\xbf\x00\x1b\x01\xc1\x00\x1d\x01\x50\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x23\x01\xc9\x00\xca\x00\xcb\x00\xb7\x00\xb8\x00\xb9\x00\x19\x01\x1a\x01\x55\x00\x1c\x01\x1d\x01\x52\x00\x53\x00\xec\x00\xed\x00\xee\x00\x23\x01\x42\x00\x25\x01\x26\x01\x81\x00\x1b\x01\x29\x01\x1d\x01\x52\x00\x60\x00\x8c\x00\x3c\x00\x3d\x00\x23\x01\x65\x00\x91\x00\x6b\x00\x93\x00\x94\x00\x95\x00\x6b\x00\x97\x00\x98\x00\x4b\x00\x4c\x00\xf2\x00\xf3\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x6b\x00\x06\x01\x07\x01\xfc\x00\xfd\x00\x0a\x01\x0b\x01\x6b\x00\x01\x01\x02\x01\x37\x00\x1a\x01\x1b\x01\x1c\x01\x1d\x01\x6b\x00\x4a\x00\x16\x01\x6b\x00\x18\x01\x23\x01\x20\x01\x21\x01\x22\x01\x52\x00\x24\x01\x71\x00\xbd\x00\x56\x00\x4b\x00\x23\x01\x4a\x00\x19\x01\x1a\x01\x4f\x00\x1c\x01\x1d\x01\x5f\x00\x50\x00\x52\x00\xca\x00\x48\x00\x23\x01\x56\x00\x25\x01\x26\x01\x71\x00\x5a\x00\x29\x01\x6b\x00\x71\x00\x60\x00\x5f\x00\x4b\x00\x4c\x00\x71\x00\x65\x00\x75\x00\x67\x00\x77\x00\x76\x00\x77\x00\xb5\x00\xb6\x00\x7a\x00\x7b\x00\x64\x00\xba\x00\x66\x00\x0c\x00\xbd\x00\x72\x00\xbf\x00\x48\x00\xc1\x00\x76\x00\x77\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x69\x00\xc9\x00\xca\x00\xcb\x00\x68\x00\x68\x00\x6a\x00\x6a\x00\x6c\x00\x6c\x00\x05\x01\x06\x01\x07\x01\x70\x00\x98\x00\x0a\x01\x0b\x01\x75\x00\x75\x00\x06\x01\x07\x01\x79\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x16\x01\x90\x00\x18\x01\xdc\x00\xdd\x00\xde\x00\x8e\x00\xe0\x00\x16\x01\x17\x01\x18\x01\x8e\x00\x4e\x00\x23\x01\x8e\x00\xf2\x00\xf3\x00\x21\x01\x22\x01\x37\x00\x24\x01\x23\x01\x3c\x00\x3d\x00\xbd\x00\xfc\x00\xfd\x00\x6d\x00\xb5\x00\xb6\x00\x01\x01\x02\x01\x1a\x01\xba\x00\x1c\x01\x1d\x01\xbd\x00\xca\x00\xbf\x00\x6b\x00\xc1\x00\x23\x01\x69\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x52\x00\xc9\x00\xca\x00\xcb\x00\xa2\x00\xa3\x00\xa4\x00\x19\x01\x1a\x01\x71\x00\x1c\x01\x1d\x01\x98\x00\x60\x00\xb1\x00\xb2\x00\xb3\x00\x23\x01\x65\x00\x25\x01\x26\x01\x4b\x00\x4c\x00\x29\x01\x05\x01\x06\x01\x07\x01\x8c\x00\x6f\x00\x0a\x01\x0b\x01\xfb\x00\x91\x00\xfd\x00\x93\x00\x94\x00\x95\x00\x01\x01\x97\x00\x98\x00\x02\x00\x03\x00\xf2\x00\xf3\x00\x48\x00\x64\x00\x37\x00\x66\x00\x48\x00\xbd\x00\x06\x01\x07\x01\xfc\x00\xfd\x00\x0a\x01\x0b\x01\x52\x00\x01\x01\x02\x01\x02\x00\x03\x00\x19\x01\xca\x00\x70\x00\x71\x00\x1d\x01\x16\x01\x64\x00\x18\x01\x66\x00\x64\x00\x23\x01\x66\x00\x25\x01\x26\x01\x64\x00\xbd\x00\x66\x00\x64\x00\x23\x01\x66\x00\x19\x01\x1a\x01\x0c\x00\x1c\x01\x1d\x01\x50\x00\x60\x00\x4a\x00\xca\x00\x4c\x00\x23\x01\x65\x00\x25\x01\x26\x01\x70\x00\x71\x00\x29\x01\xb5\x00\xb6\x00\x56\x00\x70\x00\x6f\x00\xba\x00\x5a\x00\x64\x00\xbd\x00\x66\x00\xbf\x00\x5f\x00\xc1\x00\x98\x00\x6d\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x14\x00\xc9\x00\xca\x00\xcb\x00\x72\x00\x06\x01\x07\x01\xbb\x00\xbc\x00\x0a\x01\x0b\x01\x72\x00\x5d\x00\x5e\x00\x5f\x00\x76\x00\x77\x00\x46\x00\x47\x00\x7a\x00\x7b\x00\x16\x01\x2c\x01\x18\x01\x2e\x01\xdc\x00\xdd\x00\xde\x00\xde\x00\xe0\x00\xe0\x00\xbd\x00\x06\x01\x07\x01\x23\x01\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x73\x00\x74\x00\xf2\x00\xf3\x00\xca\x00\x6b\x00\x37\x00\x72\x00\x16\x01\x17\x01\x18\x01\x72\x00\xfc\x00\xfd\x00\x6d\x00\xb5\x00\xb6\x00\x01\x01\x02\x01\x6b\x00\xba\x00\x23\x01\x6b\x00\xbd\x00\x37\x00\xbf\x00\x6b\x00\xc1\x00\xbb\x00\xbc\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x72\x00\xc9\x00\xca\x00\xcb\x00\xaa\x00\xab\x00\xac\x00\x19\x01\x1a\x01\x65\x00\x1c\x01\x1d\x01\x1a\x01\x60\x00\x1c\x01\x1d\x01\x4a\x00\x23\x01\x65\x00\x25\x01\x26\x01\x23\x01\x52\x00\x29\x01\x52\x00\x20\x01\x21\x01\x22\x01\x56\x00\x24\x01\x06\x01\x07\x01\x5a\x00\x71\x00\x0a\x01\x0b\x01\x65\x00\x5f\x00\x1a\x01\x70\x00\x1c\x01\x1d\x01\xf2\x00\xf3\x00\xbb\x00\xbc\x00\x16\x01\x23\x01\x18\x01\x6b\x00\x2d\x01\x2e\x01\xfc\x00\xfd\x00\x6a\x00\x71\x00\x4a\x00\x01\x01\x02\x01\x23\x01\x76\x00\x77\x00\x0c\x01\x0d\x01\x7a\x00\x7b\x00\x70\x00\x71\x00\x56\x00\xb1\x00\xb2\x00\xb3\x00\x5a\x00\x4e\x00\xb1\x00\xb2\x00\xb3\x00\x5f\x00\xb1\x00\xb2\x00\xb3\x00\x19\x01\x1a\x01\x0b\x00\x1c\x01\x1d\x01\xb1\x00\xb2\x00\xb3\x00\x6b\x00\x32\x00\x23\x01\x18\x00\x25\x01\x26\x01\x71\x00\x4b\x00\x29\x01\xb5\x00\xb6\x00\x76\x00\x77\x00\x72\x00\xba\x00\x7a\x00\x7b\x00\xbd\x00\x6b\x00\xbf\x00\x71\x00\xc1\x00\xf1\x00\xf2\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x6b\x00\xc9\x00\xca\x00\xcb\x00\xba\x00\x10\x00\x11\x00\xbd\x00\x6b\x00\xbf\x00\x6b\x00\xc1\x00\x10\x00\x11\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x8c\x00\x6b\x00\xca\x00\xcb\x00\x98\x00\x91\x00\x6b\x00\x93\x00\x94\x00\x95\x00\x6b\x00\x97\x00\x98\x00\x6b\x00\x20\x01\x21\x01\x22\x01\x71\x00\x24\x01\xa3\x00\xa4\x00\x27\x01\x28\x01\x69\x00\xf2\x00\xf3\x00\x2c\x01\x43\x00\x44\x00\x45\x00\x46\x00\x34\x00\x35\x00\x4e\x00\xfc\x00\xfd\x00\xb1\x00\xb2\x00\xb3\x00\x01\x01\x02\x01\xbd\x00\xf2\x00\xf3\x00\x21\x01\x22\x01\x65\x00\x24\x01\x71\x00\xbd\x00\x4c\x00\x28\x01\xfc\x00\xfd\x00\xca\x00\x2c\x01\x61\x00\x01\x01\x02\x01\xab\x00\xac\x00\x61\x00\xca\x00\x19\x01\x1a\x01\x52\x00\x1c\x01\x1d\x01\x16\x00\x71\x00\x71\x00\x50\x00\x6b\x00\x23\x01\x65\x00\x25\x01\x26\x01\x48\x00\x48\x00\x29\x01\x71\x00\x19\x01\x1a\x01\x4b\x00\x1c\x01\x1d\x01\x69\x00\x4b\x00\x82\x00\x48\x00\x48\x00\x23\x01\x4e\x00\x25\x01\x26\x01\x8c\x00\x6b\x00\x29\x01\x72\x00\x6b\x00\x91\x00\x72\x00\x93\x00\x94\x00\x95\x00\x50\x00\x97\x00\x98\x00\x71\x00\x18\x00\x4b\x00\x6b\x00\x4b\x00\x18\x00\x06\x01\x07\x01\x4c\x00\x75\x00\x0a\x01\x0b\x01\x48\x00\x48\x00\x06\x01\x07\x01\x15\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x16\x01\x81\x00\x18\x01\x6a\x00\x4a\x00\x58\x00\x81\x00\x0b\x00\x16\x01\x17\x01\x18\x01\x70\x00\x18\x00\x23\x01\xbd\x00\x18\x00\x56\x00\x48\x00\x81\x00\x6b\x00\x5a\x00\x23\x01\x18\x00\x65\x00\x8c\x00\x5f\x00\x69\x00\xca\x00\x71\x00\x91\x00\x5f\x00\x93\x00\x94\x00\x95\x00\x4a\x00\x97\x00\x98\x00\x72\x00\x4b\x00\x4b\x00\x4b\x00\x4b\x00\x50\x00\x4c\x00\x72\x00\x71\x00\x56\x00\x18\x00\x76\x00\x77\x00\x5a\x00\x18\x00\x7a\x00\x7b\x00\x07\x00\x5f\x00\x19\x00\x8c\x00\x48\x00\x55\x00\x50\x00\x90\x00\x91\x00\x69\x00\x93\x00\x94\x00\x95\x00\x7e\x00\x97\x00\x98\x00\x50\x00\x65\x00\x8e\x00\xbd\x00\x72\x00\x58\x00\x65\x00\x18\x00\x76\x00\x77\x00\x70\x00\x70\x00\x7a\x00\x7b\x00\x70\x00\x6b\x00\xca\x00\x06\x01\x07\x01\x69\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x18\x00\x4a\x00\x48\x00\x48\x00\x6b\x00\x65\x00\x6b\x00\x18\x00\x16\x01\x17\x01\x18\x01\xbd\x00\x70\x00\x56\x00\x50\x00\x59\x00\x2b\x00\x5a\x00\x70\x00\x4c\x00\x71\x00\x23\x01\x5f\x00\x48\x00\xca\x00\x48\x00\x18\x00\x07\x00\x5f\x00\x50\x00\x07\x00\x18\x00\x8c\x00\x5f\x00\x4b\x00\x71\x00\x90\x00\x91\x00\x81\x00\x93\x00\x94\x00\x95\x00\x69\x00\x97\x00\x98\x00\x76\x00\x77\x00\x6b\x00\x6a\x00\x7a\x00\x7b\x00\x06\x01\x07\x01\x70\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x70\x00\x15\x00\x6b\x00\x6b\x00\x59\x00\x6b\x00\x4b\x00\x8c\x00\x16\x01\x17\x01\x18\x01\x90\x00\x91\x00\x4c\x00\x93\x00\x94\x00\x95\x00\x52\x00\x97\x00\x98\x00\x10\x00\x23\x01\xbd\x00\x21\x00\x31\x00\x06\x01\x07\x01\x5f\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x07\x00\x55\x00\xca\x00\x4a\x00\x4b\x00\x55\x00\x19\x00\x08\x00\x16\x01\x17\x01\x18\x01\x39\x00\x6a\x00\x68\x00\x2c\x00\x56\x00\x71\x00\x55\x00\x6b\x00\x5a\x00\x70\x00\x23\x01\x8c\x00\xbd\x00\x5f\x00\x65\x00\x90\x00\x91\x00\x42\x00\x93\x00\x94\x00\x95\x00\x02\x00\x97\x00\x98\x00\x71\x00\xca\x00\x6b\x00\x65\x00\x5f\x00\x6b\x00\x65\x00\x4b\x00\x72\x00\x4b\x00\x6a\x00\x02\x00\x76\x00\x77\x00\x18\x00\x6b\x00\x7a\x00\x7b\x00\x50\x00\x6a\x00\x6a\x00\x18\x00\x07\x00\x18\x00\x4a\x00\x07\x00\x12\x00\x06\x01\x07\x01\x76\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x6b\x00\xbd\x00\x2e\x00\x76\x00\x2c\x01\xce\x00\x36\x00\xe6\x00\x16\x01\x17\x01\x18\x01\x8c\x00\x92\x00\x2b\x01\xca\x00\x90\x00\x91\x00\x5a\x00\x93\x00\x94\x00\x95\x00\x23\x01\x97\x00\x98\x00\x2b\x01\x82\x00\x06\x01\x07\x01\xe6\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xe6\x00\x44\x00\x2f\x00\x16\x00\x16\x00\x2b\x01\x30\x00\x2a\x01\x16\x01\x17\x01\x18\x01\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x2b\x01\x93\x00\x94\x00\x95\x00\x23\x01\x97\x00\x98\x00\x7f\x00\x7f\x00\xbd\x00\x9c\x00\x9d\x00\x92\x00\x83\x00\x83\x00\x76\x00\xa1\x00\x5a\x00\xcc\x00\x87\x00\x30\x01\x16\x00\xca\x00\x06\x01\x07\x01\x2f\x01\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xc2\x00\x16\x00\x2a\x01\x20\x00\x7f\x00\x20\x00\x7f\x00\x2e\x00\x16\x01\x17\x01\x18\x01\x03\x00\xbd\x00\x0a\x00\x6a\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x23\x01\x93\x00\x94\x00\x95\x00\xca\x00\x97\x00\x98\x00\x30\x01\x2a\x01\x44\x00\xe0\x00\x2a\x01\x2a\x01\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x2a\x01\x93\x00\x94\x00\x95\x00\x55\x00\x97\x00\x98\x00\x6e\x00\x78\x00\x56\x00\x76\x00\x06\x01\x07\x01\x80\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x26\x01\x4a\x00\x4b\x00\x4c\x00\x74\x00\xbd\x00\xf2\x00\x50\x00\x16\x01\x17\x01\x18\x01\x0d\x01\x32\x00\x56\x00\x20\x00\x20\x00\x2a\x00\x5a\x00\xca\x00\x31\x00\x48\x00\x23\x01\x5f\x00\x64\x00\xbd\x00\x5f\x00\x06\x01\x07\x01\x6d\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x69\x00\x72\x00\xa6\x00\xca\x00\x2a\x00\x2a\x01\x0f\x00\x72\x00\x16\x01\x17\x01\x18\x01\x76\x00\x77\x00\x2a\x01\x1c\x00\x7a\x00\x7b\x00\x1c\x00\xc2\x00\x72\x00\xe0\x00\x23\x01\xa6\x00\xa4\x00\xf2\x00\xb3\x00\x4b\x00\x17\x00\x2b\x01\x24\x00\x2c\x01\x2b\x01\x2e\x01\x17\x00\x2a\x00\x32\x00\x4c\x00\x51\x00\x51\x00\x2a\x01\x46\x00\x2a\x01\x2a\x01\xf2\x00\x06\x01\x07\x01\x50\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x2f\x00\x11\x00\x2b\x01\x0c\x00\x16\x00\x5a\x00\x57\x00\x2a\x01\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\x2b\x01\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x21\x01\x22\x01\x23\x01\x24\x01\x33\x00\x2a\x01\x27\x01\x28\x01\x16\x01\x17\x01\x18\x01\x2c\x01\x55\x00\x57\x00\x16\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x23\x01\x93\x00\x94\x00\x95\x00\x2b\x01\x97\x00\x98\x00\xf7\x00\xf8\x00\x2c\x01\xfa\x00\x20\x00\x2a\x01\x2a\x01\xfe\x00\x2a\x01\x20\x00\x01\x01\x02\x01\xa6\x00\x88\x00\x89\x00\x17\x00\x2b\x01\x8c\x00\x8d\x00\x2b\x01\x8f\x00\x90\x00\x91\x00\x2b\x01\x93\x00\x94\x00\x95\x00\x17\x00\x97\x00\x98\x00\x2b\x01\x9a\x00\xff\xff\xff\xff\x19\x01\xff\xff\xbd\x00\xff\xff\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\xff\xff\x26\x01\xff\xff\xca\x00\xff\xff\xff\xff\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xbd\x00\x97\x00\x98\x00\xff\xff\x9a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xf2\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xca\x00\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x23\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x2c\x01\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xf2\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x23\x01\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x06\x01\x07\x01\xbd\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\x16\x01\x17\x01\x18\x01\x88\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\x23\x01\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xf2\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xca\x00\xff\xff\x4a\x00\x4b\x00\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xbd\x00\x5a\x00\x23\x01\xff\xff\x89\x00\xff\xff\x5f\x00\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xca\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\x99\x00\xff\xff\xff\xff\xf2\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\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\x23\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x16\x01\x17\x01\x18\x01\x90\x00\xff\xff\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\x23\x01\xff\xff\x89\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\xf2\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xad\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x23\x01\xff\xff\x89\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xca\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\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\x06\x01\x07\x01\xbd\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xbd\x00\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xf2\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xbd\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\x23\x01\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xfb\x00\xff\xff\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\xff\xff\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\x10\x01\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\xff\xff\x19\x01\xff\xff\xff\xff\xbd\x00\x1d\x01\x16\x01\x17\x01\x18\x01\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\xca\x00\xff\xff\x23\x01\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\x04\x01\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\x11\x01\x23\x01\x13\x01\x14\x01\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\x1e\x01\xff\xff\x20\x01\x21\x01\x22\x01\xca\x00\x24\x01\x23\x01\x89\x00\x27\x01\x28\x01\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xca\x00\xff\xff\x23\x01\x89\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x9b\x00\x9c\x00\xff\xff\xf2\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x9b\x00\x9c\x00\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xbd\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xca\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\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\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x9c\x00\xbd\x00\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\x23\x01\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\x4a\x00\x4b\x00\x23\x01\xff\xff\xff\xff\xf2\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x56\x00\x93\x00\x94\x00\x95\x00\x5a\x00\x97\x00\x98\x00\xff\xff\xff\xff\x5f\x00\xff\xff\x9d\x00\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\x72\x00\x16\x01\x17\x01\x18\x01\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xbd\x00\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\x23\x01\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\xff\xff\xff\xff\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\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xbd\x00\x9c\x00\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\xbd\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xca\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xf2\x00\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\x04\x01\xff\xff\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\x11\x01\xff\xff\x13\x01\x14\x01\xff\xff\xbd\x00\xf2\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\x1e\x01\xff\xff\x20\x01\x21\x01\x22\x01\xca\x00\x24\x01\xff\xff\x23\x01\x27\x01\x28\x01\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\xff\xff\xf2\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x04\x01\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\x11\x01\xff\xff\x13\x01\x14\x01\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\x1e\x01\xff\xff\x20\x01\x21\x01\x22\x01\xff\xff\x24\x01\x23\x01\xbd\x00\x27\x01\x28\x01\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xca\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xff\xff\xfa\x00\xbd\x00\xf2\x00\xff\xff\xfe\x00\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\x19\x01\xff\xff\xca\x00\xff\xff\x1d\x01\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\x23\x01\xff\xff\xff\xff\x26\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xa5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\x23\x01\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\x23\x01\xff\xff\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\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\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xa5\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xa5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xa5\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xa5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xa5\x00\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xa5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xa5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xf2\x00\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x91\x00\xff\xff\x93\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\xff\xff\x97\x00\x98\x00\xff\xff\xad\x00\xff\xff\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\x02\x00\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\x15\x00\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x94\x00\x95\x00\xff\xff\x97\x00\x98\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\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\x16\x01\x17\x01\x18\x01\x06\x01\x07\x01\xff\xff\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xca\x00\xff\xff\x23\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xff\xff\xfa\x00\xff\xff\xff\xff\x23\x01\xfe\x00\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\x75\x00\x76\x00\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\x19\x01\xff\xff\xff\xff\xff\xff\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\x06\x01\x07\x01\x26\x01\x09\x01\x0a\x01\x0b\x01\x0c\x01\x0d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x01\x17\x01\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\x23\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\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xff\xff\xfa\x00\xff\xff\xff\xff\xff\xff\xfe\x00\xff\xff\xff\xff\x01\x01\x02\x01\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\x19\x01\xff\xff\xff\xff\xff\xff\x1d\x01\xff\xff\xff\xff\xff\xff\x21\x01\x22\x01\x23\x01\x24\x01\xff\xff\x26\x01\x68\x00\x28\x01\x6a\x00\xff\xff\x6c\x00\x2c\x01\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\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\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\x1e\x00\x1f\x00\x20\x00\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\x79\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x6a\x00\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\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\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\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\x01\x00\x02\x00\x7e\x00\xff\xff\x80\x00\x81\x00\x82\x00\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\x91\x00\xff\xff\xff\xff\x94\x00\x95\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x10\x00\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\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\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x6a\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\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\xe1\x00\xe2\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\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\x81\x00\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\x2a\x01\xe1\x00\xe2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\x34\x01\xff\xff\x36\x01\xff\xff\x38\x01\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe1\x00\xe2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\x34\x01\xff\xff\x36\x01\xff\xff\x38\x01\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe1\x00\xe2\x00\x49\x00\x4a\x00\x4b\x00\xff\xff\xff\xff\x31\x01\xff\xff\x50\x00\x34\x01\x52\x00\x36\x01\xff\xff\x38\x01\x56\x00\xff\xff\xf2\x00\xf3\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\x65\x00\xbd\x00\x01\x01\x02\x01\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xc5\x00\xc6\x00\xc7\x00\x71\x00\x72\x00\xca\x00\xcb\x00\xff\xff\x76\x00\x77\x00\xff\xff\xff\xff\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xe4\x00\xe5\x00\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\x38\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\x2a\x01\xe4\x00\xe5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x33\x01\xff\xff\x35\x01\xff\xff\x37\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe4\x00\xe5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\x33\x01\xff\xff\x35\x01\xff\xff\x37\x01\xf2\x00\xf3\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\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\xe4\x00\xe5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x33\x01\xff\xff\x35\x01\xff\xff\x37\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\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\x15\x00\x25\x01\x26\x01\xff\xff\x19\x00\x29\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\x37\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\x10\x00\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\xff\xff\x74\x00\x75\x00\xff\xff\xff\xff\xff\xff\x79\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\xff\xff\xff\xff\x2a\x00\xff\xff\x68\x00\xff\xff\x6a\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\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\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\x68\x00\xff\xff\x6a\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\x02\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\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\x49\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\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xbd\x00\xff\xff\xff\xff\xc0\x00\xc1\x00\x4a\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\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\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\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xbd\x00\x01\x01\x02\x01\xc0\x00\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x01\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\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\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\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\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\x2c\x01\xff\xff\x2e\x01\xff\xff\x02\x00\x31\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x09\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\x15\x00\xff\xff\xd0\x00\xd1\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\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\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\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\x2c\x01\x74\x00\x2e\x01\xff\xff\x02\x00\x31\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x09\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\x15\x00\xff\xff\xd0\x00\xd1\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\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\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\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\x2c\x01\x74\x00\x2e\x01\xff\xff\xff\xff\x31\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xd4\x00\xd5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\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\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\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\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\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\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\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\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\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\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\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\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\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\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\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\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\x04\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\x12\x01\x13\x01\xff\xff\x15\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\x1f\x01\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\x31\x01\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xd7\x00\xd8\x00\xd9\x00\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xe9\x00\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xe8\x00\x31\x01\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xe3\x00\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\x31\x01\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xe3\x00\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\x31\x01\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xda\x00\xdb\x00\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xda\x00\xdb\x00\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xde\x00\xdf\x00\xe0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\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\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xea\x00\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xd9\x00\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xe3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xeb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xe1\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xe1\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xe1\x00\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x01\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\x15\x00\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\x1b\x00\x1c\x00\x1d\x00\x01\x01\x02\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\x1a\x01\x02\x00\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x12\x00\xff\xff\xff\xff\x15\x00\xff\xff\x17\x00\x31\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\xbd\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\x74\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xf3\x00\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xbd\x00\x29\x01\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe4\x00\xe5\x00\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\xf3\x00\xff\xff\xe4\x00\xe5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xbd\x00\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xc5\x00\xc6\x00\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xc6\x00\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\x01\xf2\x00\xf3\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xc7\x00\x01\x01\x02\x01\xca\x00\xcb\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xbd\x00\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xff\xff\xf2\x00\xf3\x00\xff\xff\xc7\x00\xff\xff\xff\xff\xca\x00\xcb\x00\xff\xff\xff\xff\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\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\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xf2\x00\xf3\x00\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\xfc\x00\xfd\x00\xff\xff\xff\xff\xff\xff\x01\x01\x02\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\x1a\x01\xff\xff\x1c\x01\x1d\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x01\xff\xff\x25\x01\x26\x01\xff\xff\xff\xff\x29\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\x39\x05\x3a\x05\x3c\x05\x3d\x05\x21\x01\x79\x04\x70\x05\x77\x05\xca\x00\x15\x05\x72\x05\x93\x04\x46\x05\x73\x05\xc8\x04\x15\x02\xc7\x04\x16\x02\x46\x03\x6e\x05\xc8\x04\x15\x02\x34\x05\x16\x02\x3c\x04\x3d\x04\xc8\x04\x15\x02\xe0\x01\x16\x02\x14\x02\x15\x02\x15\x02\x16\x02\xe2\x03\x7d\x04\x7e\x04\xff\x02\x98\x02\x36\x04\x3f\x03\x40\x03\x53\x03\x71\x04\x3d\x04\x12\x02\x3b\x03\x99\x03\x5b\x05\xe8\x00\x8f\x02\x90\x02\x11\x05\x3d\x04\xcb\x00\x12\x02\x67\x03\xeb\x01\xec\x01\xed\x01\x7f\x04\x84\x04\x11\x04\x39\x03\xe1\x01\xe2\x01\xe3\x01\x4b\x04\x4c\x04\x4d\x04\x8f\x02\x90\x02\x3f\x02\xde\x04\x4e\x04\x4f\x04\x75\x04\x5d\x05\x4c\x04\x4d\x04\x12\x02\x31\x00\x84\x02\xbc\x02\x4e\x04\x4f\x04\x04\x01\x7e\x02\x60\x05\x7a\x05\x4c\x04\x4d\x04\xb5\x04\x81\x00\x7f\x02\x6b\x02\x4e\x04\x4f\x04\x0b\x03\xfc\x02\x32\x02\xff\x04\x0a\x01\x49\x01\x00\x01\x40\x02\x4e\x04\x4f\x04\x33\x02\x5c\x05\x03\x05\x4f\x04\xfe\x00\xb6\x04\x32\x00\x00\x05\x01\x05\x02\x05\x03\x05\x4f\x04\x06\x01\x70\x03\x94\x04\x0c\x03\x12\x02\xb1\x01\xa1\x02\x80\x02\x12\x02\x66\x03\xee\x01\x63\x03\x4d\x00\xfe\x02\xa3\x02\x81\x04\x9c\x02\x85\x02\x8c\x00\xeb\x00\xbd\x02\x68\x03\x8f\x00\x4e\x00\xa5\x02\x5c\x05\x92\x00\x12\x04\x13\x02\x94\x00\x95\x00\x96\x00\x97\x00\x4a\x01\xa6\x02\xa7\x02\xa8\x02\x54\x03\x13\x02\x95\x04\x48\x00\x22\x01\x23\x01\x33\x00\x73\x00\x10\x01\x41\x03\x14\x02\x05\x01\x6c\x02\x12\x01\xe4\x01\x85\x02\x61\x05\x86\x02\x12\x01\x11\x00\xee\x01\x71\x03\x4d\x00\x98\x01\x11\x00\x36\x00\x13\x02\x5f\x01\xde\x02\xb8\x02\x41\x03\x3e\x04\x41\x03\x4e\x00\x12\x01\x24\x01\x12\x01\x11\x00\x9e\x00\x9f\x00\x11\x00\x11\x00\x11\x00\x92\x02\x13\x01\x64\x03\x11\x03\xf4\x02\xa0\x00\x72\x00\x3e\x04\x95\x04\x48\x00\x73\x00\x74\x00\x7a\x04\x11\x00\x7a\x04\x16\x05\x3e\x04\xb9\x02\xff\xff\x3a\x02\x91\x02\x68\x05\x11\x00\x4e\x00\x00\x03\x4e\x00\x4e\x00\x13\x02\xe0\x01\xba\x02\x11\x00\x13\x02\xaf\x02\x00\x03\xce\x00\xa1\x00\x94\x03\x0f\x00\xcf\x00\x11\x00\x8a\x03\x99\x02\xf5\x02\x12\x03\x11\x00\x3a\x03\x7c\x00\x7d\x00\x3b\x02\x12\x01\xa2\x00\x71\x00\x72\x00\x9a\x02\x9b\x02\x11\x00\x73\x00\x74\x00\x3a\x03\x75\x00\x1b\x01\x1c\x01\x12\x01\x69\x05\x58\xff\xcb\x03\xe3\x01\xa7\x01\x11\x00\xe4\x01\x50\x02\xcd\x01\x7a\x00\x12\x01\x7b\x00\x76\x00\x36\x02\x0d\x03\x9c\x02\x11\x00\xa8\x01\x0e\x00\x81\x00\x0f\x00\x10\x00\x77\x00\x3b\x05\x78\x00\x79\x00\x7a\x00\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x3e\x05\x17\x02\x50\x04\x3e\x05\x51\x04\x48\x00\x58\xff\x17\x02\x3b\x05\x29\x02\xec\x01\xed\x01\x50\x04\x17\x02\x51\x04\x48\x00\xff\xff\x17\x02\x17\x02\x5e\x01\x52\x04\x0e\x03\x0f\x00\x10\x00\x50\x04\x5f\x01\x51\x04\x48\x00\x29\x01\x11\x00\x52\x04\x8c\x00\x0f\x00\x10\x00\x50\x04\x8f\x00\x51\x04\x48\x00\x50\x04\x11\x00\x51\x04\x48\x00\x52\x04\xff\x03\x0f\x00\x10\x00\x50\x04\x12\x02\x51\x04\x48\x00\x12\x02\x11\x00\x52\x04\x2f\x03\x0f\x00\x10\x00\x52\x04\x12\x02\x0f\x00\x10\x00\x12\x02\x11\x00\xca\x00\x12\x02\x52\x04\x11\x00\x0f\x00\x10\x00\x59\x04\x5a\x04\xe1\x00\xe2\x00\xe3\x00\x11\x00\xe4\x00\xe4\x01\x00\x04\x72\x01\x23\x01\x12\x01\x73\x00\x10\x01\x08\x03\x12\x02\x15\x03\x11\x00\xb0\x02\x72\x00\x1d\x01\x1a\x01\xe5\x00\x73\x00\x74\x00\x0f\x01\x57\x00\x64\x00\x73\x00\x10\x01\xe6\x00\xe7\x00\xce\x03\x33\x00\x36\x00\xe8\x00\x45\x04\x30\x02\x58\x00\x2a\x01\xcb\x00\x2b\x01\x3d\x00\x3e\x00\x46\x04\x3f\x00\x40\x00\x5c\x00\xb1\x02\x13\x01\x0f\x00\x10\x00\x11\x01\x34\x00\x09\x03\x8e\x03\x12\x01\x11\x00\xcf\x03\x7c\x00\x7d\x00\xee\x01\x11\x00\x4d\x00\x28\x01\x13\x01\x05\x01\x02\x02\xe9\x00\xca\x00\x65\x00\x66\x00\xe2\x04\xe0\x04\x4e\x00\x31\x02\xe0\x00\xe1\x00\xe2\x00\xe3\x00\x29\x01\xe4\x00\x13\x02\x41\x00\x06\x01\x13\x02\x4a\x03\xec\x01\xed\x01\xd1\x01\x48\x00\x88\x03\x13\x02\x31\x02\xef\x04\x13\x02\x42\x00\xe5\x00\x13\x02\xe1\x04\x81\x00\xe5\x04\xea\x03\xd2\x01\xc7\x04\xe6\x00\xe7\x00\x8a\x03\x1d\x01\x1a\x01\xe8\x00\x17\x01\x18\x01\x0f\x01\x4e\x00\xcb\x00\x73\x00\x10\x01\x13\x02\xce\x02\xea\x00\x0f\x04\xec\x01\xed\x01\x43\x04\xeb\x00\xb1\x01\x52\x05\x8f\x00\xcf\x02\xec\x00\xff\xff\x92\x00\x5e\x01\xb8\x02\x94\x00\x95\x00\x96\x00\x97\x00\x5f\x01\x11\x01\x98\x00\x99\x00\xe9\x00\x12\x01\x8c\x00\xeb\x03\xbc\x03\x63\x02\x44\x04\x11\x00\x5b\x01\x1d\x03\x13\x01\x11\x00\xbc\x04\x44\x00\x2c\x01\x2d\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xfd\x01\xb9\x02\x5b\x01\x9b\x04\xec\x01\xed\x01\x1e\x03\x1f\x03\x4b\x00\x4c\x00\x4d\x00\x72\x01\x85\x03\x35\x03\x73\x00\x10\x01\x96\x02\x9e\x00\x9f\x00\x1c\x02\x5f\x01\x4e\x00\x96\x02\x4a\x00\xbd\x04\xbe\x04\x40\x01\xa0\x00\x72\x00\xcd\x02\x14\x02\xea\x00\x73\x00\x74\x00\x5b\x01\x5f\x01\xeb\x00\x2e\x04\xed\x01\x8f\x00\x09\x05\xec\x00\xee\x01\x92\x00\x4d\x00\xfc\x01\x94\x00\x95\x00\x96\x00\x97\x00\x57\x00\x13\x01\x98\x00\x99\x00\xdb\x01\x4e\x00\xce\x00\xa1\x00\x06\x01\x0f\x00\xcf\x00\x01\x04\x58\x00\x88\x02\xdf\x04\xe0\x04\x11\x00\x5f\x01\x7c\x00\x7d\x00\xd1\x02\x5c\x00\xa2\x00\x19\x01\x1a\x01\x03\x03\xca\x00\xee\x01\x0f\x01\x4d\x00\x04\x03\x73\x00\x10\x01\x91\x03\xe1\x00\xe2\x00\xe3\x00\x28\x02\xe4\x00\x4d\x00\x4e\x00\xe1\x04\x9e\x00\x9f\x00\x65\x00\x66\x00\x08\x05\x83\x00\x68\x00\x69\x00\x4e\x00\x84\x00\xa0\x00\x72\x00\xe5\x00\x11\x01\x85\x00\x73\x00\x74\x00\x12\x01\x44\x05\xe0\x04\xe6\x00\xe7\x00\x06\x01\x11\x00\xf2\x01\xe8\x00\x13\x01\x19\x01\x1a\x01\xeb\x01\xcb\x00\xee\x01\x0f\x01\x4d\x00\x2b\x02\x73\x00\x10\x01\x8b\x00\x6a\x05\xce\x00\xa1\x00\x94\xfe\x0f\x00\xcf\x00\x4e\x00\xe1\x04\x6b\x05\x2c\x02\x94\xfe\x11\x00\xb6\x01\x7c\x00\x7d\x00\xb7\x01\x0c\x02\xa2\x00\x64\x04\x72\x00\xe9\x00\x11\x01\x41\x01\x73\x00\x74\x00\x12\x01\xee\x01\x94\xfe\x4d\x00\x0d\x02\x0e\x02\x11\x00\xee\x02\x97\x04\x13\x01\x42\x01\x07\x02\x43\x01\x44\x01\x4e\x00\x03\x02\x72\x01\x28\x05\x64\x00\x73\x00\x10\x01\xea\x01\x67\x00\x77\x00\x04\x02\x78\x00\x79\x00\x7a\x00\x04\x02\x7b\x00\x1a\x05\x18\x05\x7e\x00\x7f\x00\x7c\x00\x7d\x00\x98\x04\x99\x04\xd3\x03\xca\x00\xc7\x02\xd4\x03\x63\x02\x0a\x02\x0b\x02\x60\x01\x72\x00\xea\x00\x11\x00\x61\x01\x73\x00\x74\x00\xeb\x00\x94\xfe\x94\xfe\x8f\x00\x13\x01\xec\x00\x94\xfe\x92\x00\xf9\x01\xfa\x01\x94\x00\x95\x00\x96\x00\x97\x00\x7d\x04\x7e\x04\x98\x00\x99\x00\xd5\x03\xff\xff\xf2\x01\x00\x01\x01\x01\x21\x03\x9d\x01\xfb\x01\x02\x01\x94\xfe\xe8\x00\x94\xfe\xf3\x01\xf4\x01\xf5\x01\xcb\x00\x7c\x00\x7d\x00\x22\x03\x23\x03\x94\xfe\x7f\x04\x80\x04\x36\x00\x27\x02\x9a\x04\x4d\x00\x38\x01\xf0\x02\x81\x00\x2b\x01\x3d\x00\x3e\x00\xc4\x04\x3f\x00\x40\x00\x64\x00\x4e\x00\x9e\x00\x9f\x00\x67\x00\x83\x00\xca\x00\x83\x00\x99\xfd\x84\x00\x04\x02\x84\x00\xa0\x00\x72\x00\x85\x00\x41\x00\x85\x00\x73\x00\x74\x00\x39\x01\x3a\x01\x3b\x01\x94\xfe\x93\x03\x2d\x00\xb4\x01\x5e\x01\x24\x04\x42\x00\x4d\x00\xb5\x01\x2e\x00\x5f\x01\x2f\x00\x94\x03\x9a\x04\x41\x00\x8b\x00\x8c\x00\x8b\x00\x4e\x00\xce\x00\xa1\x00\x8e\x00\x0f\x00\xcf\x00\x64\x00\xe8\x00\xc3\x04\x42\x00\x67\x00\x11\x00\xcb\x00\x7c\x00\x7d\x00\x89\x03\x76\x01\xa2\x00\x77\x01\xa3\x02\x81\x04\x04\x02\xac\x02\x8c\x01\xeb\x00\x8d\x01\x8a\x03\x8f\x00\xc9\x03\xa5\x02\x99\x02\x92\x00\x12\x01\x54\x05\x94\x00\x95\x00\x96\x00\x97\x00\x11\x00\xa6\x02\xa7\x02\xa8\x02\x04\x04\x9b\x02\x4e\x00\x87\x03\xee\x04\xe4\x04\x44\x00\x45\x00\x7b\x01\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x88\x03\xef\x04\xe5\x04\x12\x03\xcd\x01\x7a\x00\x13\x03\x7b\x00\x4b\x00\x4c\x00\x4d\x00\x9c\x02\xc6\x04\x44\x00\x45\x00\x13\x05\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4e\x00\x51\x05\xc7\x04\x9e\x00\x9f\x00\x8a\x03\xff\xff\xca\x00\x4b\x00\x4c\x00\x4d\x00\x38\x02\x52\x05\xa0\x00\x72\x00\xa3\x02\xa4\x02\x39\x02\x73\x00\x74\x00\xeb\x00\x4e\x00\x09\x01\x8f\x00\x34\x04\xa5\x02\x0a\x01\x92\x00\x12\x01\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x11\x00\xa6\x02\xa7\x02\xa8\x02\x35\x02\x78\x01\xbf\x01\x10\x00\xce\x00\xa1\x00\x36\x02\x0f\x00\xcf\x00\x11\x00\xe8\x00\xc0\x01\x7d\x00\x6d\x05\x11\x00\xcb\x00\x7c\x00\x7d\x00\x1d\xfd\x6e\x05\xa2\x00\xe8\x03\x5d\x02\x36\x00\x37\x00\xa2\x02\xfd\x01\x3a\x00\x3b\x00\x09\x01\x3c\x00\x3d\x00\x3e\x00\x0a\x01\x3f\x00\x40\x00\xad\x02\xaa\x02\xab\x02\x9f\x00\xff\xff\x60\x01\x72\x00\x3d\x01\x3e\x03\x77\x03\x73\x00\x74\x00\xa0\x00\x72\x00\x11\x00\xdd\x02\x3c\x01\x73\x00\x74\x00\xde\x02\x2e\x03\x1a\x01\x17\x05\x18\x05\x86\x01\x0f\x01\x87\x01\x21\x01\x73\x00\x10\x01\x5e\x02\x5f\x02\x0f\x00\x60\x02\x42\x02\x76\x01\x41\x00\x77\x01\xff\xff\x11\x00\x11\x00\xce\x00\xa1\x00\x3d\x03\x0f\x00\xcf\x00\x7c\x00\x7d\x00\x78\x02\x42\x00\x79\x02\x11\x00\x11\x01\x7c\x00\x7d\x00\x70\x04\x12\x01\xa2\x00\xca\x00\xa3\x02\xa4\x02\x11\x00\x11\x00\x0e\x01\xeb\x00\x13\x01\x75\x02\x8f\x00\x76\x02\xa5\x02\x62\x02\x92\x00\x63\x02\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x11\x00\xa6\x02\xa7\x02\xa8\x02\x87\x04\xc3\x01\x7f\x00\x36\x00\x21\x03\x53\x02\xc4\x01\x43\x00\xf0\x02\x36\x02\x2b\x01\x3d\x00\x3e\x00\x10\x02\x3f\x00\x40\x00\x86\x00\xe8\x00\x26\x01\x78\x02\x88\x00\x79\x02\xcb\x00\xe8\x01\x88\x04\x8e\x04\x1a\x03\x44\x00\x45\x00\x8a\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x18\x03\xa9\x02\xaa\x02\xab\x02\x9f\x00\x6a\x03\x6b\x03\x3c\x02\x4b\x00\x4c\x00\x4d\x00\x36\x02\xff\x02\xa0\x00\x72\x00\xca\x00\x0e\x01\x41\x00\x73\x00\x74\x00\x0f\x01\x4e\x00\xa9\xfe\x73\x00\x10\x01\x41\x00\xa9\xfe\x86\x00\x0f\x03\x63\x01\x42\x00\x88\x00\x0e\x00\xec\x02\x0f\x00\x10\x00\x47\x00\x48\x00\x42\x00\x87\x04\x8a\x00\x11\x00\xce\x00\xa1\x00\x8d\x00\x0f\x00\xcf\x00\x11\x01\xb1\x01\x09\x01\xf7\x03\x12\x01\x11\x00\x0a\x01\x7c\x00\x7d\x00\xe8\x00\x11\x00\xa2\x00\xf3\x02\x13\x01\xcb\x00\x47\x03\x88\x04\x89\x04\x47\x00\x48\x00\xa3\x02\x8a\x04\x4e\x03\x4f\x03\x70\x01\xeb\x00\x0f\x00\x10\x00\x8f\x00\x2c\x04\xa5\x02\x2d\x04\x92\x00\x11\x00\xeb\x02\x94\x00\x95\x00\x96\x00\x97\x00\xea\x02\xa6\x02\xa7\x02\xa8\x02\x44\x00\x45\x00\xe9\x02\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x44\x00\x45\x00\xe6\x01\x65\x04\x47\x00\x48\x00\x47\x00\x48\x00\x4b\x00\x4c\x00\x4d\x00\x7f\x01\xe8\x02\x80\x01\x42\x02\x81\x01\x4b\x00\x23\x04\x4d\x00\x24\x04\x11\x00\x4e\x00\xc0\x01\x7d\x00\x64\x00\xc5\x02\x10\x00\xef\x02\x67\x00\x4e\x00\x9e\x00\x9f\x00\x11\x00\xbe\x02\xc0\x01\x7d\x00\x76\x01\xc4\x01\x77\x01\x41\x00\xa0\x00\x72\x00\xe7\x02\xa3\x02\x8a\x04\x73\x00\x74\x00\xca\x00\xeb\x00\x6a\x03\x6b\x03\x8f\x00\x42\x00\xa5\x02\x72\x03\x92\x00\x63\x02\xe1\x02\x94\x00\x95\x00\x96\x00\x97\x00\x11\x00\xa6\x02\xa7\x02\xa8\x02\xd9\x02\xda\x02\xdb\x02\xce\x00\xa1\x00\xdf\x02\x0f\x00\xcf\x00\x7d\x04\x7e\x04\x5b\x02\x5c\x02\x5d\x02\x11\x00\x4a\x01\x7c\x00\x7d\x00\xd2\x02\xcd\x04\xa2\x00\x63\x02\xd1\x02\xe8\x00\x36\x00\x0a\x02\x0b\x02\x11\x00\xcb\x00\xf0\x02\xcc\x02\x2b\x01\x3d\x00\x3e\x00\x1e\x05\x3f\x00\x40\x00\x25\x05\x26\x05\x9e\x00\x9f\x00\xf7\x02\xf8\x02\xf9\x02\xfa\x02\xfb\x02\x52\x02\x44\x00\x45\x00\xa0\x00\x72\x00\x47\x00\x48\x00\xca\x02\x73\x00\x74\x00\xca\x00\x5e\x02\x5f\x02\x0f\x00\x60\x02\x08\xfd\x57\x00\x4b\x00\x51\x02\x4d\x00\x11\x00\xc2\x01\x98\x01\x7a\x00\xdd\x01\x7b\x00\xc5\x02\x41\x00\x58\x00\xc4\x02\x4e\x00\x81\x00\xce\x00\xa1\x00\x87\x04\x0f\x00\xcf\x00\x5c\x00\xc1\x02\x9e\x02\x42\x00\xc2\x02\x11\x00\x83\x00\x7c\x00\x7d\x00\xc0\x02\x84\x00\xa2\x00\x98\x02\xaf\x02\xe8\x00\x85\x00\x25\x05\x4c\x05\x5f\x01\xcb\x00\x04\x03\x26\x05\x05\x03\x65\x00\x66\x00\xa3\x02\x81\x04\x68\x00\x69\x00\xe1\x03\xeb\x00\xe2\x03\x70\x02\x8f\x00\x9f\x02\xa5\x02\xb3\x02\x92\x00\x8b\x00\x8c\x00\x94\x00\x95\x00\x96\x00\x97\x00\xe0\x01\xa6\x02\xa7\x02\xa8\x02\x86\x00\x08\xfe\x63\x01\x08\xfe\x88\x00\x08\xfe\x7b\x01\x7c\x01\x45\x00\x6f\x02\x5a\x02\x47\x00\x48\x00\x8a\x00\x08\xfe\x44\x00\x45\x00\x8d\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x7d\x01\x95\x02\x4d\x00\xfb\x03\xf4\x03\xf5\x03\x94\x02\xaf\x01\x4b\x00\x4c\x00\x4d\x00\x8f\x02\xe5\x04\x4e\x00\x8d\x02\x9e\x00\x9f\x00\x2c\x02\x7a\x00\xca\x00\x7b\x00\x4e\x00\x0a\x02\x0b\x02\x41\x00\xa0\x00\x72\x00\x84\x02\xa3\x02\x8a\x04\x73\x00\x74\x00\x6a\x01\xeb\x00\x0f\x00\x10\x00\x8f\x00\x42\x00\xa5\x02\x81\x02\x92\x00\x11\x00\x7d\x02\x94\x00\x95\x00\x96\x00\x97\x00\x7a\x02\xa6\x02\xa7\x02\xa8\x02\x5b\x03\x5c\x03\x5d\x03\xce\x00\xa1\x00\x7c\x02\x0f\x00\xcf\x00\x25\x02\xe8\x00\x18\x04\x19\x04\x1a\x04\x11\x00\xcb\x00\x7c\x00\x7d\x00\x6a\x03\x6b\x03\xa2\x00\x78\x03\x7c\x01\x45\x00\x36\x00\xfa\x04\x47\x00\x48\x00\xc7\x01\xe6\x04\xc8\x01\x2b\x01\x3d\x00\x3e\x00\xc9\x01\x3f\x00\x40\x00\x02\x02\x00\x02\x9e\x00\x9f\x00\x73\x02\xc1\x04\xca\x00\xc2\x04\x72\x02\x41\x00\x44\x00\x45\x00\xa0\x00\x72\x00\x47\x00\x48\x00\x71\x02\x73\x00\x74\x00\xff\x01\x00\x02\xcc\x01\x42\x00\x73\x01\xab\x01\x12\x01\x4b\x00\x91\x04\x4d\x00\x92\x04\x74\x04\x11\x00\x75\x04\x7c\x00\x7d\x00\x60\x04\x41\x00\x61\x04\xf5\x04\x4e\x00\xf6\x04\xce\x00\xa1\x00\x70\x02\x0f\x00\xcf\x00\xb1\x01\xe8\x00\x81\x00\x42\x00\x70\x04\x11\x00\xcb\x00\x7c\x00\x7d\x00\x73\x01\x74\x01\xa2\x00\xa3\x02\xa4\x02\x83\x00\x6f\x02\xf9\x04\xeb\x00\x84\x00\x60\x04\x8f\x00\x61\x04\xa5\x02\x85\x00\x92\x00\x23\x02\x3e\x02\x94\x00\x95\x00\x96\x00\x97\x00\x67\x02\xa6\x02\xa7\x02\xa8\x02\x55\x02\x44\x00\x45\x00\x71\x01\x6c\x01\x47\x00\x48\x00\x47\x01\x4f\x03\x50\x03\x51\x03\x8b\x00\x8c\x00\x35\x01\x36\x01\x8e\x00\x8f\x00\x4b\x00\xd6\x01\x4d\x00\xd7\x01\xf3\x03\xf4\x03\xf5\x03\x67\x02\xaf\x01\xaf\x01\x41\x00\x44\x00\x45\x00\x4e\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x1e\x01\x1f\x01\x9e\x00\x9f\x00\x42\x00\x52\x02\xca\x00\x54\x02\x4b\x00\x4c\x00\x4d\x00\x42\x02\xa0\x00\x72\x00\x3d\x02\xa3\x02\xa4\x02\x73\x00\x74\x00\x51\x02\xeb\x00\x4e\x00\x4f\x02\x8f\x00\xca\x00\xa5\x02\x34\x02\x92\x00\x6e\x01\x6c\x01\x94\x00\x95\x00\x96\x00\x97\x00\x41\x02\xa6\x02\xa7\x02\xa8\x02\x13\x04\x14\x04\x15\x04\xce\x00\xa1\x00\x2f\x02\x0f\x00\xcf\x00\xba\x02\xe8\x00\x0f\x00\x10\x00\x81\x00\x11\x00\xcb\x00\x7c\x00\x7d\x00\x11\x00\x23\x02\xa2\x00\xc6\x01\xc2\x01\x98\x01\x7a\x00\x83\x00\x7b\x00\x44\x00\x45\x00\x84\x00\x2e\x02\x47\x00\x48\x00\xcb\x00\x85\x00\xb5\x02\x10\x02\x0f\x00\x10\x00\x9e\x00\x9f\x00\x6b\x01\x6c\x01\x4b\x00\x11\x00\x4d\x00\x5e\x01\x73\x03\x74\x03\xa0\x00\x72\x00\x26\x03\x5f\x01\x81\x00\x73\x00\x74\x00\x4e\x00\x8b\x00\x8c\x00\x96\x02\x4a\x00\x8e\x00\x8f\x00\x73\x01\x1e\x04\x83\x00\xa1\x04\x19\x04\x1a\x04\x84\x00\x22\x05\x92\x04\x19\x04\x1a\x04\x85\x00\xd6\x04\x19\x04\x1a\x04\xce\x00\xa1\x00\xfe\x00\x0f\x00\xcf\x00\x78\x05\x19\x04\x1a\x04\x5e\x01\x02\x02\x11\x00\xd6\x03\x7c\x00\x7d\x00\x5f\x01\xd0\x03\xa2\x00\xa3\x02\x07\x04\x8b\x00\x8c\x00\xc4\x03\xeb\x00\x8e\x00\x8f\x00\x8f\x00\xcd\x03\xa5\x02\xc3\x03\x92\x00\x08\x04\x09\x04\x94\x00\x95\x00\x96\x00\x97\x00\xea\xfc\xa6\x02\xa7\x02\xa8\x02\xcc\x00\xbe\x04\xba\x04\x8f\x00\x07\xfd\xcd\x00\xf1\xfc\x92\x00\xb9\x04\xba\x04\x94\x00\x95\x00\x96\x00\x97\x00\x36\x00\xf2\xfc\x98\x00\x99\x00\x1f\x02\xf0\x02\x06\xfd\x2b\x01\x3d\x00\x3e\x00\xeb\xfc\x3f\x00\x40\x00\xec\xfc\xc2\x01\x98\x01\x7a\x00\x40\x02\x7b\x00\x85\x04\x5d\x03\xc3\x01\x7f\x00\xc2\x03\x9e\x00\x9f\x00\xc4\x01\x32\x01\x33\x01\x34\x01\x35\x01\x58\x05\x59\x05\x1d\x05\xa0\x00\x72\x00\x7d\x05\x19\x04\x1a\x04\x73\x00\x74\x00\x41\x00\x9e\x00\x9f\x00\x2c\x02\x7a\x00\xc1\x03\x7b\x00\xc0\x03\x41\x00\xbf\x03\xbe\x02\xa0\x00\x72\x00\x42\x00\xc4\x01\xbe\x03\x73\x00\x74\x00\xd7\x04\x15\x04\x18\xfd\x42\x00\xce\x00\xa1\x00\xbb\x03\x0f\x00\xcf\x00\xb9\x03\xba\x03\x5f\x01\x3a\x02\x37\x02\x11\x00\x90\x03\x7c\x00\x7d\x00\x85\x03\x84\x03\xa2\x00\x8f\x03\xce\x00\xa1\x00\x83\x03\x0f\x00\xcf\x00\x81\x03\x80\x03\x82\x03\x7f\x03\x7a\x03\x11\x00\x5f\x05\x7c\x00\x7d\x00\x36\x00\x7e\x03\xa2\x00\x77\x03\x7d\x03\xf0\x02\x76\x03\x2b\x01\x3d\x00\x3e\x00\x5b\x01\x3f\x00\x40\x00\x1c\xfd\x60\x03\x5b\x03\x59\x03\x58\x03\x56\x03\x44\x00\x45\x00\x4c\x03\x8a\x00\x47\x00\x48\x00\x2b\x03\x2a\x03\x44\x00\x45\x00\x29\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x21\x01\x4d\x00\x26\x03\x81\x00\x3d\x01\x32\x03\xfe\x00\x4b\x00\x4c\x00\x4d\x00\x04\x04\x59\x04\x4e\x00\x41\x00\x4b\x04\x83\x00\x47\x04\x4a\x04\x48\x04\x84\x00\x4e\x00\x3c\x04\x3a\x04\x36\x00\x85\x00\x42\x04\x42\x00\x39\x04\xf0\x02\x34\x04\x2b\x01\x3d\x00\x3e\x00\x81\x00\x3f\x00\x40\x00\x38\x04\x36\x04\x12\xfd\x11\xfd\x13\xfd\x32\x04\x21\x04\x47\x01\x27\x04\x83\x00\x66\x03\x8b\x00\x8c\x00\x84\x00\x1e\x04\x8e\x00\x8f\x00\x1c\x04\x85\x00\x17\x04\x36\x00\x0f\x04\x11\x04\x3a\x02\x3e\x01\x3f\x01\x0d\x04\x3c\x00\x3d\x00\x3e\x00\x6a\x00\x3f\x00\x40\x00\x3f\x02\xf8\x03\x8e\x02\x41\x00\x47\x01\xd3\x02\xf0\x03\xdf\x03\x8b\x00\x8c\x00\x04\x04\xfa\x03\x8e\x00\x8f\x00\xf2\x03\xe7\x03\x42\x00\x44\x00\x45\x00\xe6\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xdc\x03\x62\x04\xde\x03\xdd\x03\xb9\x04\xb8\x04\xb7\x04\x66\x03\x4b\x00\x4c\x00\x4d\x00\x41\x00\x6f\x02\x83\x00\xb1\x01\x6b\x03\xaf\x04\x84\x00\x5d\x04\x8b\x03\xa8\x04\x4e\x00\x85\x00\xa7\x04\x42\x00\xa6\x04\x1e\x04\x1c\x04\xa5\x04\xa1\x04\x1c\x04\x7d\x04\x36\x00\x73\x04\x78\x04\x6a\x04\x3e\x01\x3f\x01\x6e\x04\x3c\x00\x3d\x00\x3e\x00\x6f\x04\x3f\x00\x40\x00\x8b\x00\x63\x04\x6b\x04\x69\x04\x8e\x00\x64\x04\x44\x00\x45\x00\x04\x04\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x5d\x04\x29\x03\x08\x05\x07\x05\x4e\x05\x06\x05\xfd\x04\x36\x00\x4b\x00\x4c\x00\x4d\x00\x6c\x03\x6d\x03\xf8\x04\x3c\x00\x3d\x00\x3e\x00\xf7\x04\x3f\x00\x40\x00\xf1\x04\x4e\x00\x41\x00\xec\x04\x3b\x01\x44\x00\x45\x00\xda\x04\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x1c\x04\xd9\x04\x42\x00\x81\x00\x79\x01\x8f\xfe\x17\x04\xd0\x04\x4b\x00\x4c\x00\x4d\x00\x0e\x01\x38\x05\x36\x05\x31\x05\x83\x00\x2d\x05\x30\x05\x2c\x05\x84\x00\x2a\x05\x4e\x00\x36\x00\x41\x00\x85\x00\x28\x05\x6c\x03\x6d\x03\x4a\x01\x3c\x00\x3d\x00\x3e\x00\x10\x05\x3f\x00\x40\x00\x0d\x05\x42\x00\x0e\x05\x0b\x05\x56\x05\x57\x05\x50\x05\x5b\x03\x47\x01\x46\x05\x26\x03\x6c\x05\x8b\x00\x8c\x00\x67\x05\x7c\x05\x8e\x00\x8f\x00\x64\x05\x26\x03\x5f\x05\x1e\x04\x1c\x04\x77\x05\x81\x05\x1c\x04\xfe\x00\x44\x00\x45\x00\x82\x05\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x7d\x05\x41\x00\xfc\x00\x84\x05\xc1\x01\x84\x01\x79\x01\xa9\x01\x4b\x00\x4c\x00\x4d\x00\x36\x00\xf7\x01\x06\x02\x42\x00\xd4\x04\xd5\x04\x47\x01\x3c\x00\x3d\x00\x3e\x00\x4e\x00\x3f\x00\x40\x00\x05\x02\x26\x01\x44\x00\x45\x00\x8d\x01\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x8a\x01\x30\x01\x0c\x01\x1c\x03\x1a\x03\x0b\x01\x18\x03\x1b\x03\x4b\x00\x4c\x00\x4d\x00\x36\x00\x37\x00\xd3\x01\x39\x00\x3a\x00\x3b\x00\x07\x01\x3c\x00\x3d\x00\x3e\x00\x4e\x00\x3f\x00\x40\x00\x0f\x03\x09\x03\x41\x00\xd4\x01\xd5\x01\xf7\x01\xfb\x02\xf5\x02\xb6\x02\xdf\x02\xd2\x02\x88\x02\xc2\x02\x76\x02\x0b\x02\x42\x00\x44\x00\x45\x00\x73\x02\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x6d\x02\x08\x02\x10\x02\xda\x03\xd9\x03\xd7\x03\xd8\x03\x21\x03\x4b\x00\x4c\x00\x4d\x00\xd6\x03\x41\x00\xd1\x03\x5e\x03\x36\x00\x37\x00\x43\x02\x39\x00\x3a\x00\x3b\x00\x4e\x00\x3c\x00\x3d\x00\x3e\x00\x42\x00\x3f\x00\x40\x00\xbc\x03\x94\x03\x56\x03\x6b\x02\x90\x03\x8c\x03\x36\x00\x37\x00\xd9\x01\x39\x00\x3a\x00\x3b\x00\x8b\x03\x3c\x00\x3d\x00\x3e\x00\x59\x03\x3f\x00\x40\x00\x54\x03\x35\x03\x4c\x03\x33\x03\x44\x00\x45\x00\x30\x03\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x3d\x03\x81\x00\x46\x01\xaa\xfe\x32\x03\x41\x00\x43\x00\xaa\xfe\x4b\x00\x4c\x00\x4d\x00\x2b\x03\x27\x03\x83\x00\x26\x03\x24\x03\x5b\x04\x84\x00\x42\x00\x48\x04\x30\x04\x4e\x00\x85\x00\x3a\x04\x41\x00\x2d\x04\x44\x00\x45\x00\x2a\x04\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x21\x04\x1f\x04\x1c\x04\x42\x00\x02\x04\xfa\x03\xdf\x03\x47\x01\x4b\x00\x4c\x00\x4d\x00\x8b\x00\x8c\x00\xf2\x03\xc2\x04\x8e\x00\x8f\x00\xbf\x04\xb3\x04\xb1\x04\x6b\x02\x4e\x00\xa2\x04\x86\x04\x43\x00\x9a\x04\x7b\x04\x6b\x04\x6c\x04\x67\x04\xd6\x01\x66\x04\xd7\x01\x5e\x04\x5d\x04\xfe\x04\xf3\x04\xf2\x04\xef\x04\xf1\x04\xdd\x04\xec\x04\xcc\x04\x43\x00\x44\x00\x45\x00\xea\x04\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xcb\x04\x38\x05\xca\x04\x36\x05\x33\x05\x1c\x05\x23\x05\x2a\x05\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x32\x05\x46\x00\x47\x00\x48\x00\xda\x01\x4a\x00\x2c\x02\x7a\x00\x4e\x00\x7b\x00\x0e\x05\x13\x05\xc3\x01\x7f\x00\x4b\x00\x4c\x00\x4d\x00\xc4\x01\x4d\x05\x4a\x05\x40\x05\x36\x00\x37\x00\xd9\x01\x39\x00\x3a\x00\x3b\x00\x4e\x00\x3c\x00\x3d\x00\x3e\x00\x57\x05\x3f\x00\x40\x00\x7b\x03\x67\x01\xdb\x01\x68\x01\x3f\x05\x0b\x05\x53\x05\x0f\x01\x52\x05\x65\x05\x73\x00\x10\x01\x79\x05\xda\x04\xe4\x02\x75\x05\x71\x05\x36\x00\x37\x00\x6f\x05\xe5\x02\x3a\x00\x3b\x00\x7f\x05\x3c\x00\x3d\x00\x3e\x00\x7e\x05\x3f\x00\x40\x00\x82\x05\xdb\x04\x00\x00\x00\x00\x11\x01\x00\x00\x41\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x13\x01\x00\x00\x42\x00\x00\x00\x00\x00\xda\x04\xe4\x02\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xe5\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x41\x00\x3f\x00\x40\x00\x00\x00\x43\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\xe3\x02\xe4\x02\x00\x00\x00\x00\x36\x00\x37\x00\x43\x00\xe5\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\x41\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\xda\x01\x4a\x00\x00\x00\x42\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\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\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xdb\x01\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x43\x00\xb3\x02\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x4e\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\xeb\x02\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\x43\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\x44\x00\x45\x00\x41\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\x42\x00\x4b\x00\x4c\x00\x4d\x00\x48\x03\xe4\x02\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xe5\x02\x3a\x00\x3b\x00\x4e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x02\x00\x00\x00\x00\x36\x00\x37\x00\x43\x00\xa0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\xb4\x02\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x42\x00\x00\x00\x81\x00\x46\x01\x00\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\x41\x00\x84\x00\x4e\x00\x00\x00\xb3\x02\x00\x00\x85\x00\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x42\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x29\x04\x00\x00\x00\x00\x43\x00\x00\x00\x47\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\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\x43\x00\x00\x00\x00\x00\x41\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\x42\x00\x00\x00\x00\x00\x4e\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\x36\x00\x4b\x00\x4c\x00\x4d\x00\x9c\x04\x00\x00\x00\x00\x9d\x04\x9e\x04\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x4e\x00\x00\x00\x0a\x04\x00\x00\x0d\x04\x36\x00\x37\x00\x43\x00\xa0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x9f\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4e\x00\x00\x00\x0a\x04\x00\x00\x0b\x04\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x42\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x0a\x04\x00\x00\xd3\x04\x36\x00\x37\x00\x00\x00\xa0\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x41\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\x42\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x41\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\x42\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\x9f\x02\x00\x00\x00\x00\x36\x00\x37\x00\x43\x00\xd4\x02\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x41\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x9f\x02\x00\x00\x00\x00\x36\x00\x37\x00\x4e\x00\xa0\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\x3c\x03\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa0\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\xc7\x01\x00\x00\xc8\x01\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\xca\x01\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\xcb\x01\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x00\x00\xcc\x01\x00\x00\x00\x00\x41\x00\x12\x01\x4b\x00\x4c\x00\x4d\x00\xcd\x01\x7a\x00\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x42\x00\x00\x00\x4e\x00\x05\x04\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa0\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\x76\x04\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa0\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\x41\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\x42\x01\x4e\x00\x43\x01\x44\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\xf8\x04\x7e\x00\x7f\x00\x36\x00\x37\x00\x00\x00\xa0\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\x4c\x05\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa0\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\x8e\x01\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x64\x05\x00\x00\x00\x00\x36\x00\x37\x00\x00\x00\xa0\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\x8f\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\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\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\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\x4b\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\xe2\x02\x4d\x02\x00\x00\x43\x00\x36\x00\x37\x00\x4b\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\x4c\x02\x4d\x02\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\x41\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\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x41\x00\x00\x00\x00\x00\x36\x00\x37\x00\x4b\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\xc8\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\x43\x00\x36\x00\x37\x00\x4b\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\xc7\x03\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\x41\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\x42\x00\x00\x00\x00\x00\x81\x00\x21\x05\x4e\x00\x00\x00\x00\x00\x43\x00\x36\x00\x37\x00\xc5\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\xc6\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\x43\x00\x00\x00\x00\x00\x47\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\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\x4b\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\x00\x00\xc4\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\x43\x00\x00\x00\x36\x00\x37\x00\x4b\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\x41\x00\xe7\x03\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\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\x41\x00\x00\x00\x00\x00\x36\x00\x37\x00\x32\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\x43\x00\x00\x00\x00\x00\x00\x00\x46\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x01\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\xcf\x02\x00\x00\x43\x01\x44\x01\x00\x00\x41\x00\x43\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x42\x00\x7b\x00\x00\x00\x4e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x43\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x41\x01\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\x01\x00\x00\x43\x01\x44\x01\x00\x00\x00\x00\x00\x00\x47\x05\x4c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x4e\x00\x41\x00\x7e\x00\x7f\x00\x36\x00\x37\x00\xde\x01\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\x00\x00\x36\x00\x37\x00\x87\x01\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x01\x64\x01\x65\x01\x66\x01\x67\x01\x00\x00\x68\x01\x41\x00\x43\x00\x00\x00\x0f\x01\x00\x00\x00\x00\x73\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x11\x01\x00\x00\x42\x00\x00\x00\x12\x01\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x11\x00\x00\x00\x00\x00\x13\x01\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\x1c\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\x43\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x1d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x41\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\x42\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x36\x00\x37\x00\x49\x03\x39\x00\x3a\x00\x3b\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x37\x00\x32\x04\x39\x00\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\x1c\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\x1c\x02\x3a\x00\x3b\x00\x2f\x04\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\x28\x04\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\x1c\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\x1c\x02\x3a\x00\x3b\x00\x27\x04\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\x17\x04\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\x1c\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\x1c\x02\x3a\x00\x3b\x00\xe4\x03\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\xe3\x03\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\x14\x05\x39\x00\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\x1c\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\x49\x05\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\x59\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\x26\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\x21\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\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\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\x1e\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\xd0\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\xca\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\x10\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\x00\x00\xee\x02\x00\x00\x2b\x01\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\xe1\x02\x00\x00\x2b\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\x60\x03\x00\x00\x2b\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\xa3\x04\x00\x00\x2b\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\x78\x04\x00\x00\x2b\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\x21\x05\x00\x00\x2b\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\x1f\x05\x00\x00\x2b\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\x42\x05\x00\x00\x2b\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\x00\x00\x00\x00\x00\x00\x2d\x05\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x01\x3e\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x2e\x05\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x13\x00\x41\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x15\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x24\x02\x3e\x00\x00\x00\x3f\x00\x40\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x00\x00\x7a\x03\x65\x01\x66\x01\x67\x01\x00\x00\x68\x01\x00\x00\x00\x00\x4e\x00\x0f\x01\x00\x00\x00\x00\x73\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x02\x1a\x02\x75\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x02\x00\x00\x00\x00\x00\x00\x11\x01\x00\x00\x00\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x44\x00\x45\x00\x13\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\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\x00\x00\x4e\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfc\xf9\xfc\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfc\xf9\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xdb\xfd\xdb\xfd\x13\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\x14\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\x00\x00\x00\x00\xdb\xfd\x15\x00\xdb\xfd\x00\x00\xdb\xfd\xdb\xfd\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\xdb\xfd\xdb\xfd\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xdb\xfd\x00\x00\x24\x00\xdb\xfd\xdb\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\xdb\xfd\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\xdb\xfd\x7f\x01\xdb\xfd\x80\x01\xdb\xfd\x81\x01\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x63\x00\x64\x00\xdb\xfd\xdb\xfd\xdb\xfd\x67\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x8e\xfe\x50\x00\x13\x00\x8e\xfe\x00\x00\x00\x00\x00\x00\x8e\xfe\x8e\xfe\x14\x00\x8e\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\xfe\x8e\xfe\x00\x00\x00\x00\x8e\xfe\x15\x00\x8e\xfe\x00\x00\x8e\xfe\x8e\xfe\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\x8e\xfe\x8e\xfe\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x8e\xfe\x00\x00\x24\x00\x8e\xfe\x8e\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\x8e\xfe\x8e\xfe\x57\x00\x8e\xfe\x8e\xfe\x8e\xfe\x00\x00\x00\x00\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x00\x00\x8e\xfe\x58\x00\x59\x00\x5a\x00\x8e\xfe\x5b\x00\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x5c\x00\x00\x00\x00\x00\xf7\x01\x8e\xfe\x5d\x00\x8e\xfe\x00\x00\x8e\xfe\x5e\x00\x8e\xfe\x5f\x00\x8e\xfe\x60\x00\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x8e\xfe\x67\x00\x68\x00\x69\x00\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x6b\x00\x6c\x00\x6d\x00\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x8e\xfe\x6e\x00\x8e\xfe\x8e\xfe\x6f\x00\x70\x00\x8e\xfe\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x00\x00\x00\x00\x00\x00\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\xfe\x94\xfe\x00\x00\x00\x00\x94\xfe\x94\xfe\x94\xfe\x00\x00\x94\xfe\x94\xfe\x00\x00\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x00\x00\x94\xfe\x94\xfe\x94\xfe\x00\x00\x00\x00\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\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\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x00\x00\x00\x00\x94\xfe\x94\xfe\xf9\x01\xfa\x01\x00\x00\x95\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x00\x00\x00\x00\x94\xfe\xfb\x01\x00\x00\x94\xfe\x00\x00\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x94\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x11\xfe\x11\xfe\x11\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\xfe\x00\x00\x00\x00\x11\xfe\x11\xfe\x11\xfe\x00\x00\x11\xfe\x11\xfe\x00\x00\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x00\x00\x11\xfe\x11\xfe\x11\xfe\x00\x00\x00\x00\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\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\x11\xfe\x11\xfe\x81\x00\xbb\x01\x11\xfe\x11\xfe\x00\x00\x00\x00\x11\xfe\x11\xfe\x11\xfe\x00\x00\x00\x00\x00\x00\x83\x00\x11\xfe\x11\xfe\x11\xfe\x84\x00\xbc\x01\xbd\x01\xbe\x01\xbf\x01\x85\x00\x00\x00\x00\x00\x11\xfe\x00\x00\x00\x00\x11\xfe\x00\x00\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x47\x01\x11\xfe\x11\xfe\x11\xfe\x8b\x00\x8c\x00\x11\xfe\x11\xfe\x8e\x00\x8f\x00\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x11\xfe\x0a\xfe\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\xfe\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x0a\xfe\x15\x00\x0a\xfe\x00\x00\x0a\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\x0a\xfe\x0a\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\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\xad\x00\x00\x00\x00\x00\x0a\xfe\x0a\xfe\x0a\xfe\x00\x00\x00\x00\x00\x00\x0a\xfe\xaf\x00\xb0\x00\xb1\x00\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\x00\x00\x00\x00\xb9\x01\x00\x00\x00\x00\x0a\xfe\x00\x00\x0a\xfe\xb2\x00\x0a\xfe\xb3\x00\x0a\xfe\xb4\x00\x0a\xfe\xb5\x00\x0a\xfe\x0a\xfe\x0a\xfe\x0a\xfe\xb6\x00\x2c\x00\x8a\x00\x0a\xfe\x0a\xfe\x2d\x00\x8d\x00\x0a\xfe\x0a\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\x0a\xfe\xc8\x00\x0a\xfe\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x0a\xfe\x0b\xfe\xa5\x00\x13\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\xfe\x14\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x0b\xfe\x15\x00\x0b\xfe\x00\x00\x0b\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\x0b\xfe\x0b\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\x0b\xfe\x0b\xfe\x0b\xfe\x0b\xfe\x0b\xfe\xad\x00\x00\x00\x00\x00\x0b\xfe\x0b\xfe\x0b\xfe\x00\x00\x00\x00\x00\x00\x0b\xfe\xaf\x00\xb0\x00\xb1\x00\x0b\xfe\x0b\xfe\x0b\xfe\x0b\xfe\x0b\xfe\x0b\xfe\x00\x00\x00\x00\xb9\x01\x00\x00\x00\x00\x0b\xfe\x00\x00\x0b\xfe\xb2\x00\x0b\xfe\xb3\x00\x0b\xfe\xb4\x00\x0b\xfe\xb5\x00\x0b\xfe\x0b\xfe\x0b\xfe\x0b\xfe\xb6\x00\x2c\x00\x8a\x00\x0b\xfe\x0b\xfe\x2d\x00\x8d\x00\x0b\xfe\x0b\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\x0b\xfe\xc8\x00\x0b\xfe\x6e\x00\xc9\x00\xca\x00\x6f\x00\x70\x00\x0b\xfe\x12\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\x13\x02\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xac\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\x12\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\x96\xfd\x00\x00\x96\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\x13\x02\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb4\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\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x5b\xfe\x00\x00\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x00\x00\x80\xfe\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x13\x00\xa6\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\x80\xfe\x14\x00\xa7\x00\x80\xfe\x80\xfe\xd1\x00\xd2\x00\xd3\x00\xf2\x00\xd4\x00\x00\x00\xf3\x00\x00\x00\x15\x00\x00\x00\xf4\x00\x00\x00\x16\x00\xf5\x00\x17\x00\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\xf6\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\xf7\x00\xda\x00\xf8\x00\xf9\x00\x00\x00\x00\x00\xfa\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\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfc\xf9\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xfc\x00\x00\x00\x00\x00\x00\xf9\xfc\x00\x00\x00\x00\x00\x00\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xad\x04\xae\x04\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\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\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\x00\x00\x00\x00\xf9\xfc\x00\x00\x00\x00\x00\x00\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\x00\x00\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\x00\x00\xf9\xfc\x00\x00\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\x00\x00\xf9\xfc\x00\x00\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xf9\xfc\xa5\x00\x13\x00\xa6\x00\x00\x00\x8c\x04\x8d\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\x8e\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\xf6\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\x83\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\xf3\x00\x00\x00\x15\x00\x00\x00\x84\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\xf6\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\x8c\x04\x8d\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\x8e\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\xf6\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\x83\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\xf3\x00\x00\x00\x15\x00\x00\x00\x84\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\xf6\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\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\xaf\x00\xb0\x00\xb1\x00\x84\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\xb2\x00\x00\x00\xb3\x00\x5e\x01\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x5f\x01\x60\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\xe1\xfd\xe1\xfd\xe1\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfd\xe1\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfd\x00\x00\x00\x00\x00\x00\xe1\xfd\x00\x00\x00\x00\x00\x00\xe1\xfd\x00\x00\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\x00\x00\xe1\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\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\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\x00\x00\x00\x00\xe1\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfd\x00\x00\xe1\xfd\xe1\xfd\x00\x00\xe1\xfd\x00\x00\x00\x00\x00\x00\xe1\xfd\x00\x00\xe1\xfd\x00\x00\xe1\xfd\x00\x00\xe1\xfd\x00\x00\x00\x00\x00\x00\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\x00\x00\xe1\xfd\x00\x00\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe1\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\xe0\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\x00\x00\x00\x00\x00\x00\xe0\xfd\x00\x00\x00\x00\x00\x00\xe0\xfd\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\xe0\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\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\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\x00\x00\xe0\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfd\x00\x00\xe0\xfd\xe0\xfd\x00\x00\xe0\xfd\x00\x00\x00\x00\x00\x00\xe0\xfd\x00\x00\xe0\xfd\x00\x00\xe0\xfd\x00\x00\xe0\xfd\x00\x00\x00\x00\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\x00\x00\xe0\xfd\x00\x00\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xe0\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\x00\x00\x00\x00\x00\x00\xed\xfd\x00\x00\x00\x00\x00\x00\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\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\xed\xfd\xed\xfd\x8b\x03\xed\xfd\x00\x00\x00\x00\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xed\xfd\x00\x00\xed\xfd\xed\xfd\x00\x00\xed\xfd\x00\x00\x00\x00\x00\x00\xed\xfd\x00\x00\xed\xfd\x00\x00\xed\xfd\x00\x00\xed\xfd\x00\x00\x00\x00\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\xfd\x00\x00\xed\xfd\x00\x00\xed\xfd\xed\xfd\xed\xfd\xed\xfd\xed\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\x5b\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\x98\x01\xb5\x00\x00\x00\x00\x00\x5f\x01\x60\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\xbb\xfd\xb4\x00\xbb\xfd\xb5\x00\x00\x00\x00\x00\x36\x02\x60\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\x50\x02\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x36\x02\x60\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\xf6\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\x53\x02\xb5\x00\x00\x00\x00\x00\x36\x02\x60\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\xf6\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\x9d\x01\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x60\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\x3a\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\x60\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\x60\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\xb1\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\xb2\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\xae\x03\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xac\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\xa2\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\xac\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\xa2\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\xfe\x03\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\xbd\x02\x65\x01\x66\x01\x67\x01\x00\x00\x68\x01\x00\x00\x00\x00\x00\x00\x0f\x01\x00\x00\x00\x00\x73\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\xa5\x01\xa6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xb0\x00\xb1\x00\x11\x01\x00\x00\x00\x00\x00\x00\x12\x01\x00\x00\x00\x00\x00\x00\x2c\x02\x7a\x00\x11\x00\x7b\x00\x00\x00\x13\x01\xb2\x00\xbe\x02\xb3\x00\x00\x00\xb4\x00\xc4\x01\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\xd7\xfe\xd7\xfe\xd7\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfe\xd7\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfe\x00\x00\x00\x00\x00\x00\xd7\xfe\x00\x00\x00\x00\x00\x00\xd7\xfe\x00\x00\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\x00\x00\xd7\xfe\x00\x00\x00\x00\x00\x00\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\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\xd7\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfe\xd7\xfe\xd7\xfe\xd7\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\x07\x03\x00\x00\xd7\xfe\x00\x00\xd7\xfe\x00\x00\xd7\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xd7\xfe\xd7\xfe\xd7\xfe\x00\x00\x00\x00\xd7\xfe\xd7\xfe\x00\x00\x00\x00\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\x00\x00\xd7\xfe\x00\x00\xd7\xfe\xd7\xfe\xd7\xfe\xd7\xfe\xd7\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\xb6\x03\x00\x00\x00\x00\xb2\x00\x00\x00\xb3\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\xb4\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\xce\xfe\xce\xfe\xce\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfe\xce\xfe\x19\x02\x1a\x02\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfe\x00\x00\x00\x00\x00\x00\xce\xfe\x00\x00\x00\x00\x1b\x02\x37\x03\x00\x00\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\x00\x00\xce\xfe\x00\x00\x00\x00\x00\x00\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\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\xce\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfe\xce\xfe\xce\xfe\xce\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\xce\xfe\x00\x00\xce\xfe\x00\x00\xce\xfe\x00\x00\xce\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xce\xfe\xce\xfe\xce\xfe\x00\x00\x00\x00\xce\xfe\xce\xfe\x00\x00\x00\x00\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\xfe\x00\x00\xce\xfe\x00\x00\xce\xfe\xce\xfe\xce\xfe\xce\xfe\xce\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\x96\xfd\x00\x00\x96\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\xcf\xfe\xcf\xfe\xcf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfe\xcf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfe\x00\x00\x00\x00\x00\x00\xcf\xfe\x00\x00\x00\x00\x00\x00\xfc\x04\x00\x00\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\x00\x00\xcf\xfe\x00\x00\x00\x00\x00\x00\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\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\xcf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfe\xcf\xfe\xcf\xfe\xcf\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\xcf\xfe\x00\x00\xcf\xfe\x00\x00\xcf\xfe\x00\x00\xcf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xcf\xfe\xcf\xfe\xcf\xfe\x00\x00\x00\x00\xcf\xfe\xcf\xfe\x00\x00\x00\x00\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\x00\x00\xcf\xfe\x00\x00\xcf\xfe\xcf\xfe\xcf\xfe\xcf\xfe\xcf\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\xca\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\x98\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\x19\x02\x1a\x02\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x1b\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\xb4\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\x19\x02\x1a\x02\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x1b\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\x52\x00\x53\x00\x54\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\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x00\x00\x63\x00\x64\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x00\x00\x00\x00\x00\x00\x43\xfd\x00\x00\x43\xfd\x37\x02\x43\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x43\xfd\x00\x00\x43\xfd\x43\xfd\x43\xfd\x80\xfe\x80\xfe\x00\x00\x00\x00\x43\xfd\x43\xfd\x43\xfd\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x43\xfd\x00\x00\x00\x00\x43\xfd\x43\xfd\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\xd0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x80\xfe\x00\x00\x80\xfe\x80\xfe\x80\xfe\x00\x00\x00\x00\xa5\x00\x13\x00\x80\xfe\x80\xfe\x80\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\x80\xfe\x15\x00\x00\x00\x80\xfe\x80\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\xc7\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\xdd\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\xde\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\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\x5b\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\xd9\x01\x00\x00\x00\x00\x00\x00\x5f\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\xdd\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\xde\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\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\x45\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x02\x59\x00\x5a\x00\x00\x00\x47\x02\x00\x00\x00\x00\x00\x00\x00\x00\x48\x02\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x5f\x00\x5e\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x61\x00\x62\x00\x63\x00\x64\x00\x49\x02\x4a\x02\x00\x00\x67\x00\x68\x00\x4b\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\xe0\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\x50\x00\x13\x00\x6a\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\x2e\x01\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\x2f\x01\x30\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\xe8\x04\x00\x00\x00\x00\x00\x00\x6e\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xf2\x02\x00\x00\x17\x00\x18\x00\x19\x00\x52\x00\x53\x00\x54\x00\xe9\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\xf2\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\x1c\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\xf2\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\x1a\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\x49\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\xf2\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\x6f\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\xf2\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\x6f\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\xf2\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\xe8\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\xe6\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\x46\x03\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x43\x03\x44\x03\x45\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\xe6\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\x46\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x03\xa6\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\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\x46\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\xa7\x03\xa5\x03\xa6\x03\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\xa8\x03\x00\x00\xa9\x03\x00\x00\xaa\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\xa5\x03\xa6\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\xac\x03\x00\x00\xa9\x03\x00\x00\xaa\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\xa5\x03\xa6\x03\x11\xfe\x81\x00\xbb\x01\x00\x00\x00\x00\xa3\x00\x00\x00\x11\xfe\xf8\x03\x11\xfe\xa9\x03\x00\x00\xaa\x03\x83\x00\x00\x00\x9e\x00\x9f\x00\x84\x00\xbc\x01\xbd\x01\xbe\x01\xbf\x01\x85\x00\x00\x00\x00\x00\xa0\x00\x72\x00\x00\x00\x11\xfe\x8f\x00\x73\x00\x74\x00\x11\xfe\x00\x00\x11\xfe\x00\x00\x11\xfe\xa1\x01\x96\x00\x97\x00\x11\xfe\x47\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\xa2\x01\xae\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\xaf\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\xa1\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\xaf\x03\xa2\x01\xae\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x03\x00\x00\xb1\x03\x00\x00\xb2\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\xa1\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\xa2\x01\xae\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xb4\x03\x00\x00\xb1\x03\x00\x00\xb2\x03\x9e\x00\x9f\x00\xa1\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\xa2\x01\xae\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\xf0\x03\x00\x00\xb1\x03\x00\x00\xb2\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\xb2\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\xcf\x01\x00\x00\xd0\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\xd1\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\x54\x04\x00\x00\x00\x00\x15\x00\x00\x00\x55\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\x56\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\x54\x04\x00\x00\x00\x00\x15\x00\x00\x00\x55\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\x56\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\x57\x04\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\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\x57\x04\x1c\xfe\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x1c\xfe\x00\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x91\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\x6e\x01\x00\x00\x1c\xfe\x14\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x1c\xfe\x00\x00\x15\x00\x1c\xfe\x1c\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\x55\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\x91\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\x05\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\x57\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\xcf\x01\x00\x00\xd0\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\x1c\xfe\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x01\x00\x00\x2c\x00\x8a\x00\x00\x00\x1c\xfe\x2d\x00\x8d\x00\x00\x00\x1c\xfe\x00\x00\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x00\x00\x00\x00\x1c\xfe\x00\x00\x6e\x01\x00\x00\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x1c\xfe\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x1c\xfe\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\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\x6e\x01\x00\x00\x1c\xfe\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x13\x00\x1c\xfe\x00\x00\x00\x00\x00\x00\x1c\xfe\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x02\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\x2b\x00\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\x2d\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\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\x8f\x00\x00\x00\x00\x00\xd5\x02\xd6\x02\x81\x00\xd7\x02\x94\x00\x95\x00\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\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\x00\x00\x6a\x01\x5e\x01\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x01\x00\x00\x00\x00\x2c\x00\x8a\x00\x8b\x00\x8c\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\x66\x03\xd6\x02\x00\x00\xd7\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\xd8\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\x4a\x01\x4b\x01\x00\x00\x92\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x4c\x01\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x01\x4e\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\xd8\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\x4f\x01\x00\x00\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\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x54\x01\x98\x01\x56\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x57\x01\x7f\x00\xa2\x00\x00\x00\x00\x00\x58\x01\x00\x00\x59\x01\x00\x00\x13\x00\xa3\x00\x8f\x00\x4a\x01\x4b\x01\x00\x00\x92\x00\x14\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x4c\x01\x00\x00\x98\x00\x99\x00\x00\x00\x00\x00\x15\x00\x00\x00\x4d\x01\x4e\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\x4f\x01\x00\x00\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\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x54\x01\x55\x01\x56\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x57\x01\x7f\x00\xa2\x00\x00\x00\x00\x00\x58\x01\x2c\x00\x59\x01\x00\x00\x13\x00\xa3\x00\x8f\x00\x4a\x01\x4b\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\x92\x01\x93\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\x4f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x01\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x96\x01\x63\x00\x59\x01\x00\x00\x00\x00\xa3\x00\x8f\x00\x4a\x01\x4b\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\x99\x01\x00\x00\x00\x00\x00\x00\x9a\x01\x9b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x4f\x01\x00\x00\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\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\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\x81\x02\x00\x00\x00\x00\x82\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x4f\x01\x00\x00\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\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\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\x81\x02\x00\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\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\x4f\x01\x00\x00\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\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\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\xc8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x4f\x01\x00\x00\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\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\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\xa3\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\x4f\x01\x00\x00\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\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x9a\x03\x4b\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\x9b\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\x4f\x01\x00\x00\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\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\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\x71\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\x4f\x01\x00\x00\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\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x4f\x01\x00\x00\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\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa2\x00\x00\x00\x00\x00\x8f\x00\x4a\x01\x4b\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\xce\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x4f\x01\x00\x00\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\x51\x01\x00\x00\x52\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x0f\x00\x10\x00\x00\x00\x53\x01\x94\x01\x00\x00\x95\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\x9c\x03\x9d\x03\x9e\x03\x9f\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\xa0\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\xab\x04\x9e\x03\x9f\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\xa0\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\xfa\x00\xfb\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\x8b\x02\x00\x00\xa3\x00\x8a\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\x89\x02\x00\x00\xa3\x00\x8a\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\x68\x02\x69\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\x6a\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\x61\x03\x69\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\x6a\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\xac\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\xad\x01\xae\x01\xaf\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\x01\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\xa9\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\xaa\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\xed\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\x38\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\x37\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\xb9\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\xb2\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\x89\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\x83\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\x64\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\x56\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\x55\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\xb7\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\xb6\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\xa2\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\x62\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\x06\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\xfc\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\xec\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\xb0\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\xa8\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\x8f\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\xfd\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\xd2\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\xd1\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\xd0\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\x31\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\x41\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\x15\x01\x00\x00\x00\x00\x15\x00\x00\x00\x16\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\x19\x02\x1a\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\x17\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\x6a\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\x26\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\x17\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\x6a\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\x17\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\x05\xff\x00\x00\x15\x00\x00\x00\x00\x00\x05\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\x02\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\xaf\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\xe6\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\x40\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\xe6\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\x40\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\xf0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xf1\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\xf1\x01\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x88\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\xca\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\x40\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\xe9\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\xa1\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\xa1\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\xa2\x01\xa3\x01\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\xa2\x01\x7a\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\xa0\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\x95\x03\x96\x00\x97\x00\x00\x00\x00\x00\x98\x00\x99\x00\x00\x00\x96\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\xb7\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\xaa\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\xa8\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\x9f\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\x9e\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\x9d\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\x91\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\x16\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\x15\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\xb7\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\x65\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\x2c\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\xc6\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\x81\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\x82\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\x82\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, 829) [ - (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) - ] - -happy_n_terms = 151 :: Prelude.Int -happy_n_nonterms = 313 :: 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 happyOut298 happy_x_1 of { (HappyWrap298 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 happyOut268 happy_x_1 of { (HappyWrap268 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 happyOut292 happy_x_1 of { (HappyWrap292 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 happyOut276 happy_x_1 of { (HappyWrap276 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 happyOut315 happy_x_1 of { (HappyWrap315 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 happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut315 happy_x_3 of { (HappyWrap315 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 happyOut315 happy_x_2 of { (HappyWrap315 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 happyOut315 happy_x_3 of { (HappyWrap315 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 happyOut307 happy_x_1 of { (HappyWrap307 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 $ appendFS (unLoc happy_var_1) (consFS '-' (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 happyOut315 happy_x_1 of { (HappyWrap315 happy_var_1) -> - case happyOut315 happy_x_3 of { (HappyWrap315 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 happyOut315 happy_x_1 of { (HappyWrap315 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 happyOut315 happy_x_3 of { (HappyWrap315 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 noAnn (thdOf3 happy_var_7) (Just happy_var_3) happy_var_5 (fst $ sndOf3 happy_var_7) (snd $ sndOf3 happy_var_7) happy_var_4 Nothing)) - ) `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 happyOut315 happy_x_2 of { (HappyWrap315 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 noAnn (thdOf3 happy_var_6) (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) (snd $ sndOf3 happy_var_6) happy_var_3 Nothing)) - ) `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 happyOut315 happy_x_2 of { (HappyWrap315 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 (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature happy_var_1, mj AnnWhere happy_var_5] (fstOf3 happy_var_6)) cs) - (thdOf3 happy_var_6) (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) - (snd $ sndOf3 happy_var_6) happy_var_3 Nothing)) - ))}}}}}}) - ) (\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 happyOut315 happy_x_2 of { (HappyWrap315 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 (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule happy_var_1, mj AnnWhere happy_var_5] (fstOf3 happy_var_6)) cs) - (thdOf3 happy_var_6) (Just happy_var_2) happy_var_4 (fst $ sndOf3 happy_var_6) - (snd $ sndOf3 happy_var_6) happy_var_3 Nothing) - )))}}}}}}) - ) (\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 (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 happy_var_1)) cs) - (thdOf3 happy_var_1) Nothing Nothing - (fst $ sndOf3 happy_var_1) (snd $ sndOf3 happy_var_1) Nothing Nothing))))}) - ) (\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 happyOut143 happy_x_2 of { (HappyWrap143 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 happyOut143 happy_x_2 of { (HappyWrap143 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) - )}}} - -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) - )}}} - -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 happyOut315 happy_x_2 of { (HappyWrap315 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 (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule happy_var_1,mj AnnWhere happy_var_5] (AnnList Nothing Nothing Nothing [] [])) cs) - NoLayoutInfo (Just happy_var_2) happy_var_4 happy_var_6 [] happy_var_3 Nothing - ))))}}}}}}) - ) (\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 happyOut315 happy_x_2 of { (HappyWrap315 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 (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule happy_var_1,mj AnnWhere happy_var_5] (AnnList Nothing Nothing Nothing [] [])) cs) - NoLayoutInfo (Just happy_var_2) happy_var_4 happy_var_6 [] happy_var_3 Nothing - ))))}}}}}}) - ) (\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 noAnn NoLayoutInfo Nothing Nothing happy_var_1 [] Nothing - Nothing)))}) - ) (\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 happyOut315 happy_x_2 of { (HappyWrap315 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 happyOut268 happy_x_2 of { (HappyWrap268 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 happyOut279 happy_x_2 of { (HappyWrap279 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 happyOut298 happy_x_1 of { (HappyWrap298 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 happyOut280 happy_x_1 of { (HappyWrap280 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 happyOut315 happy_x_6 of { (HappyWrap315 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 = EpAnn (glR happy_var_1) anns cs - , ideclSourceSrc = snd $ fst happy_var_2 - , ideclName = happy_var_6, ideclPkgQual = snd happy_var_5 - , ideclSource = snd happy_var_2, ideclSafe = snd happy_var_3 - , ideclQualified = snd $ importDeclQualifiedStyle mPreQual mPostQual - , ideclImplicit = False - , ideclAs = unLoc (snd happy_var_8) - , ideclHiding = 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 happyOut315 happy_x_2 of { (HappyWrap315 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 (False, 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 (True, 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 happyOut287 happy_x_3 of { (HappyWrap287 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 happyOut287 happy_x_1 of { (HappyWrap287 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 happyOut107 happy_x_1 of { (HappyWrap107 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 happyOut108 happy_x_1 of { (HappyWrap108 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 happyOut171 happy_x_3 of { (HappyWrap171 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 happyOut146 happy_x_2 of { (HappyWrap146 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 happyOut141 happy_x_2 of { (HappyWrap141 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 happyOut139 happy_x_2 of { (HappyWrap139 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 happyOut131 happy_x_2 of { (HappyWrap131 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 happyOut145 happy_x_1 of { (HappyWrap145 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 happyOut197 happy_x_1 of { (HappyWrap197 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 happyOut207 happy_x_1 of { (HappyWrap207 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 happyOut104 happy_x_2 of { (HappyWrap104 happy_var_2) -> - case happyOut177 happy_x_3 of { (HappyWrap177 happy_var_3) -> - case happyOut122 happy_x_4 of { (HappyWrap122 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 happyOut161 happy_x_2 of { (HappyWrap161 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut158 happy_x_4 of { (HappyWrap158 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 happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> - case happyOut102 happy_x_4 of { (HappyWrap102 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 happyOut106 happy_x_2 of { (HappyWrap106 happy_var_2) -> - case happyOut104 happy_x_3 of { (HappyWrap104 happy_var_3) -> - case happyOut185 happy_x_4 of { (HappyWrap185 happy_var_4) -> - case happyOut193 happy_x_5 of { (HappyWrap193 happy_var_5) -> - ( mkTyData (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (snd $ unLoc happy_var_1) happy_var_2 happy_var_3 - Nothing (reverse (snd $ unLoc happy_var_4)) - (fmap reverse happy_var_5) - ((fst $ 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 happyOut106 happy_x_2 of { (HappyWrap106 happy_var_2) -> - case happyOut104 happy_x_3 of { (HappyWrap104 happy_var_3) -> - case happyOut100 happy_x_4 of { (HappyWrap100 happy_var_4) -> - case happyOut182 happy_x_5 of { (HappyWrap182 happy_var_5) -> - case happyOut193 happy_x_6 of { (HappyWrap193 happy_var_6) -> - ( mkTyData (comb4 happy_var_1 happy_var_3 happy_var_5 happy_var_6) (snd $ 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) - ((fst $ 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 happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> - case happyOut101 happy_x_4 of { (HappyWrap101 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 happyOut152 happy_x_4 of { (HappyWrap152 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 happyOut279 happy_x_3 of { (HappyWrap279 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 happyOut279 happy_x_1 of { (HappyWrap279 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 happyOut169 happy_x_3 of { (HappyWrap169 happy_var_3) -> - case happyOut126 happy_x_4 of { (HappyWrap126 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 happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut106 happy_x_3 of { (HappyWrap106 happy_var_3) -> - case happyOut105 happy_x_4 of { (HappyWrap105 happy_var_4) -> - case happyOut185 happy_x_5 of { (HappyWrap185 happy_var_5) -> - case happyOut193 happy_x_6 of { (HappyWrap193 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 happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut106 happy_x_3 of { (HappyWrap106 happy_var_3) -> - case happyOut105 happy_x_4 of { (HappyWrap105 happy_var_4) -> - case happyOut100 happy_x_5 of { (HappyWrap100 happy_var_5) -> - case happyOut182 happy_x_6 of { (HappyWrap182 happy_var_6) -> - case happyOut193 happy_x_7 of { (HappyWrap193 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 happyOut152 happy_x_2 of { (HappyWrap152 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 happyOut296 happy_x_1 of { (HappyWrap296 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 happyOut296 happy_x_2 of { (HappyWrap296 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 happyOut296 happy_x_1 of { (HappyWrap296 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 happyOut174 happy_x_2 of { (HappyWrap174 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 happyOut158 happy_x_6 of { (HappyWrap158 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 happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut158 happy_x_3 of { (HappyWrap158 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 happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> - case happyOut101 happy_x_4 of { (HappyWrap101 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 happyOut161 happy_x_2 of { (HappyWrap161 happy_var_2) -> - case happyOut103 happy_x_3 of { (HappyWrap103 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 happyOut161 happy_x_3 of { (HappyWrap161 happy_var_3) -> - case happyOut103 happy_x_4 of { (HappyWrap103 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 happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> - case happyOut97 happy_x_2 of { (HappyWrap97 happy_var_2) -> - case happyOut106 happy_x_3 of { (HappyWrap106 happy_var_3) -> - case happyOut105 happy_x_4 of { (HappyWrap105 happy_var_4) -> - case happyOut185 happy_x_5 of { (HappyWrap185 happy_var_5) -> - case happyOut193 happy_x_6 of { (HappyWrap193 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 happyOut99 happy_x_1 of { (HappyWrap99 happy_var_1) -> - case happyOut97 happy_x_2 of { (HappyWrap97 happy_var_2) -> - case happyOut106 happy_x_3 of { (HappyWrap106 happy_var_3) -> - case happyOut105 happy_x_4 of { (HappyWrap105 happy_var_4) -> - case happyOut100 happy_x_5 of { (HappyWrap100 happy_var_5) -> - case happyOut182 happy_x_6 of { (HappyWrap182 happy_var_6) -> - case happyOut193 happy_x_7 of { (HappyWrap193 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,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,NewType) - )} - -happyReduce_217 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_217 = happySpecReduce_0 84# happyReduction_217 -happyReduction_217 = happyIn100 - (noLoc ([] , Nothing) - ) - -happyReduce_218 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_218 = happySpecReduce_2 84# happyReduction_218 -happyReduction_218 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut181 happy_x_2 of { (HappyWrap181 happy_var_2) -> - happyIn100 - (sLL happy_var_1 (reLoc happy_var_2) ([mu AnnDcolon happy_var_1], Just happy_var_2) - )}} - -happyReduce_219 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_219 = happySpecReduce_0 85# happyReduction_219 -happyReduction_219 = happyIn101 - (noLoc ([] , noLocA (NoSig noExtField) ) - ) - -happyReduce_220 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_220 = happySpecReduce_2 85# happyReduction_220 -happyReduction_220 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut181 happy_x_2 of { (HappyWrap181 happy_var_2) -> - happyIn101 - (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_221 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_221 = happySpecReduce_0 86# happyReduction_221 -happyReduction_221 = happyIn102 - (noLoc ([] , noLocA (NoSig noExtField) ) - ) - -happyReduce_222 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_222 = happySpecReduce_2 86# happyReduction_222 -happyReduction_222 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut181 happy_x_2 of { (HappyWrap181 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_223 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_223 = happyMonadReduce 2# 86# happyReduction_223 -happyReduction_223 (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) -> - ( 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 (happyIn102 r)) - -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), Nothing)) - ) - -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 happyOut181 happy_x_2 of { (HappyWrap181 happy_var_2) -> - happyIn103 - (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_226 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_226 = happyMonadReduce 4# 87# happyReduction_226 -happyReduction_226 (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 happyOut176 happy_x_2 of { (HappyWrap176 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 (happyIn103 r)) - -happyReduce_227 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_227 = happyMonadReduce 3# 88# happyReduction_227 -happyReduction_227 (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 happyOut161 happy_x_3 of { (HappyWrap161 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 (happyIn104 r)) - -happyReduce_228 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_228 = happySpecReduce_1 88# happyReduction_228 -happyReduction_228 happy_x_1 - = case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> - happyIn104 - (sL1A happy_var_1 (Nothing, happy_var_1) - )} - -happyReduce_229 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_229 = happyMonadReduce 6# 89# happyReduction_229 -happyReduction_229 (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 happyOut174 happy_x_2 of { (HappyWrap174 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 -> - case happyOut161 happy_x_6 of { (HappyWrap161 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 (happyIn105 r)) - -happyReduce_230 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_230 = happyMonadReduce 4# 89# happyReduction_230 -happyReduction_230 (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 happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut161 happy_x_4 of { (HappyWrap161 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 (happyIn105 r)) - -happyReduce_231 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_231 = happyMonadReduce 3# 89# happyReduction_231 -happyReduction_231 (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 happyOut161 happy_x_3 of { (HappyWrap161 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 (happyIn105 r)) - -happyReduce_232 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_232 = happySpecReduce_1 89# happyReduction_232 -happyReduction_232 happy_x_1 - = case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> - happyIn105 - (sL1A happy_var_1 (Nothing, mkHsOuterImplicit, happy_var_1) - )} - -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 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 (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 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 (happyIn106 r)) - -happyReduce_235 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_235 = happySpecReduce_0 90# happyReduction_235 -happyReduction_235 = happyIn106 - (Nothing - ) - -happyReduce_236 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_236 = happyMonadReduce 5# 91# happyReduction_236 -happyReduction_236 (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 happyOut169 happy_x_5 of { (HappyWrap169 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 (happyIn107 r)) - -happyReduce_237 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_237 = happyMonadReduce 4# 92# happyReduction_237 -happyReduction_237 (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 happyOut279 happy_x_3 of { (HappyWrap279 happy_var_3) -> - case happyOut109 happy_x_4 of { (HappyWrap109 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 (happyIn108 r)) - -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 [] - ) - -happyReduce_239 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_239 = happySpecReduce_1 93# happyReduction_239 -happyReduction_239 happy_x_1 - = case happyOut110 happy_x_1 of { (HappyWrap110 happy_var_1) -> - happyIn109 - (happy_var_1 - )} - -happyReduce_240 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_240 = happySpecReduce_1 94# happyReduction_240 -happyReduction_240 happy_x_1 - = case happyOut111 happy_x_1 of { (HappyWrap111 happy_var_1) -> - happyIn110 - (sLL happy_var_1 happy_var_1 [happy_var_1] - )} - -happyReduce_241 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_241 = happySpecReduce_2 94# happyReduction_241 -happyReduction_241 happy_x_2 - happy_x_1 - = case happyOut110 happy_x_1 of { (HappyWrap110 happy_var_1) -> - case happyOut111 happy_x_2 of { (HappyWrap111 happy_var_2) -> - happyIn110 - (sLL happy_var_1 happy_var_2 $ happy_var_2 : unLoc happy_var_1 - )}} - -happyReduce_242 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_242 = happySpecReduce_1 95# happyReduction_242 -happyReduction_242 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn111 - (sL1 happy_var_1 $ Just $ getVARID 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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn111 - (sL1 happy_var_1 Nothing - )} - -happyReduce_244 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_244 = happyMonadReduce 4# 96# happyReduction_244 -happyReduction_244 (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 happyOut113 happy_x_2 of { (HappyWrap113 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut241 happy_x_4 of { (HappyWrap241 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 (happyIn112 r)) - -happyReduce_245 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_245 = happyMonadReduce 4# 96# happyReduction_245 -happyReduction_245 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut113 happy_x_2 of { (HappyWrap113 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut241 happy_x_4 of { (HappyWrap241 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 (happyIn112 r)) - -happyReduce_246 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_246 = happyMonadReduce 5# 96# happyReduction_246 -happyReduction_246 (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 happyOut113 happy_x_2 of { (HappyWrap113 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut241 happy_x_4 of { (HappyWrap241 happy_var_4) -> - case happyOut116 happy_x_5 of { (HappyWrap116 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 (happyIn112 r)) - -happyReduce_247 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_247 = happySpecReduce_2 97# happyReduction_247 -happyReduction_247 happy_x_2 - happy_x_1 - = case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> - case happyOut114 happy_x_2 of { (HappyWrap114 happy_var_2) -> - happyIn113 - ((happy_var_1, PrefixCon noTypeArgs happy_var_2, []) - )}} - -happyReduce_248 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_248 = happySpecReduce_3 97# happyReduction_248 -happyReduction_248 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> - case happyOut275 happy_x_2 of { (HappyWrap275 happy_var_2) -> - case happyOut301 happy_x_3 of { (HappyWrap301 happy_var_3) -> - happyIn113 - ((happy_var_2, InfixCon happy_var_1 happy_var_3, []) - )}}} - -happyReduce_249 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_249 = happyReduce 4# 97# happyReduction_249 -happyReduction_249 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut115 happy_x_3 of { (HappyWrap115 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn113 - ((happy_var_1, RecCon happy_var_3, [moc happy_var_2, mcc happy_var_4] ) - ) `HappyStk` happyRest}}}} - -happyReduce_250 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_250 = happySpecReduce_0 98# happyReduction_250 -happyReduction_250 = happyIn114 - ([] - ) - -happyReduce_251 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_251 = happySpecReduce_2 98# happyReduction_251 -happyReduction_251 happy_x_2 - happy_x_1 - = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> - case happyOut114 happy_x_2 of { (HappyWrap114 happy_var_2) -> - happyIn114 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_252 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_252 = happySpecReduce_1 99# happyReduction_252 -happyReduction_252 happy_x_1 - = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> - happyIn115 - ([RecordPatSynField (mkFieldOcc happy_var_1) happy_var_1] - )} - -happyReduce_253 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_253 = happyMonadReduce 3# 99# happyReduction_253 -happyReduction_253 (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 happyOut115 happy_x_3 of { (HappyWrap115 happy_var_3) -> - ( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2) - ; return ((RecordPatSynField (mkFieldOcc h) h) : happy_var_3 )})}}}) - ) (\r -> happyReturn (happyIn115 r)) - -happyReduce_254 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_254 = happyMonadReduce 4# 100# 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 happyOut127 happy_x_3 of { (HappyWrap127 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 (happyIn116 r)) - -happyReduce_255 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_255 = happyMonadReduce 4# 100# happyReduction_255 -happyReduction_255 (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 happyOut127 happy_x_3 of { (HappyWrap127 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 (happyIn116 r)) - -happyReduce_256 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_256 = happyMonadReduce 4# 101# happyReduction_256 -happyReduction_256 (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 happyOut271 happy_x_2 of { (HappyWrap271 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut153 happy_x_4 of { (HappyWrap153 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) - (unLoc happy_var_2) happy_var_4))}}}}) - ) (\r -> happyReturn (happyIn117 r)) - -happyReduce_257 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_257 = happySpecReduce_1 102# happyReduction_257 -happyReduction_257 happy_x_1 - = case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> - happyIn118 - (happy_var_1 - )} - -happyReduce_258 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_258 = happySpecReduce_1 102# happyReduction_258 -happyReduction_258 happy_x_1 - = case happyOut268 happy_x_1 of { (HappyWrap268 happy_var_1) -> - happyIn118 - (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 103# happyReduction_259 -happyReduction_259 happy_x_1 - = case happyOut95 happy_x_1 of { (HappyWrap95 happy_var_1) -> - happyIn119 - (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 103# happyReduction_260 -happyReduction_260 happy_x_1 - = case happyOut198 happy_x_1 of { (HappyWrap198 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 = 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 happyOut207 happy_x_2 of { (HappyWrap207 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut153 happy_x_4 of { (HappyWrap153 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 (happyIn119 r)) - -happyReduce_262 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_262 = happyMonadReduce 3# 104# happyReduction_262 -happyReduction_262 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut120 happy_x_1 of { (HappyWrap120 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut119 happy_x_3 of { (HappyWrap119 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 (happyIn120 r)) - -happyReduce_263 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_263 = happyMonadReduce 2# 104# happyReduction_263 -happyReduction_263 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut120 happy_x_1 of { (HappyWrap120 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 (happyIn120 r)) - -happyReduce_264 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_264 = happySpecReduce_1 104# happyReduction_264 -happyReduction_264 happy_x_1 - = case happyOut119 happy_x_1 of { (HappyWrap119 happy_var_1) -> - happyIn120 - (sL1A happy_var_1 ([], unitOL happy_var_1) - )} - -happyReduce_265 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_265 = happySpecReduce_0 104# happyReduction_265 -happyReduction_265 = happyIn120 - (noLoc ([],nilOL) - ) - -happyReduce_266 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_266 = happySpecReduce_3 105# happyReduction_266 -happyReduction_266 happy_x_3 - happy_x_2 - happy_x_1 - = 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 -> - happyIn121 - (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) - )}}} - -happyReduce_267 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_267 = happySpecReduce_3 105# happyReduction_267 -happyReduction_267 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut120 happy_x_2 of { (HappyWrap120 happy_var_2) -> - happyIn121 - (let { L l (anns, decls) = happy_var_2 } - in L l (anns, decls, VirtualBraces (getVOCURLY happy_var_1)) - )}} - -happyReduce_268 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_268 = happySpecReduce_2 106# happyReduction_268 -happyReduction_268 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 - (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_269 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_269 = happySpecReduce_0 106# happyReduction_269 -happyReduction_269 = happyIn122 - (noLoc ([],nilOL,NoLayoutInfo) - ) - -happyReduce_270 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_270 = happySpecReduce_1 107# happyReduction_270 -happyReduction_270 happy_x_1 - = case happyOut98 happy_x_1 of { (HappyWrap98 happy_var_1) -> - happyIn123 - (sL1A happy_var_1 (unitOL (sL1 happy_var_1 (InstD noExtField (unLoc happy_var_1)))) - )} - -happyReduce_271 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_271 = happySpecReduce_1 107# happyReduction_271 -happyReduction_271 happy_x_1 - = case happyOut198 happy_x_1 of { (HappyWrap198 happy_var_1) -> - happyIn123 - (sL1A happy_var_1 (unitOL happy_var_1) - )} - -happyReduce_272 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_272 = happyMonadReduce 3# 108# happyReduction_272 -happyReduction_272 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut124 happy_x_1 of { (HappyWrap124 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut123 happy_x_3 of { (HappyWrap123 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 (happyIn124 r)) - -happyReduce_273 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_273 = happyMonadReduce 2# 108# happyReduction_273 -happyReduction_273 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut124 happy_x_1 of { (HappyWrap124 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 (happyIn124 r)) - -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 happyOut123 happy_x_1 of { (HappyWrap123 happy_var_1) -> - happyIn124 - (sL1 happy_var_1 ([],unLoc happy_var_1) - )} - -happyReduce_275 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_275 = happySpecReduce_0 108# happyReduction_275 -happyReduction_275 = happyIn124 - (noLoc ([],nilOL) - ) - -happyReduce_276 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_276 = happySpecReduce_3 109# happyReduction_276 -happyReduction_276 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut124 happy_x_2 of { (HappyWrap124 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn125 - (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_277 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_277 = happySpecReduce_3 109# happyReduction_277 -happyReduction_277 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut124 happy_x_2 of { (HappyWrap124 happy_var_2) -> - happyIn125 - (L (gl happy_var_2) (unLoc happy_var_2) - )} - -happyReduce_278 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_278 = happySpecReduce_2 110# happyReduction_278 -happyReduction_278 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut125 happy_x_2 of { (HappyWrap125 happy_var_2) -> - happyIn126 - (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) - ,(snd $ unLoc happy_var_2)) - )}} - -happyReduce_279 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_279 = happySpecReduce_0 110# happyReduction_279 -happyReduction_279 = happyIn126 - (noLoc ([],nilOL) - ) - -happyReduce_280 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_280 = happyMonadReduce 3# 111# happyReduction_280 -happyReduction_280 (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 happyOut198 happy_x_3 of { (HappyWrap198 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 (happyIn127 r)) - -happyReduce_281 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_281 = happyMonadReduce 2# 111# happyReduction_281 -happyReduction_281 (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 (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 (happyIn127 r)) - -happyReduce_282 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_282 = happySpecReduce_1 111# happyReduction_282 -happyReduction_282 happy_x_1 - = case happyOut198 happy_x_1 of { (HappyWrap198 happy_var_1) -> - happyIn127 - (sL1A happy_var_1 ([], unitOL happy_var_1) - )} - -happyReduce_283 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_283 = happySpecReduce_0 111# happyReduction_283 -happyReduction_283 = happyIn127 - (noLoc ([],nilOL) - ) - -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) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn128 - (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_285 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_285 = happySpecReduce_3 112# happyReduction_285 -happyReduction_285 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut127 happy_x_2 of { (HappyWrap127 happy_var_2) -> - happyIn128 - (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_286 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_286 = happyMonadReduce 1# 113# happyReduction_286 -happyReduction_286 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut128 happy_x_1 of { (HappyWrap128 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 (happyIn129 r)) - -happyReduce_287 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_287 = happyMonadReduce 3# 113# happyReduction_287 -happyReduction_287 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut256 happy_x_2 of { (HappyWrap256 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 (happyIn129 r)) - -happyReduce_288 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_288 = happyMonadReduce 3# 113# happyReduction_288 -happyReduction_288 (happy_x_3 `HappyStk` - 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) -> - ( 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 (happyIn129 r)) - -happyReduce_289 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_289 = happyMonadReduce 2# 114# happyReduction_289 -happyReduction_289 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut129 happy_x_2 of { (HappyWrap129 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 (happyIn130 r)) - -happyReduce_290 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_290 = happySpecReduce_0 114# happyReduction_290 -happyReduction_290 = happyIn130 - (Nothing - ) - -happyReduce_291 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_291 = happyMonadReduce 3# 115# happyReduction_291 -happyReduction_291 (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 happyOut132 happy_x_3 of { (HappyWrap132 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 (happyIn131 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 happyOut131 happy_x_1 of { (HappyWrap131 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 (happyIn131 r)) - -happyReduce_293 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_293 = happySpecReduce_1 115# happyReduction_293 -happyReduction_293 happy_x_1 - = case happyOut132 happy_x_1 of { (HappyWrap132 happy_var_1) -> - happyIn131 - ([happy_var_1] - )} - -happyReduce_294 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_294 = happySpecReduce_0 115# happyReduction_294 -happyReduction_294 = happyIn131 - ([] - ) - -happyReduce_295 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_295 = happyMonadReduce 6# 116# happyReduction_295 -happyReduction_295 (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 happyOut133 happy_x_2 of { (HappyWrap133 happy_var_2) -> - case happyOut136 happy_x_3 of { (HappyWrap136 happy_var_3) -> - case happyOut207 happy_x_4 of { (HappyWrap207 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut206 happy_x_6 of { (HappyWrap206 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 - , rd_name = L (noAnnSrcSpan $ gl happy_var_1) (getSTRINGs 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 (happyIn132 r)) - -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 - (([],Nothing) - ) - -happyReduce_297 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_297 = happySpecReduce_1 117# happyReduction_297 -happyReduction_297 happy_x_1 - = case happyOut135 happy_x_1 of { (HappyWrap135 happy_var_1) -> - happyIn133 - ((fst happy_var_1,Just (snd happy_var_1)) - )} - -happyReduce_298 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_298 = happySpecReduce_1 118# happyReduction_298 -happyReduction_298 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn134 - ([mj AnnTilde happy_var_1] - )} - -happyReduce_299 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_299 = happyMonadReduce 1# 118# happyReduction_299 -happyReduction_299 (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 (happyIn134 r)) - -happyReduce_300 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_300 = happySpecReduce_3 119# happyReduction_300 -happyReduction_300 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 -> - happyIn135 - (([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_301 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_301 = happyReduce 4# 119# happyReduction_301 -happyReduction_301 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn135 - ((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_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 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 - ((happy_var_2++[mos happy_var_1,mcs happy_var_3] - ,NeverActive) - )}}} - -happyReduce_303 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_303 = happyMonadReduce 6# 120# happyReduction_303 -happyReduction_303 (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 happyOut137 happy_x_2 of { (HappyWrap137 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut137 happy_x_5 of { (HappyWrap137 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 (happyIn136 r)) - -happyReduce_304 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_304 = happySpecReduce_3 120# happyReduction_304 -happyReduction_304 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut137 happy_x_2 of { (HappyWrap137 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn136 - ((\anns -> HsRuleAnn Nothing (Just (mu AnnForall happy_var_1,mj AnnDot happy_var_3)) anns, - Nothing, mkRuleBndrs happy_var_2) - )}}} - -happyReduce_305 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_305 = happySpecReduce_0 120# happyReduction_305 -happyReduction_305 = happyIn136 - ((\anns -> HsRuleAnn Nothing Nothing anns, Nothing, []) - ) - -happyReduce_306 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_306 = happySpecReduce_2 121# happyReduction_306 -happyReduction_306 happy_x_2 - happy_x_1 - = case happyOut138 happy_x_1 of { (HappyWrap138 happy_var_1) -> - case happyOut137 happy_x_2 of { (HappyWrap137 happy_var_2) -> - happyIn137 - (happy_var_1 : happy_var_2 - )}} - -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 - ([] - ) - -happyReduce_308 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_308 = happySpecReduce_1 122# happyReduction_308 -happyReduction_308 happy_x_1 - = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> - happyIn138 - (sL1l happy_var_1 (RuleTyTmVar noAnn happy_var_1 Nothing) - )} - -happyReduce_309 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_309 = happyMonadReduce 5# 122# happyReduction_309 -happyReduction_309 (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 happyOut301 happy_x_2 of { (HappyWrap301 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut159 happy_x_4 of { (HappyWrap159 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 (happyIn138 r)) - -happyReduce_310 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_310 = happyMonadReduce 3# 123# happyReduction_310 -happyReduction_310 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut139 happy_x_1 of { (HappyWrap139 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut140 happy_x_3 of { (HappyWrap140 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 (happyIn139 r)) - -happyReduce_311 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_311 = happyMonadReduce 2# 123# happyReduction_311 -happyReduction_311 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut139 happy_x_1 of { (HappyWrap139 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 (happyIn139 r)) - -happyReduce_312 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_312 = happySpecReduce_1 123# happyReduction_312 -happyReduction_312 happy_x_1 - = case happyOut140 happy_x_1 of { (HappyWrap140 happy_var_1) -> - happyIn139 - (happy_var_1 - )} - -happyReduce_313 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_313 = happySpecReduce_0 123# happyReduction_313 -happyReduction_313 = happyIn139 - (nilOL - ) - -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 happyOut265 happy_x_1 of { (HappyWrap265 happy_var_1) -> - case happyOut143 happy_x_2 of { (HappyWrap143 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 (happyIn140 r)) - -happyReduce_315 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_315 = happyMonadReduce 3# 125# happyReduction_315 -happyReduction_315 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut141 happy_x_1 of { (HappyWrap141 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut142 happy_x_3 of { (HappyWrap142 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 (happyIn141 r)) - -happyReduce_316 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_316 = happyMonadReduce 2# 125# happyReduction_316 -happyReduction_316 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut141 happy_x_1 of { (HappyWrap141 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 (happyIn141 r)) - -happyReduce_317 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_317 = happySpecReduce_1 125# happyReduction_317 -happyReduction_317 happy_x_1 - = case happyOut142 happy_x_1 of { (HappyWrap142 happy_var_1) -> - happyIn141 - (happy_var_1 - )} - -happyReduce_318 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_318 = happySpecReduce_0 125# happyReduction_318 -happyReduction_318 = happyIn141 - (nilOL - ) - -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 happyOut265 happy_x_1 of { (HappyWrap265 happy_var_1) -> - case happyOut143 happy_x_2 of { (HappyWrap143 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 (happyIn142 r)) - -happyReduce_320 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_320 = happySpecReduce_1 127# happyReduction_320 -happyReduction_320 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn143 - (sL1 happy_var_1 ([],[L (gl happy_var_1) (getStringLiteral happy_var_1)]) - )} - -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 - (sLL happy_var_1 happy_var_3 $ ([mos happy_var_1,mcs happy_var_3],fromOL (unLoc happy_var_2)) - )}}} - -happyReduce_322 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_322 = happyMonadReduce 3# 128# happyReduction_322 -happyReduction_322 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut144 happy_x_1 of { (HappyWrap144 happy_var_1) -> - case 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 (happyIn144 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 - (sLL happy_var_1 happy_var_1 (unitOL (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_0 128# happyReduction_324 -happyReduction_324 = happyIn144 - (noLoc nilOL - ) - -happyReduce_325 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_325 = happyMonadReduce 4# 129# happyReduction_325 -happyReduction_325 (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 happyOut266 happy_x_2 of { (HappyWrap266 happy_var_2) -> - case happyOut213 happy_x_3 of { (HappyWrap213 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 (happyIn145 r)) - -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 happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut286 happy_x_3 of { (HappyWrap286 happy_var_3) -> - case happyOut213 happy_x_4 of { (HappyWrap213 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 (happyIn145 r)) - -happyReduce_327 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_327 = happyMonadReduce 4# 129# happyReduction_327 -happyReduction_327 (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 happyOut213 happy_x_3 of { (HappyWrap213 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 (happyIn145 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 happyOut148 happy_x_3 of { (HappyWrap148 happy_var_3) -> - case happyOut149 happy_x_4 of { (HappyWrap149 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 (happyIn146 r)) - -happyReduce_329 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_329 = happyMonadReduce 3# 130# happyReduction_329 -happyReduction_329 (happy_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 happyOut149 happy_x_3 of { (HappyWrap149 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 (happyIn146 r)) - -happyReduce_330 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_330 = happyMonadReduce 3# 130# happyReduction_330 -happyReduction_330 (happy_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 happyOut149 happy_x_3 of { (HappyWrap149 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 (happyIn146 r)) - -happyReduce_331 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_331 = happySpecReduce_1 131# happyReduction_331 -happyReduction_331 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn147 - (sLL happy_var_1 happy_var_1 StdCallConv - )} - -happyReduce_332 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_332 = happySpecReduce_1 131# happyReduction_332 -happyReduction_332 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn147 - (sLL happy_var_1 happy_var_1 CCallConv - )} - -happyReduce_333 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_333 = happySpecReduce_1 131# happyReduction_333 -happyReduction_333 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn147 - (sLL happy_var_1 happy_var_1 CApiConv - )} - -happyReduce_334 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_334 = happySpecReduce_1 131# happyReduction_334 -happyReduction_334 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn147 - (sLL happy_var_1 happy_var_1 PrimCallConv - )} - -happyReduce_335 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_335 = happySpecReduce_1 131# happyReduction_335 -happyReduction_335 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn147 - (sLL happy_var_1 happy_var_1 JavaScriptCallConv - )} - -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 PlayRisky - )} - -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 PlaySafe - )} - -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 PlayInterruptible - )} - -happyReduce_339 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_339 = happyReduce 4# 133# happyReduction_339 -happyReduction_339 (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 happyOut297 happy_x_2 of { (HappyWrap297 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut153 happy_x_4 of { (HappyWrap153 happy_var_4) -> - happyIn149 - (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_340 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_340 = happySpecReduce_3 133# happyReduction_340 -happyReduction_340 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut153 happy_x_3 of { (HappyWrap153 happy_var_3) -> - happyIn149 - (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_341 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_341 = happySpecReduce_0 134# happyReduction_341 -happyReduction_341 = happyIn150 - (Nothing - ) - -happyReduce_342 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_342 = happySpecReduce_2 134# happyReduction_342 -happyReduction_342 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut159 happy_x_2 of { (HappyWrap159 happy_var_2) -> - happyIn150 - (Just (mu AnnDcolon happy_var_1, happy_var_2) - )}} - -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 - (([], Nothing) - ) - -happyReduce_344 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_344 = happySpecReduce_2 135# happyReduction_344 -happyReduction_344 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut277 happy_x_2 of { (HappyWrap277 happy_var_2) -> - happyIn151 - (([mu AnnDcolon happy_var_1], Just happy_var_2) - )}} - -happyReduce_345 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_345 = happySpecReduce_1 136# happyReduction_345 -happyReduction_345 happy_x_1 - = case happyOut153 happy_x_1 of { (HappyWrap153 happy_var_1) -> - happyIn152 - (happy_var_1 - )} - -happyReduce_346 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_346 = happyMonadReduce 3# 136# happyReduction_346 -happyReduction_346 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut181 happy_x_3 of { (HappyWrap181 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 (happyIn152 r)) - -happyReduce_347 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_347 = happySpecReduce_1 137# happyReduction_347 -happyReduction_347 happy_x_1 - = case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> - happyIn153 - (hsTypeToHsSigType happy_var_1 - )} - -happyReduce_348 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_348 = happyMonadReduce 3# 138# happyReduction_348 -happyReduction_348 (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 happyOut297 happy_x_3 of { (HappyWrap297 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 (happyIn154 r)) - -happyReduce_349 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_349 = happySpecReduce_1 138# happyReduction_349 -happyReduction_349 happy_x_1 - = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> - happyIn154 - (sL1N happy_var_1 [happy_var_1] - )} - -happyReduce_350 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_350 = happySpecReduce_1 139# happyReduction_350 -happyReduction_350 happy_x_1 - = case happyOut153 happy_x_1 of { (HappyWrap153 happy_var_1) -> - happyIn155 - (unitOL 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 happyOut153 happy_x_1 of { (HappyWrap153 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut155 happy_x_3 of { (HappyWrap155 happy_var_3) -> - ( do { st <- addTrailingCommaA happy_var_1 (gl happy_var_2) - ; return $ unitOL st `appOL` happy_var_3 })}}}) - ) (\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_2 140# happyReduction_352 -happyReduction_352 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn156 - (sLL happy_var_1 happy_var_2 (UnpackednessPragma [mo happy_var_1, mc happy_var_2] (getUNPACK_PRAGs happy_var_1) SrcUnpack) - )}} - -happyReduce_353 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_353 = happySpecReduce_2 140# happyReduction_353 -happyReduction_353 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn156 - (sLL happy_var_1 happy_var_2 (UnpackednessPragma [mo happy_var_1, mc happy_var_2] (getNOUNPACK_PRAGs happy_var_1) SrcNoUnpack) - )}} - -happyReduce_354 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_354 = happyMonadReduce 3# 141# 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 happyOut174 happy_x_2 of { (HappyWrap174 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 (happyIn157 r)) - -happyReduce_355 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_355 = happyMonadReduce 3# 141# 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 happyOut174 happy_x_2 of { (HappyWrap174 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 (happyIn157 r)) - -happyReduce_356 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_356 = happySpecReduce_1 142# happyReduction_356 -happyReduction_356 happy_x_1 - = case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> - happyIn158 - (happy_var_1 - )} - -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 happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut181 happy_x_3 of { (HappyWrap181 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 (happyIn158 r)) - -happyReduce_358 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_358 = happySpecReduce_2 143# happyReduction_358 -happyReduction_358 happy_x_2 - happy_x_1 - = case happyOut157 happy_x_1 of { (HappyWrap157 happy_var_1) -> - case happyOut159 happy_x_2 of { (HappyWrap159 happy_var_2) -> - happyIn159 - (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_359 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_359 = happyMonadReduce 3# 143# happyReduction_359 -happyReduction_359 (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 happyOut159 happy_x_3 of { (HappyWrap159 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 (happyIn159 r)) - -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 happyOut258 happy_x_1 of { (HappyWrap258 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut159 happy_x_3 of { (HappyWrap159 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 (happyIn159 r)) - -happyReduce_361 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_361 = happySpecReduce_1 143# happyReduction_361 -happyReduction_361 happy_x_1 - = case happyOut161 happy_x_1 of { (HappyWrap161 happy_var_1) -> - happyIn159 - (happy_var_1 - )} - -happyReduce_362 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_362 = happyMonadReduce 1# 144# happyReduction_362 -happyReduction_362 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> - ( checkContext happy_var_1)}) - ) (\r -> happyReturn (happyIn160 r)) - -happyReduce_363 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_363 = happySpecReduce_1 145# happyReduction_363 -happyReduction_363 happy_x_1 - = case happyOut163 happy_x_1 of { (HappyWrap163 happy_var_1) -> - happyIn161 - (happy_var_1 - )} - -happyReduce_364 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_364 = happyMonadReduce 3# 145# happyReduction_364 -happyReduction_364 (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 happyOut159 happy_x_3 of { (HappyWrap159 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 (happyIn161 r)) - -happyReduce_365 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_365 = happyMonadReduce 4# 145# happyReduction_365 -happyReduction_365 (happy_x_4 `HappyStk` - 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 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) -> - ( 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 (happyIn161 r)) - -happyReduce_366 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_366 = happyMonadReduce 3# 145# happyReduction_366 -happyReduction_366 (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 happyOut159 happy_x_3 of { (HappyWrap159 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 (happyIn161 r)) - -happyReduce_367 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_367 = happySpecReduce_2 146# happyReduction_367 -happyReduction_367 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> - happyIn162 - (sLL happy_var_1 (reLoc happy_var_2) (mkMultTy (hsTok happy_var_1) happy_var_2) - )}} - -happyReduce_368 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_368 = happyMonadReduce 1# 147# happyReduction_368 -happyReduction_368 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> - ( runPV happy_var_1)}) - ) (\r -> happyReturn (happyIn163 r)) - -happyReduce_369 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_369 = happySpecReduce_1 148# happyReduction_369 -happyReduction_369 happy_x_1 - = case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> - happyIn164 - (happy_var_1 - )} - -happyReduce_370 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_370 = happySpecReduce_3 148# happyReduction_370 -happyReduction_370 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> - case happyOut167 happy_x_2 of { (HappyWrap167 happy_var_2) -> - case happyOut164 happy_x_3 of { (HappyWrap164 happy_var_3) -> - happyIn164 - (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_371 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_371 = happySpecReduce_2 148# happyReduction_371 -happyReduction_371 happy_x_2 - happy_x_1 - = case happyOut156 happy_x_1 of { (HappyWrap156 happy_var_1) -> - case happyOut164 happy_x_2 of { (HappyWrap164 happy_var_2) -> - happyIn164 - (happy_var_2 >>= \ happy_var_2 -> - mkUnpackednessPV happy_var_1 happy_var_2 - )}} - -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 happyOut168 happy_x_1 of { (HappyWrap168 happy_var_1) -> - happyIn165 - (mkHsAppTyHeadPV happy_var_1 - )} - -happyReduce_373 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_373 = happySpecReduce_1 149# happyReduction_373 -happyReduction_373 happy_x_1 - = case happyOut167 happy_x_1 of { (HappyWrap167 happy_var_1) -> - happyIn165 - (failOpFewArgs (fst happy_var_1) - )} - -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 happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> - case happyOut166 happy_x_2 of { (HappyWrap166 happy_var_2) -> - happyIn165 - (happy_var_1 >>= \ happy_var_1 -> - mkHsAppTyPV 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_3 149# happyReduction_375 -happyReduction_375 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut165 happy_x_1 of { (HappyWrap165 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut168 happy_x_3 of { (HappyWrap168 happy_var_3) -> - happyIn165 - (happy_var_1 >>= \ happy_var_1 -> - mkHsAppKindTyPV happy_var_1 (getLoc happy_var_2) happy_var_3 - )}}} - -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 - (happy_var_1 - )} - -happyReduce_377 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_377 = happyMonadReduce 2# 150# happyReduction_377 -happyReduction_377 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut156 happy_x_1 of { (HappyWrap156 happy_var_1) -> - case happyOut168 happy_x_2 of { (HappyWrap168 happy_var_2) -> - ( addUnpackednessP happy_var_1 happy_var_2)}}) - ) (\r -> happyReturn (happyIn166 r)) - -happyReduce_378 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_378 = happySpecReduce_1 151# happyReduction_378 -happyReduction_378 happy_x_1 - = case happyOut281 happy_x_1 of { (HappyWrap281 happy_var_1) -> - happyIn167 - ((happy_var_1, NotPromoted) - )} - -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 happyOut295 happy_x_1 of { (HappyWrap295 happy_var_1) -> - happyIn167 - ((happy_var_1, NotPromoted) - )} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut276 happy_x_2 of { (HappyWrap276 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 (happyIn167 r)) - -happyReduce_381 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_381 = happyMonadReduce 2# 151# happyReduction_381 -happyReduction_381 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut288 happy_x_2 of { (HappyWrap288 happy_var_2) -> - ( 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 (happyIn167 r)) - -happyReduce_382 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_382 = happyMonadReduce 1# 152# happyReduction_382 -happyReduction_382 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut278 happy_x_1 of { (HappyWrap278 happy_var_1) -> - ( acsa (\cs -> sL1a (reLocN happy_var_1) (HsTyVar (EpAnn (glNR happy_var_1) [] cs) NotPromoted happy_var_1)))}) - ) (\r -> happyReturn (happyIn168 r)) - -happyReduce_383 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_383 = happyMonadReduce 1# 152# happyReduction_383 -happyReduction_383 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut294 happy_x_1 of { (HappyWrap294 happy_var_1) -> - ( acsa (\cs -> sL1a (reLocN happy_var_1) (HsTyVar (EpAnn (glNR happy_var_1) [] cs) NotPromoted happy_var_1)))}) - ) (\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 1# 152# happyReduction_384 -happyReduction_384 (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 (happyIn168 r)) - -happyReduce_385 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_385 = happyMonadReduce 2# 152# happyReduction_385 -happyReduction_385 (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) -> - ( 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 (happyIn168 r)) - -happyReduce_386 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_386 = happyMonadReduce 2# 152# happyReduction_386 -happyReduction_386 (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) -> - ( 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 (happyIn168 r)) - -happyReduce_387 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_387 = happyMonadReduce 3# 152# happyReduction_387 -happyReduction_387 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut190 happy_x_2 of { (HappyWrap190 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 (happyIn168 r)) - -happyReduce_388 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_388 = happyMonadReduce 2# 152# 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 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 (happyIn168 r)) - -happyReduce_389 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_389 = happyMonadReduce 5# 152# happyReduction_389 -happyReduction_389 (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 happyOut158 happy_x_2 of { (HappyWrap158 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 -> - ( 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 (happyIn168 r)) - -happyReduce_390 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_390 = happyMonadReduce 2# 152# happyReduction_390 -happyReduction_390 (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 (happyIn168 r)) - -happyReduce_391 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_391 = happyMonadReduce 3# 152# happyReduction_391 -happyReduction_391 (happy_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 -> - ( 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 (happyIn168 r)) - -happyReduce_392 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_392 = happyMonadReduce 3# 152# happyReduction_392 -happyReduction_392 (happy_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 $ HsSumTy (EpAnn (glR happy_var_1) (AnnParen AnnParensHash (glAA happy_var_1) (glAA happy_var_3)) cs) happy_var_2))}}}) - ) (\r -> happyReturn (happyIn168 r)) - -happyReduce_393 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_393 = happyMonadReduce 3# 152# happyReduction_393 -happyReduction_393 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut158 happy_x_2 of { (HappyWrap158 happy_var_2) -> - 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 (happyIn168 r)) - -happyReduce_394 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_394 = happyMonadReduce 3# 152# 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 happyOut158 happy_x_2 of { (HappyWrap158 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 (happyIn168 r)) - -happyReduce_395 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_395 = happySpecReduce_1 152# happyReduction_395 -happyReduction_395 happy_x_1 - = case happyOut205 happy_x_1 of { (HappyWrap205 happy_var_1) -> - happyIn168 - (mapLocA (HsSpliceTy noExtField) happy_var_1 - )} - -happyReduce_396 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_396 = happySpecReduce_1 152# happyReduction_396 -happyReduction_396 happy_x_1 - = case happyOut218 happy_x_1 of { (HappyWrap218 happy_var_1) -> - happyIn168 - (mapLocA (HsSpliceTy noExtField) happy_var_1 - )} - -happyReduce_397 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_397 = happyMonadReduce 2# 152# happyReduction_397 -happyReduction_397 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut267 happy_x_2 of { (HappyWrap267 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 (happyIn168 r)) - -happyReduce_398 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_398 = happyMonadReduce 6# 152# happyReduction_398 -happyReduction_398 (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 happyOut158 happy_x_3 of { (HappyWrap158 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut172 happy_x_5 of { (HappyWrap172 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 (happyIn168 r)) - -happyReduce_399 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_399 = happyMonadReduce 4# 152# happyReduction_399 -happyReduction_399 (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 happyOut171 happy_x_3 of { (HappyWrap171 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 (happyIn168 r)) - -happyReduce_400 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_400 = happyMonadReduce 2# 152# 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 happyOut297 happy_x_2 of { (HappyWrap297 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 (happyIn168 r)) - -happyReduce_401 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_401 = happyMonadReduce 5# 152# happyReduction_401 -happyReduction_401 (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 happyOut158 happy_x_2 of { (HappyWrap158 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 -> - ( 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 (happyIn168 r)) - -happyReduce_402 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_402 = happySpecReduce_1 152# happyReduction_402 -happyReduction_402 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn168 - (reLocA $ sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsNumTy (getINTEGERs happy_var_1) - (il_value (getINTEGER happy_var_1)) - )} - -happyReduce_403 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_403 = happySpecReduce_1 152# happyReduction_403 -happyReduction_403 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn168 - (reLocA $ sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsCharTy (getCHARs happy_var_1) - (getCHAR happy_var_1) - )} - -happyReduce_404 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_404 = happySpecReduce_1 152# happyReduction_404 -happyReduction_404 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn168 - (reLocA $ sLL happy_var_1 happy_var_1 $ HsTyLit noExtField $ HsStrTy (getSTRINGs happy_var_1) - (getSTRING happy_var_1) - )} - -happyReduce_405 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_405 = happySpecReduce_1 152# happyReduction_405 -happyReduction_405 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn168 - (reLocA $ sL1 happy_var_1 $ mkAnonWildCardTy - )} - -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 happyOut153 happy_x_1 of { (HappyWrap153 happy_var_1) -> - happyIn169 - (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 154# happyReduction_407 -happyReduction_407 happy_x_1 - = case happyOut152 happy_x_1 of { (HappyWrap152 happy_var_1) -> - happyIn170 - ([happy_var_1] - )} - -happyReduce_408 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_408 = happyMonadReduce 3# 154# happyReduction_408 -happyReduction_408 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut152 happy_x_1 of { (HappyWrap152 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut170 happy_x_3 of { (HappyWrap170 happy_var_3) -> - ( do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn170 r)) - -happyReduce_409 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_409 = happySpecReduce_1 155# happyReduction_409 -happyReduction_409 happy_x_1 - = case happyOut172 happy_x_1 of { (HappyWrap172 happy_var_1) -> - happyIn171 - (happy_var_1 - )} - -happyReduce_410 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_410 = happySpecReduce_0 155# happyReduction_410 -happyReduction_410 = happyIn171 - ([] - ) - -happyReduce_411 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_411 = happySpecReduce_1 156# happyReduction_411 -happyReduction_411 happy_x_1 - = case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> - happyIn172 - ([happy_var_1] - )} - -happyReduce_412 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_412 = happyMonadReduce 3# 156# happyReduction_412 -happyReduction_412 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut172 happy_x_3 of { (HappyWrap172 happy_var_3) -> - ( do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn172 r)) - -happyReduce_413 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_413 = happyMonadReduce 3# 157# happyReduction_413 -happyReduction_413 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut158 happy_x_3 of { (HappyWrap158 happy_var_3) -> - ( do { h <- addTrailingVbarA happy_var_1 (gl happy_var_2) - ; return [h,happy_var_3] })}}}) - ) (\r -> happyReturn (happyIn173 r)) - -happyReduce_414 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_414 = happyMonadReduce 3# 157# happyReduction_414 -happyReduction_414 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut173 happy_x_3 of { (HappyWrap173 happy_var_3) -> - ( do { h <- addTrailingVbarA happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn173 r)) - -happyReduce_415 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_415 = happySpecReduce_2 158# happyReduction_415 -happyReduction_415 happy_x_2 - happy_x_1 - = case happyOut175 happy_x_1 of { (HappyWrap175 happy_var_1) -> - case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> - happyIn174 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_416 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_416 = happySpecReduce_0 158# happyReduction_416 -happyReduction_416 = happyIn174 - ([] - ) - -happyReduce_417 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_417 = happySpecReduce_1 159# happyReduction_417 -happyReduction_417 happy_x_1 - = case happyOut176 happy_x_1 of { (HappyWrap176 happy_var_1) -> - happyIn175 - (happy_var_1 - )} - -happyReduce_418 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_418 = happyMonadReduce 3# 159# happyReduction_418 -happyReduction_418 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> - 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 (happyIn175 r)) - -happyReduce_419 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_419 = happyMonadReduce 5# 159# happyReduction_419 -happyReduction_419 (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 happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut181 happy_x_4 of { (HappyWrap181 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 (happyIn175 r)) - -happyReduce_420 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_420 = happyMonadReduce 1# 160# happyReduction_420 -happyReduction_420 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut294 happy_x_1 of { (HappyWrap294 happy_var_1) -> - ( acsA (\cs -> (sL1 (reLocN happy_var_1) (UserTyVar (EpAnn (glNR happy_var_1) [] cs) SpecifiedSpec happy_var_1))))}) - ) (\r -> happyReturn (happyIn176 r)) - -happyReduce_421 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_421 = happyMonadReduce 5# 160# happyReduction_421 -happyReduction_421 (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 happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut181 happy_x_4 of { (HappyWrap181 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 (happyIn176 r)) - -happyReduce_422 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_422 = happySpecReduce_0 161# happyReduction_422 -happyReduction_422 = happyIn177 - (noLoc ([],[]) - ) - -happyReduce_423 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_423 = happySpecReduce_2 161# happyReduction_423 -happyReduction_423 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut178 happy_x_2 of { (HappyWrap178 happy_var_2) -> - happyIn177 - ((sLL happy_var_1 happy_var_2 ([mj AnnVbar happy_var_1] - ,reverse (unLoc happy_var_2))) - )}} - -happyReduce_424 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_424 = happyMonadReduce 3# 162# happyReduction_424 -happyReduction_424 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut178 happy_x_1 of { (HappyWrap178 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut179 happy_x_3 of { (HappyWrap179 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 (happyIn178 r)) - -happyReduce_425 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_425 = happySpecReduce_1 162# happyReduction_425 -happyReduction_425 happy_x_1 - = case happyOut179 happy_x_1 of { (HappyWrap179 happy_var_1) -> - happyIn178 - (sL1A happy_var_1 [happy_var_1] - )} - -happyReduce_426 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_426 = happyMonadReduce 3# 163# happyReduction_426 -happyReduction_426 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut180 happy_x_1 of { (HappyWrap180 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut180 happy_x_3 of { (HappyWrap180 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 (happyIn179 r)) - -happyReduce_427 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_427 = happySpecReduce_0 164# happyReduction_427 -happyReduction_427 = happyIn180 - (noLoc [] - ) - -happyReduce_428 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_428 = happySpecReduce_2 164# happyReduction_428 -happyReduction_428 happy_x_2 - happy_x_1 - = case happyOut180 happy_x_1 of { (HappyWrap180 happy_var_1) -> - case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> - happyIn180 - (sLL happy_var_1 (reLocN happy_var_2) (happy_var_2 : (unLoc happy_var_1)) - )}} - -happyReduce_429 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_429 = happySpecReduce_1 165# happyReduction_429 -happyReduction_429 happy_x_1 - = case happyOut159 happy_x_1 of { (HappyWrap159 happy_var_1) -> - happyIn181 - (happy_var_1 - )} - -happyReduce_430 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_430 = happyMonadReduce 4# 166# happyReduction_430 -happyReduction_430 (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 -> - ( 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 (happyIn182 r)) - -happyReduce_431 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_431 = happyMonadReduce 4# 166# happyReduction_431 -happyReduction_431 (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 happyOut183 happy_x_3 of { (HappyWrap183 happy_var_3) -> - ( checkEmptyGADTs $ - L (comb2 happy_var_1 happy_var_3) - ([mj AnnWhere happy_var_1] - , unLoc happy_var_3))}}) - ) (\r -> happyReturn (happyIn182 r)) - -happyReduce_432 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_432 = happySpecReduce_0 166# happyReduction_432 -happyReduction_432 = happyIn182 - (noLoc ([],[]) - ) - -happyReduce_433 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_433 = happyMonadReduce 3# 167# happyReduction_433 -happyReduction_433 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut184 happy_x_1 of { (HappyWrap184 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut183 happy_x_3 of { (HappyWrap183 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 (happyIn183 r)) - -happyReduce_434 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_434 = happySpecReduce_1 167# happyReduction_434 -happyReduction_434 happy_x_1 - = case happyOut184 happy_x_1 of { (HappyWrap184 happy_var_1) -> - happyIn183 - (L (glA happy_var_1) [happy_var_1] - )} - -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 4# 168# happyReduction_436 -happyReduction_436 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut271 happy_x_2 of { (HappyWrap271 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut153 happy_x_4 of { (HappyWrap153 happy_var_4) -> - ( mkGadtDecl (comb2A happy_var_2 happy_var_4) (unLoc happy_var_2) happy_var_4 [mu AnnDcolon 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_2 169# happyReduction_437 -happyReduction_437 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) -> - happyIn185 - (sLL happy_var_1 happy_var_2 ([mj AnnEqual happy_var_1],unLoc happy_var_2) - )}} - -happyReduce_438 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_438 = happyMonadReduce 3# 170# happyReduction_438 -happyReduction_438 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut186 happy_x_1 of { (HappyWrap186 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut187 happy_x_3 of { (HappyWrap187 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 (happyIn186 r)) - -happyReduce_439 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_439 = happySpecReduce_1 170# happyReduction_439 -happyReduction_439 happy_x_1 - = case happyOut187 happy_x_1 of { (HappyWrap187 happy_var_1) -> - happyIn186 - (sL1A happy_var_1 [happy_var_1] - )} - -happyReduce_440 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_440 = happyMonadReduce 4# 171# happyReduction_440 -happyReduction_440 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut188 happy_x_1 of { (HappyWrap188 happy_var_1) -> - case happyOut160 happy_x_2 of { (HappyWrap160 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut189 happy_x_4 of { (HappyWrap189 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 (happyIn187 r)) - -happyReduce_441 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_441 = happyMonadReduce 2# 171# happyReduction_441 -happyReduction_441 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut188 happy_x_1 of { (HappyWrap188 happy_var_1) -> - case happyOut189 happy_x_2 of { (HappyWrap189 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 (happyIn187 r)) - -happyReduce_442 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_442 = happySpecReduce_3 172# happyReduction_442 -happyReduction_442 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut174 happy_x_2 of { (HappyWrap174 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn188 - (sLL happy_var_1 happy_var_3 ([mu AnnForall happy_var_1,mj AnnDot happy_var_3], Just happy_var_2) - )}}} - -happyReduce_443 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_443 = happySpecReduce_0 172# happyReduction_443 -happyReduction_443 = happyIn188 - (noLoc ([], Nothing) - ) - -happyReduce_444 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_444 = happyMonadReduce 1# 173# happyReduction_444 -happyReduction_444 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut164 happy_x_1 of { (HappyWrap164 happy_var_1) -> - ( fmap (reLoc. (mapLoc (\b -> (dataConBuilderCon b, - dataConBuilderDetails b)))) - (runPV happy_var_1))}) - ) (\r -> happyReturn (happyIn189 r)) - -happyReduce_445 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_445 = happySpecReduce_0 174# happyReduction_445 -happyReduction_445 = happyIn190 - ([] - ) - -happyReduce_446 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_446 = happySpecReduce_1 174# happyReduction_446 -happyReduction_446 happy_x_1 - = case happyOut191 happy_x_1 of { (HappyWrap191 happy_var_1) -> - happyIn190 - (happy_var_1 - )} - -happyReduce_447 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_447 = happyMonadReduce 3# 175# happyReduction_447 -happyReduction_447 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut192 happy_x_1 of { (HappyWrap192 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut191 happy_x_3 of { (HappyWrap191 happy_var_3) -> - ( do { h <- addTrailingCommaA happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn191 r)) - -happyReduce_448 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_448 = happySpecReduce_1 175# happyReduction_448 -happyReduction_448 happy_x_1 - = case happyOut192 happy_x_1 of { (HappyWrap192 happy_var_1) -> - happyIn191 - ([happy_var_1] - )} - -happyReduce_449 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_449 = happyMonadReduce 3# 176# happyReduction_449 -happyReduction_449 (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 happyOut159 happy_x_3 of { (HappyWrap159 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 (happyIn192 r)) - -happyReduce_450 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_450 = happySpecReduce_0 177# happyReduction_450 -happyReduction_450 = happyIn193 - (noLoc [] - ) - -happyReduce_451 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_451 = happySpecReduce_1 177# happyReduction_451 -happyReduction_451 happy_x_1 - = case happyOut194 happy_x_1 of { (HappyWrap194 happy_var_1) -> - happyIn193 - (happy_var_1 - )} - -happyReduce_452 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_452 = happySpecReduce_2 178# happyReduction_452 -happyReduction_452 happy_x_2 - happy_x_1 - = case happyOut194 happy_x_1 of { (HappyWrap194 happy_var_1) -> - case happyOut195 happy_x_2 of { (HappyWrap195 happy_var_2) -> - happyIn194 - (sLL happy_var_1 (reLoc happy_var_2) (happy_var_2 : unLoc happy_var_1) - )}} - -happyReduce_453 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_453 = happySpecReduce_1 178# happyReduction_453 -happyReduction_453 happy_x_1 - = case happyOut195 happy_x_1 of { (HappyWrap195 happy_var_1) -> - happyIn194 - (sL1 (reLoc happy_var_1) [happy_var_1] - )} - -happyReduce_454 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_454 = happyMonadReduce 2# 179# happyReduction_454 -happyReduction_454 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut196 happy_x_2 of { (HappyWrap196 happy_var_2) -> - ( 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 (happyIn195 r)) - -happyReduce_455 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_455 = happyMonadReduce 3# 179# happyReduction_455 -happyReduction_455 (happy_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 happyOut196 happy_x_3 of { (HappyWrap196 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 (happyIn195 r)) - -happyReduce_456 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_456 = happyMonadReduce 3# 179# happyReduction_456 -happyReduction_456 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut196 happy_x_2 of { (HappyWrap196 happy_var_2) -> - case 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 (happyIn195 r)) - -happyReduce_457 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_457 = happySpecReduce_1 180# happyReduction_457 -happyReduction_457 happy_x_1 - = case happyOut282 happy_x_1 of { (HappyWrap282 happy_var_1) -> - happyIn196 - (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_458 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_458 = happyMonadReduce 2# 180# happyReduction_458 -happyReduction_458 (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 (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 happyOut170 happy_x_2 of { (HappyWrap170 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 (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 happyOut202 happy_x_1 of { (HappyWrap202 happy_var_1) -> - happyIn197 - (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# 181# happyReduction_461 -happyReduction_461 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - case happyOut150 happy_x_2 of { (HappyWrap150 happy_var_2) -> - case happyOut199 happy_x_3 of { (HappyWrap199 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 (happyIn197 r)) - -happyReduce_462 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_462 = happySpecReduce_1 181# happyReduction_462 -happyReduction_462 happy_x_1 - = case happyOut112 happy_x_1 of { (HappyWrap112 happy_var_1) -> - happyIn197 - (happy_var_1 - )} - -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 happyOut197 happy_x_1 of { (HappyWrap197 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 1# 182# happyReduction_464 -happyReduction_464 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut217 happy_x_1 of { (HappyWrap217 happy_var_1) -> - ( mkSpliceDecl happy_var_1)}) - ) (\r -> happyReturn (happyIn198 r)) - -happyReduce_465 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_465 = happyMonadReduce 3# 183# happyReduction_465 -happyReduction_465 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> - case happyOut130 happy_x_3 of { (HappyWrap130 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 (happyIn199 r)) - -happyReduce_466 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_466 = happyMonadReduce 2# 183# happyReduction_466 -happyReduction_466 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut200 happy_x_1 of { (HappyWrap200 happy_var_1) -> - case happyOut130 happy_x_2 of { (HappyWrap130 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 (happyIn199 r)) - -happyReduce_467 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_467 = happySpecReduce_2 184# happyReduction_467 -happyReduction_467 happy_x_2 - happy_x_1 - = case happyOut200 happy_x_1 of { (HappyWrap200 happy_var_1) -> - case happyOut201 happy_x_2 of { (HappyWrap201 happy_var_2) -> - happyIn200 - (sLL happy_var_1 (reLoc happy_var_2) (happy_var_2 : unLoc happy_var_1) - )}} - -happyReduce_468 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_468 = happySpecReduce_1 184# happyReduction_468 -happyReduction_468 happy_x_1 - = case happyOut201 happy_x_1 of { (HappyWrap201 happy_var_1) -> - happyIn200 - (sL1 (reLoc happy_var_1) [happy_var_1] - )} - -happyReduce_469 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_469 = happyMonadReduce 4# 185# happyReduction_469 -happyReduction_469 (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 happyOut234 happy_x_2 of { (HappyWrap234 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut206 happy_x_4 of { (HappyWrap206 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 (happyIn201 r)) - -happyReduce_470 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_470 = happyMonadReduce 3# 186# happyReduction_470 -happyReduction_470 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut153 happy_x_3 of { (HappyWrap153 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 (happyIn202 r)) - -happyReduce_471 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_471 = happyMonadReduce 5# 186# happyReduction_471 -happyReduction_471 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - 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 happyOut154 happy_x_3 of { (HappyWrap154 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut153 happy_x_5 of { (HappyWrap153 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 (happyIn202 r)) - -happyReduce_472 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_472 = happyMonadReduce 3# 186# happyReduction_472 -happyReduction_472 (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 (happyIn202 r)) - -happyReduce_473 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_473 = happySpecReduce_1 186# happyReduction_473 -happyReduction_473 happy_x_1 - = case happyOut117 happy_x_1 of { (HappyWrap117 happy_var_1) -> - happyIn202 - (sL1 happy_var_1 . SigD noExtField . unLoc $ happy_var_1 - )} - -happyReduce_474 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_474 = happyMonadReduce 4# 186# happyReduction_474 -happyReduction_474 (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 happyOut151 happy_x_3 of { (HappyWrap151 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 (happyIn202 r)) - -happyReduce_475 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_475 = happyMonadReduce 4# 186# happyReduction_475 -happyReduction_475 (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 happyOut203 happy_x_2 of { (HappyWrap203 happy_var_2) -> - case happyOut118 happy_x_3 of { (HappyWrap118 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 (happyIn202 r)) - -happyReduce_476 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_476 = happyMonadReduce 3# 186# happyReduction_476 -happyReduction_476 (happy_x_3 `HappyStk` - 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) -> - 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 (happyIn202 r)) - -happyReduce_477 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_477 = happyMonadReduce 3# 186# happyReduction_477 -happyReduction_477 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut298 happy_x_2 of { (HappyWrap298 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 (happyIn202 r)) - -happyReduce_478 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_478 = happyMonadReduce 4# 186# 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 happyOut298 happy_x_2 of { (HappyWrap298 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 (happyIn202 r)) - -happyReduce_479 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_479 = happyMonadReduce 6# 186# happyReduction_479 -happyReduction_479 (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 happyOut203 happy_x_2 of { (HappyWrap203 happy_var_2) -> - case happyOut298 happy_x_3 of { (HappyWrap298 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut155 happy_x_5 of { (HappyWrap155 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 (happyIn202 r)) - -happyReduce_480 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_480 = happyMonadReduce 6# 186# happyReduction_480 -happyReduction_480 (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 happyOut203 happy_x_2 of { (HappyWrap203 happy_var_2) -> - case happyOut298 happy_x_3 of { (HappyWrap298 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut155 happy_x_5 of { (HappyWrap155 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 (happyIn202 r)) - -happyReduce_481 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_481 = happyMonadReduce 4# 186# 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 happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut169 happy_x_3 of { (HappyWrap169 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 (happyIn202 r)) - -happyReduce_482 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_482 = happyMonadReduce 3# 186# happyReduction_482 -happyReduction_482 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut260 happy_x_2 of { (HappyWrap260 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 (happyIn202 r)) - -happyReduce_483 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_483 = happySpecReduce_0 187# happyReduction_483 -happyReduction_483 = happyIn203 - (([],Nothing) - ) - -happyReduce_484 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_484 = happySpecReduce_1 187# happyReduction_484 -happyReduction_484 happy_x_1 - = case happyOut204 happy_x_1 of { (HappyWrap204 happy_var_1) -> - happyIn203 - ((fst happy_var_1,Just (snd happy_var_1)) - )} - -happyReduce_485 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_485 = happySpecReduce_3 188# happyReduction_485 -happyReduction_485 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 -> - happyIn204 - (([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_486 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_486 = happyReduce 4# 188# happyReduction_486 -happyReduction_486 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut134 happy_x_2 of { (HappyWrap134 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn204 - ((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_487 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_487 = happySpecReduce_1 189# happyReduction_487 -happyReduction_487 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn205 - (let { loc = getLoc happy_var_1 - ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc happy_var_1 - ; quoterId = mkUnqual varName quoter } - in sL1 happy_var_1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) - )} - -happyReduce_488 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_488 = happySpecReduce_1 189# happyReduction_488 -happyReduction_488 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn205 - (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 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) - )} - -happyReduce_489 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_489 = happySpecReduce_3 190# happyReduction_489 -happyReduction_489 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 happyOut159 happy_x_3 of { (HappyWrap159 happy_var_3) -> - happyIn206 - (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_490 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_490 = happyMonadReduce 3# 190# happyReduction_490 -happyReduction_490 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut206 happy_x_3 of { (HappyWrap206 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 (happyIn206 r)) - -happyReduce_491 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_491 = happyMonadReduce 3# 190# happyReduction_491 -happyReduction_491 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut206 happy_x_3 of { (HappyWrap206 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 (happyIn206 r)) - -happyReduce_492 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_492 = happyMonadReduce 3# 190# happyReduction_492 -happyReduction_492 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut206 happy_x_3 of { (HappyWrap206 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 (happyIn206 r)) - -happyReduce_493 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_493 = happyMonadReduce 3# 190# happyReduction_493 -happyReduction_493 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut206 happy_x_3 of { (HappyWrap206 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 (happyIn206 r)) - -happyReduce_494 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_494 = happySpecReduce_1 190# happyReduction_494 -happyReduction_494 happy_x_1 - = case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - happyIn206 - (happy_var_1 - )} - -happyReduce_495 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_495 = happySpecReduce_1 190# happyReduction_495 -happyReduction_495 happy_x_1 - = case happyOut321 happy_x_1 of { (HappyWrap321 happy_var_1) -> - happyIn206 - (happy_var_1 - )} - -happyReduce_496 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_496 = happySpecReduce_1 191# happyReduction_496 -happyReduction_496 happy_x_1 - = case happyOut209 happy_x_1 of { (HappyWrap209 happy_var_1) -> - happyIn207 - (happy_var_1 - )} - -happyReduce_497 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_497 = happySpecReduce_3 191# happyReduction_497 -happyReduction_497 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - case happyOut289 happy_x_2 of { (HappyWrap289 happy_var_2) -> - case happyOut208 happy_x_3 of { (HappyWrap208 happy_var_3) -> - happyIn207 - (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_498 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_498 = happySpecReduce_1 192# happyReduction_498 -happyReduction_498 happy_x_1 - = case happyOut209 happy_x_1 of { (HappyWrap209 happy_var_1) -> - happyIn208 - (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 happyOut322 happy_x_1 of { (HappyWrap322 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_2 193# happyReduction_500 -happyReduction_500 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut212 happy_x_2 of { (HappyWrap212 happy_var_2) -> - happyIn209 - (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_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 happyOut212 happy_x_1 of { (HappyWrap212 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 194# happyReduction_502 -happyReduction_502 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn210 - ((msemim happy_var_1,True) - )} - -happyReduce_503 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_503 = happySpecReduce_0 194# happyReduction_503 -happyReduction_503 = happyIn210 - ((Nothing,False) - ) - -happyReduce_504 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_504 = happyMonadReduce 3# 195# happyReduction_504 -happyReduction_504 (happy_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 (happyIn211 r)) - -happyReduce_505 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_505 = happyMonadReduce 3# 195# 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 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 (happyIn211 r)) - -happyReduce_506 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_506 = happySpecReduce_2 196# happyReduction_506 -happyReduction_506 happy_x_2 - happy_x_1 - = case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> - case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> - happyIn212 - (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_507 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_507 = happySpecReduce_3 196# happyReduction_507 -happyReduction_507 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut212 happy_x_1 of { (HappyWrap212 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut168 happy_x_3 of { (HappyWrap168 happy_var_3) -> - happyIn212 - (ECP $ - unECP happy_var_1 >>= \ happy_var_1 -> - mkHsAppTypePV (noAnnSrcSpan $ comb2 (reLoc happy_var_1) (reLoc happy_var_3)) happy_var_1 (getLoc happy_var_2) happy_var_3 - )}}} - -happyReduce_508 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_508 = happyMonadReduce 2# 196# happyReduction_508 -happyReduction_508 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> - ( 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 (happyIn212 r)) - -happyReduce_509 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_509 = happySpecReduce_1 196# happyReduction_509 -happyReduction_509 happy_x_1 - = case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - happyIn212 - (happy_var_1 - )} - -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 happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut213 happy_x_3 of { (HappyWrap213 happy_var_3) -> - happyIn213 - (ECP $ - unECP happy_var_3 >>= \ happy_var_3 -> - mkHsAsPatPV (comb2 (reLocN happy_var_1) (reLoc happy_var_3)) happy_var_1 happy_var_3 [mj AnnAt happy_var_2] - )}}} - -happyReduce_511 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_511 = happySpecReduce_2 197# happyReduction_511 -happyReduction_511 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) -> - happyIn213 - (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_512 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_512 = happySpecReduce_2 197# happyReduction_512 -happyReduction_512 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) -> - happyIn213 - (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_513 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_513 = happySpecReduce_2 197# happyReduction_513 -happyReduction_513 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) -> - happyIn213 - (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_514 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_514 = happyReduce 4# 197# happyReduction_514 -happyReduction_514 (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 happyOut245 happy_x_2 of { (HappyWrap245 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut206 happy_x_4 of { (HappyWrap206 happy_var_4) -> - happyIn213 - (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_515 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_515 = happyReduce 4# 197# happyReduction_515 -happyReduction_515 (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 happyOut129 happy_x_2 of { (HappyWrap129 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut206 happy_x_4 of { (HappyWrap206 happy_var_4) -> - happyIn213 - (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_516 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_516 = happySpecReduce_3 197# happyReduction_516 -happyReduction_516 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) -> - happyIn213 - (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_517 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_517 = happySpecReduce_3 197# happyReduction_517 -happyReduction_517 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 happyOut319 happy_x_3 of { (HappyWrap319 happy_var_3) -> - happyIn213 - (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_518 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_518 = happyMonadReduce 8# 197# happyReduction_518 -happyReduction_518 (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 happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> - case happyOut210 happy_x_3 of { (HappyWrap210 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut206 happy_x_5 of { (HappyWrap206 happy_var_5) -> - case happyOut210 happy_x_6 of { (HappyWrap210 happy_var_6) -> - case happyOutTok happy_x_7 of { happy_var_7 -> - case happyOut206 happy_x_8 of { (HappyWrap206 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 (happyIn213 r)) - -happyReduce_519 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_519 = happyMonadReduce 2# 197# happyReduction_519 -happyReduction_519 (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) -> - ( 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 (happyIn213 r)) - -happyReduce_520 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_520 = happyMonadReduce 4# 197# happyReduction_520 -happyReduction_520 (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 happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut320 happy_x_4 of { (HappyWrap320 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 (happyIn213 r)) - -happyReduce_521 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_521 = happyMonadReduce 2# 197# happyReduction_521 -happyReduction_521 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut246 happy_x_2 of { (HappyWrap246 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 (happyIn213 r)) - -happyReduce_522 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_522 = happyMonadReduce 2# 197# 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 happyOut246 happy_x_2 of { (HappyWrap246 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 (happyIn213 r)) - -happyReduce_523 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_523 = happyMonadReduce 4# 197# 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 happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut206 happy_x_4 of { (HappyWrap206 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 (happyIn213 r)) - -happyReduce_524 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_524 = happySpecReduce_1 197# happyReduction_524 -happyReduction_524 happy_x_1 - = case happyOut214 happy_x_1 of { (HappyWrap214 happy_var_1) -> - happyIn213 - (happy_var_1 - )} - -happyReduce_525 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_525 = happyReduce 4# 198# happyReduction_525 -happyReduction_525 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut214 happy_x_1 of { (HappyWrap214 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut252 happy_x_3 of { (HappyWrap252 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn214 - (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_526 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_526 = happyMonadReduce 3# 198# happyReduction_526 -happyReduction_526 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut214 happy_x_1 of { (HappyWrap214 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut299 happy_x_3 of { (HappyWrap299 happy_var_3) -> - ( runPV (unECP happy_var_1) >>= \ happy_var_1 -> - fmap ecpFromExp $ acsa (\cs -> - let fl = sLLa happy_var_2 happy_var_3 (DotFieldOcc ((EpAnn (glR happy_var_2) (AnnFieldLabel (Just $ glAA happy_var_2)) emptyComments)) (reLocA happy_var_3)) in - mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc happy_var_1) happy_var_3) happy_var_1 fl (EpAnn (glAR happy_var_1) NoEpAnns cs)))}}}) - ) (\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 = happySpecReduce_1 199# happyReduction_528 -happyReduction_528 happy_x_1 - = case happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> - happyIn215 - (ECP $ mkHsVarPV $! happy_var_1 - )} - -happyReduce_529 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_529 = happySpecReduce_1 199# happyReduction_529 -happyReduction_529 happy_x_1 - = case happyOut268 happy_x_1 of { (HappyWrap268 happy_var_1) -> - happyIn215 - (ECP $ mkHsVarPV $! happy_var_1 - )} - -happyReduce_530 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_530 = happyMonadReduce 1# 199# happyReduction_530 -happyReduction_530 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut258 happy_x_1 of { (HappyWrap258 happy_var_1) -> - ( acsExpr (\cs -> sL1a happy_var_1 (HsIPVar (comment (glRR happy_var_1) cs) $! unLoc happy_var_1)))}) - ) (\r -> happyReturn (happyIn215 r)) - -happyReduce_531 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_531 = happyMonadReduce 1# 199# happyReduction_531 -happyReduction_531 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut259 happy_x_1 of { (HappyWrap259 happy_var_1) -> - ( acsExpr (\cs -> sL1a happy_var_1 (HsOverLabel (comment (glRR happy_var_1) cs) $! unLoc happy_var_1)))}) - ) (\r -> happyReturn (happyIn215 r)) - -happyReduce_532 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_532 = happySpecReduce_1 199# happyReduction_532 -happyReduction_532 happy_x_1 - = case happyOut313 happy_x_1 of { (HappyWrap313 happy_var_1) -> - happyIn215 - (ECP $ pvA (mkHsLitPV $! 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 199# happyReduction_533 -happyReduction_533 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn215 - (ECP $ mkHsOverLitPV (sL1a happy_var_1 $ mkHsIntegral (getINTEGER happy_var_1)) - )} - -happyReduce_534 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_534 = happySpecReduce_1 199# happyReduction_534 -happyReduction_534 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn215 - (ECP $ mkHsOverLitPV (sL1a happy_var_1 $ mkHsFractional (getRATIONAL happy_var_1)) - )} - -happyReduce_535 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_535 = happySpecReduce_3 199# happyReduction_535 -happyReduction_535 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 -> - happyIn215 - (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_536 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_536 = happySpecReduce_3 199# happyReduction_536 -happyReduction_536 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 -> - happyIn215 - (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_537 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_537 = happySpecReduce_3 199# happyReduction_537 -happyReduction_537 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut216 happy_x_2 of { (HappyWrap216 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn215 - (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_538 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_538 = happySpecReduce_3 199# happyReduction_538 -happyReduction_538 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 -> - happyIn215 - (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_539 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_539 = happySpecReduce_3 199# happyReduction_539 -happyReduction_539 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 -> - happyIn215 - (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_540 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_540 = happySpecReduce_3 199# happyReduction_540 -happyReduction_540 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut228 happy_x_2 of { (HappyWrap228 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn215 - (ECP $ happy_var_2 (comb2 happy_var_1 happy_var_3) (mos happy_var_1,mcs 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 199# happyReduction_541 -happyReduction_541 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn215 - (ECP $ pvA $ mkHsWildCardPV (getLoc 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 199# happyReduction_542 -happyReduction_542 happy_x_1 - = case happyOut218 happy_x_1 of { (HappyWrap218 happy_var_1) -> - happyIn215 - (ECP $ pvA $ mkHsSplicePV happy_var_1 - )} - -happyReduce_543 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_543 = happySpecReduce_1 199# happyReduction_543 -happyReduction_543 happy_x_1 - = case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> - happyIn215 - (ecpFromExp $ mapLoc (HsSpliceE noAnn) (reLocA happy_var_1) - )} - -happyReduce_544 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_544 = happyMonadReduce 2# 199# happyReduction_544 -happyReduction_544 (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) -> - ( 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 (happyIn215 r)) - -happyReduce_545 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_545 = happyMonadReduce 2# 199# happyReduction_545 -happyReduction_545 (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) -> - ( 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 (happyIn215 r)) - -happyReduce_546 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_546 = happyMonadReduce 2# 199# happyReduction_546 -happyReduction_546 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut294 happy_x_2 of { (HappyWrap294 happy_var_2) -> - ( 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 (happyIn215 r)) - -happyReduce_547 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_547 = happyMonadReduce 2# 199# 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 happyOut277 happy_x_2 of { (HappyWrap277 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 (happyIn215 r)) - -happyReduce_548 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_548 = happyMonadReduce 1# 199# happyReduction_548 -happyReduction_548 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - ( reportEmptyDoubleQuotes (getLoc happy_var_1))}) - ) (\r -> happyReturn (happyIn215 r)) - -happyReduce_549 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_549 = happyMonadReduce 3# 199# happyReduction_549 -happyReduction_549 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut206 happy_x_2 of { (HappyWrap206 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 (happyIn215 r)) - -happyReduce_550 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_550 = happyMonadReduce 3# 199# happyReduction_550 -happyReduction_550 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut206 happy_x_2 of { (HappyWrap206 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 (happyIn215 r)) - -happyReduce_551 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_551 = happyMonadReduce 3# 199# happyReduction_551 -happyReduction_551 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut158 happy_x_2 of { (HappyWrap158 happy_var_2) -> - 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 (happyIn215 r)) - -happyReduce_552 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_552 = happyMonadReduce 3# 199# 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 -> - ( (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 (happyIn215 r)) - -happyReduce_553 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_553 = happyMonadReduce 3# 199# 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 happyOut222 happy_x_2 of { (HappyWrap222 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 (happyIn215 r)) - -happyReduce_554 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_554 = happySpecReduce_1 199# happyReduction_554 -happyReduction_554 happy_x_1 - = case happyOut205 happy_x_1 of { (HappyWrap205 happy_var_1) -> - happyIn215 - (ECP $ pvA $ mkHsSplicePV happy_var_1 - )} - -happyReduce_555 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_555 = happyMonadReduce 4# 199# happyReduction_555 -happyReduction_555 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut213 happy_x_2 of { (HappyWrap213 happy_var_2) -> - case happyOut220 happy_x_3 of { (HappyWrap220 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 (happyIn215 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 happyOut216 happy_x_1 of { (HappyWrap216 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut299 happy_x_3 of { (HappyWrap299 happy_var_3) -> - ( acs (\cs -> sLL happy_var_1 happy_var_3 ((sLLa happy_var_2 happy_var_3 $ DotFieldOcc (EpAnn (glR happy_var_1) (AnnFieldLabel (Just $ glAA happy_var_2)) cs) (reLocA happy_var_3)) `NE.cons` unLoc happy_var_1)))}}}) - ) (\r -> happyReturn (happyIn216 r)) - -happyReduce_557 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_557 = happyMonadReduce 2# 200# happyReduction_557 -happyReduction_557 (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) -> - ( acs (\cs -> sLL happy_var_1 happy_var_2 ((sLLa happy_var_1 happy_var_2 $ DotFieldOcc (EpAnn (glR happy_var_1) (AnnFieldLabel (Just $ glAA happy_var_1)) cs) (reLocA happy_var_2)) :| [])))}}) - ) (\r -> happyReturn (happyIn216 r)) - -happyReduce_558 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_558 = happySpecReduce_1 201# happyReduction_558 -happyReduction_558 happy_x_1 - = case happyOut218 happy_x_1 of { (HappyWrap218 happy_var_1) -> - happyIn217 - (mapLoc (HsSpliceE noAnn) (reLocA happy_var_1) - )} - -happyReduce_559 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_559 = happySpecReduce_1 201# happyReduction_559 -happyReduction_559 happy_x_1 - = case happyOut219 happy_x_1 of { (HappyWrap219 happy_var_1) -> - happyIn217 - (mapLoc (HsSpliceE noAnn) (reLocA happy_var_1) - )} - -happyReduce_560 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_560 = happyMonadReduce 2# 202# 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 happyOut215 happy_x_2 of { (HappyWrap215 happy_var_2) -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - acs (\cs -> sLLlA happy_var_1 happy_var_2 $ mkUntypedSplice (EpAnn (glR happy_var_1) [mj AnnDollar happy_var_1] cs) DollarSplice happy_var_2))}}) - ) (\r -> happyReturn (happyIn218 r)) - -happyReduce_561 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_561 = happyMonadReduce 2# 203# happyReduction_561 -happyReduction_561 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut215 happy_x_2 of { (HappyWrap215 happy_var_2) -> - ( runPV (unECP happy_var_2) >>= \ happy_var_2 -> - acs (\cs -> sLLlA happy_var_1 happy_var_2 $ mkTypedSplice (EpAnn (glR happy_var_1) [mj AnnDollarDollar happy_var_1] cs) DollarSplice happy_var_2))}}) - ) (\r -> happyReturn (happyIn219 r)) - -happyReduce_562 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_562 = happySpecReduce_2 204# happyReduction_562 -happyReduction_562 happy_x_2 - happy_x_1 - = case happyOut220 happy_x_1 of { (HappyWrap220 happy_var_1) -> - case happyOut221 happy_x_2 of { (HappyWrap221 happy_var_2) -> - happyIn220 - (happy_var_2 : happy_var_1 - )}} - -happyReduce_563 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_563 = happySpecReduce_0 204# happyReduction_563 -happyReduction_563 = happyIn220 - ([] - ) - -happyReduce_564 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_564 = happyMonadReduce 1# 205# happyReduction_564 -happyReduction_564 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - ( runPV (unECP happy_var_1) >>= \ (cmd :: LHsCmd GhcPs) -> - runPV (checkCmdBlockArguments cmd) >>= \ _ -> - return (sL1a (reLoc cmd) $ HsCmdTop noExtField cmd))}) - ) (\r -> happyReturn (happyIn221 r)) - -happyReduce_565 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_565 = happySpecReduce_3 206# happyReduction_565 -happyReduction_565 happy_x_3 - happy_x_2 - happy_x_1 - = 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 -> - happyIn222 - (([mj AnnOpenC happy_var_1 - ,mj AnnCloseC happy_var_3],happy_var_2) - )}}} - -happyReduce_566 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_566 = happySpecReduce_3 206# happyReduction_566 -happyReduction_566 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut223 happy_x_2 of { (HappyWrap223 happy_var_2) -> - happyIn222 - (([],happy_var_2) - )} - -happyReduce_567 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_567 = happySpecReduce_1 207# happyReduction_567 -happyReduction_567 happy_x_1 - = case happyOut74 happy_x_1 of { (HappyWrap74 happy_var_1) -> - happyIn223 - (cvTopDecls happy_var_1 - )} - -happyReduce_568 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_568 = happySpecReduce_1 207# happyReduction_568 -happyReduction_568 happy_x_1 - = case happyOut73 happy_x_1 of { (HappyWrap73 happy_var_1) -> - happyIn223 - (cvTopDecls happy_var_1 - )} - -happyReduce_569 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_569 = happySpecReduce_1 208# happyReduction_569 -happyReduction_569 happy_x_1 - = case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> - happyIn224 - (happy_var_1 - )} - -happyReduce_570 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_570 = happyMonadReduce 2# 208# happyReduction_570 -happyReduction_570 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut207 happy_x_1 of { (HappyWrap207 happy_var_1) -> - case happyOut289 happy_x_2 of { (HappyWrap289 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 (happyIn224 r)) - -happyReduce_571 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_571 = happySpecReduce_2 208# happyReduction_571 -happyReduction_571 happy_x_2 - happy_x_1 - = case happyOut290 happy_x_1 of { (HappyWrap290 happy_var_1) -> - case happyOut207 happy_x_2 of { (HappyWrap207 happy_var_2) -> - happyIn224 - (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_572 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_572 = happySpecReduce_3 208# happyReduction_572 -happyReduction_572 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut224 happy_x_3 of { (HappyWrap224 happy_var_3) -> - happyIn224 - (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_573 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_573 = happySpecReduce_2 209# happyReduction_573 -happyReduction_573 happy_x_2 - happy_x_1 - = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> - case happyOut226 happy_x_2 of { (HappyWrap226 happy_var_2) -> - happyIn225 - (unECP happy_var_1 >>= \ happy_var_1 -> - happy_var_2 >>= \ happy_var_2 -> - do { t <- amsA happy_var_1 [AddCommaAnn (EpaSpan $ rs $ fst happy_var_2)] - ; return (Tuple (Right t : snd happy_var_2)) } - )}} - -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 happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> - case happyOut227 happy_x_2 of { (HappyWrap227 happy_var_2) -> - happyIn225 - (happy_var_2 >>= \ happy_var_2 -> - do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (EpaSpan $ rs ll) emptyComments))) (fst happy_var_1) } - ; return (Tuple (cos ++ happy_var_2)) } - )}} - -happyReduce_575 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_575 = happySpecReduce_2 209# happyReduction_575 -happyReduction_575 happy_x_2 - happy_x_1 - = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> - case happyOut318 happy_x_2 of { (HappyWrap318 happy_var_2) -> - happyIn225 - (unECP happy_var_1 >>= \ happy_var_1 -> return $ - (Sum 1 (snd happy_var_2 + 1) happy_var_1 [] (map (EpaSpan . realSrcSpan) $ fst happy_var_2)) - )}} - -happyReduce_576 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_576 = happySpecReduce_3 209# happyReduction_576 -happyReduction_576 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut318 happy_x_1 of { (HappyWrap318 happy_var_1) -> - case happyOut224 happy_x_2 of { (HappyWrap224 happy_var_2) -> - case happyOut317 happy_x_3 of { (HappyWrap317 happy_var_3) -> - happyIn225 - (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 (EpaSpan . realSrcSpan) $ fst happy_var_1) - (map (EpaSpan . realSrcSpan) $ fst happy_var_3)) - )}}} - -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 happyOut316 happy_x_1 of { (HappyWrap316 happy_var_1) -> - case happyOut227 happy_x_2 of { (HappyWrap227 happy_var_2) -> - happyIn226 - (happy_var_2 >>= \ happy_var_2 -> - do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (EpaSpan $ rs l) emptyComments))) (tail $ fst happy_var_1) } - ; return ((head $ fst happy_var_1, 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 211# happyReduction_578 -happyReduction_578 happy_x_2 - happy_x_1 - = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> - case happyOut226 happy_x_2 of { (HappyWrap226 happy_var_2) -> - happyIn227 - (unECP happy_var_1 >>= \ happy_var_1 -> - happy_var_2 >>= \ happy_var_2 -> - do { t <- amsA happy_var_1 [AddCommaAnn (EpaSpan $ rs $ fst happy_var_2)] - ; return (Right t : snd happy_var_2) } - )}} - -happyReduce_579 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_579 = happySpecReduce_1 211# happyReduction_579 -happyReduction_579 happy_x_1 - = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> - happyIn227 - (unECP happy_var_1 >>= \ happy_var_1 -> - return [Right happy_var_1] - )} - -happyReduce_580 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_580 = happySpecReduce_0 211# happyReduction_580 -happyReduction_580 = happyIn227 - (return [Left noAnn] - ) - -happyReduce_581 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_581 = happySpecReduce_1 212# happyReduction_581 -happyReduction_581 happy_x_1 - = case happyOut224 happy_x_1 of { (HappyWrap224 happy_var_1) -> - happyIn228 - (\loc (ao,ac) -> unECP happy_var_1 >>= \ happy_var_1 -> - mkHsExplicitListPV loc [happy_var_1] (AnnList Nothing (Just ao) (Just ac) [] []) - )} - -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 happyOut229 happy_x_1 of { (HappyWrap229 happy_var_1) -> - happyIn228 - (\loc (ao,ac) -> happy_var_1 >>= \ happy_var_1 -> - mkHsExplicitListPV loc (reverse happy_var_1) (AnnList Nothing (Just ao) (Just ac) [] []) - )} - -happyReduce_583 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_583 = happySpecReduce_2 212# happyReduction_583 -happyReduction_583 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 -> - happyIn228 - (\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_584 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_584 = happyReduce 4# 212# happyReduction_584 -happyReduction_584 (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 happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut206 happy_x_3 of { (HappyWrap206 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn228 - (\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_585 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_585 = happySpecReduce_3 212# happyReduction_585 -happyReduction_585 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 happyOut206 happy_x_3 of { (HappyWrap206 happy_var_3) -> - happyIn228 - (\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_586 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_586 = happyReduce 5# 212# happyReduction_586 -happyReduction_586 (happy_x_5 `HappyStk` - 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 happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut206 happy_x_3 of { (HappyWrap206 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut206 happy_x_5 of { (HappyWrap206 happy_var_5) -> - happyIn228 - (\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_587 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_587 = happySpecReduce_3 212# happyReduction_587 -happyReduction_587 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 happyOut230 happy_x_3 of { (HappyWrap230 happy_var_3) -> - happyIn228 - (\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_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 happyOut229 happy_x_1 of { (HappyWrap229 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut224 happy_x_3 of { (HappyWrap224 happy_var_3) -> - happyIn229 - (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_589 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_589 = happySpecReduce_3 213# happyReduction_589 -happyReduction_589 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 happyOut224 happy_x_3 of { (HappyWrap224 happy_var_3) -> - happyIn229 - (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_590 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_590 = happySpecReduce_1 214# happyReduction_590 -happyReduction_590 happy_x_1 - = case happyOut231 happy_x_1 of { (HappyWrap231 happy_var_1) -> - happyIn230 - (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_591 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_591 = happyMonadReduce 3# 215# happyReduction_591 -happyReduction_591 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut232 happy_x_1 of { (HappyWrap232 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut231 happy_x_3 of { (HappyWrap231 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 (happyIn231 r)) - -happyReduce_592 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_592 = happySpecReduce_1 215# happyReduction_592 -happyReduction_592 happy_x_1 - = case happyOut232 happy_x_1 of { (HappyWrap232 happy_var_1) -> - happyIn231 - (L (getLoc happy_var_1) [reverse (unLoc happy_var_1)] - )} - -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 happyOut232 happy_x_1 of { (HappyWrap232 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut233 happy_x_3 of { (HappyWrap233 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 (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 happyOut232 happy_x_1 of { (HappyWrap232 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut251 happy_x_3 of { (HappyWrap251 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 (happyIn232 r)) - -happyReduce_595 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_595 = happyMonadReduce 1# 216# happyReduction_595 -happyReduction_595 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut233 happy_x_1 of { (HappyWrap233 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 (happyIn232 r)) - -happyReduce_596 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_596 = happyMonadReduce 1# 216# happyReduction_596 -happyReduction_596 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut251 happy_x_1 of { (HappyWrap251 happy_var_1) -> - ( runPV happy_var_1 >>= \ happy_var_1 -> - return $ sL1A happy_var_1 [happy_var_1])}) - ) (\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 2# 217# happyReduction_597 -happyReduction_597 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut206 happy_x_2 of { (HappyWrap206 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 (happyIn233 r)) - -happyReduce_598 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_598 = happyMonadReduce 4# 217# happyReduction_598 -happyReduction_598 (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 happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut206 happy_x_4 of { (HappyWrap206 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 (happyIn233 r)) - -happyReduce_599 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_599 = happyMonadReduce 4# 217# 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 happyOutTok happy_x_2 of { happy_var_2 -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut206 happy_x_4 of { (HappyWrap206 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 (happyIn233 r)) - -happyReduce_600 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_600 = happyMonadReduce 6# 217# happyReduction_600 -happyReduction_600 (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 happyOut206 happy_x_4 of { (HappyWrap206 happy_var_4) -> - case happyOutTok happy_x_5 of { happy_var_5 -> - case happyOut206 happy_x_6 of { (HappyWrap206 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 (happyIn233 r)) - -happyReduce_601 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_601 = happySpecReduce_1 218# happyReduction_601 -happyReduction_601 happy_x_1 - = case happyOut235 happy_x_1 of { (HappyWrap235 happy_var_1) -> - happyIn234 - (L (getLoc happy_var_1) (reverse (unLoc happy_var_1)) - )} - -happyReduce_602 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_602 = happyMonadReduce 3# 219# happyReduction_602 -happyReduction_602 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut235 happy_x_1 of { (HappyWrap235 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut251 happy_x_3 of { (HappyWrap251 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 (happyIn235 r)) - -happyReduce_603 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_603 = happyMonadReduce 1# 219# happyReduction_603 -happyReduction_603 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut251 happy_x_1 of { (HappyWrap251 happy_var_1) -> - ( runPV happy_var_1 >>= \ happy_var_1 -> - return $ sL1A happy_var_1 [happy_var_1])}) - ) (\r -> happyReturn (happyIn235 r)) - -happyReduce_604 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_604 = happySpecReduce_2 220# happyReduction_604 -happyReduction_604 happy_x_2 - happy_x_1 - = case happyOut237 happy_x_1 of { (HappyWrap237 happy_var_1) -> - case happyOut130 happy_x_2 of { (HappyWrap130 happy_var_2) -> - happyIn236 - (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_605 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_605 = happySpecReduce_2 221# happyReduction_605 -happyReduction_605 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut206 happy_x_2 of { (HappyWrap206 happy_var_2) -> - happyIn237 - (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_606 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_606 = happySpecReduce_1 221# happyReduction_606 -happyReduction_606 happy_x_1 - = case happyOut238 happy_x_1 of { (HappyWrap238 happy_var_1) -> - happyIn237 - (happy_var_1 >>= \gdpats -> - return $ sL1 gdpats (reverse (unLoc gdpats)) - )} - -happyReduce_607 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_607 = happySpecReduce_2 222# happyReduction_607 -happyReduction_607 happy_x_2 - happy_x_1 - = case happyOut238 happy_x_1 of { (HappyWrap238 happy_var_1) -> - case happyOut240 happy_x_2 of { (HappyWrap240 happy_var_2) -> - happyIn238 - (happy_var_1 >>= \gdpats -> - happy_var_2 >>= \gdpat -> - return $ sLL gdpats (reLoc gdpat) (gdpat : unLoc gdpats) - )}} - -happyReduce_608 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_608 = happySpecReduce_1 222# happyReduction_608 -happyReduction_608 happy_x_1 - = case happyOut240 happy_x_1 of { (HappyWrap240 happy_var_1) -> - happyIn238 - (happy_var_1 >>= \gdpat -> return $ sL1A gdpat [gdpat] - )} - -happyReduce_609 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_609 = happyMonadReduce 3# 223# happyReduction_609 -happyReduction_609 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut238 happy_x_2 of { (HappyWrap238 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 (happyIn239 r)) - -happyReduce_610 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_610 = happyMonadReduce 2# 223# happyReduction_610 -happyReduction_610 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut238 happy_x_1 of { (HappyWrap238 happy_var_1) -> - ( runPV happy_var_1 >>= \ happy_var_1 -> - return $ sL1 happy_var_1 ([],unLoc happy_var_1))}) - ) (\r -> happyReturn (happyIn239 r)) - -happyReduce_611 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_611 = happyReduce 4# 224# happyReduction_611 -happyReduction_611 (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 happyOut234 happy_x_2 of { (HappyWrap234 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - case happyOut206 happy_x_4 of { (HappyWrap206 happy_var_4) -> - happyIn240 - (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_612 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_612 = happyMonadReduce 1# 225# happyReduction_612 -happyReduction_612 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> - ( (checkPattern <=< runPV) (unECP happy_var_1))}) - ) (\r -> happyReturn (happyIn241 r)) - -happyReduce_613 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_613 = happySpecReduce_1 226# happyReduction_613 -happyReduction_613 happy_x_1 - = case happyOut241 happy_x_1 of { (HappyWrap241 happy_var_1) -> - happyIn242 - ([ happy_var_1 ] - )} - -happyReduce_614 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_614 = happyMonadReduce 1# 227# happyReduction_614 -happyReduction_614 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> - ( -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess - checkPattern_details incompleteDoBlock - (unECP happy_var_1))}) - ) (\r -> happyReturn (happyIn243 r)) - -happyReduce_615 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_615 = happyMonadReduce 1# 228# happyReduction_615 -happyReduction_615 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut213 happy_x_1 of { (HappyWrap213 happy_var_1) -> - ( (checkPattern <=< runPV) (unECP happy_var_1))}) - ) (\r -> happyReturn (happyIn244 r)) - -happyReduce_616 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_616 = happySpecReduce_2 229# happyReduction_616 -happyReduction_616 happy_x_2 - happy_x_1 - = case happyOut244 happy_x_1 of { (HappyWrap244 happy_var_1) -> - case happyOut245 happy_x_2 of { (HappyWrap245 happy_var_2) -> - happyIn245 - (happy_var_1 : happy_var_2 - )}} - -happyReduce_617 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_617 = happySpecReduce_0 229# happyReduction_617 -happyReduction_617 = happyIn245 - ([] - ) - -happyReduce_618 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_618 = happySpecReduce_3 230# happyReduction_618 -happyReduction_618 happy_x_3 - 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) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn246 - (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) (fromOL $ fst $ unLoc 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 230# happyReduction_619 -happyReduction_619 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut247 happy_x_2 of { (HappyWrap247 happy_var_2) -> - happyIn246 - (happy_var_2 >>= \ happy_var_2 -> amsrl - (L (gl happy_var_2) (reverse $ snd $ unLoc happy_var_2)) (AnnList (Just $ glR happy_var_2) Nothing Nothing (fromOL $ fst $ unLoc happy_var_2) []) - )} - -happyReduce_620 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_620 = happySpecReduce_3 231# happyReduction_620 -happyReduction_620 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut247 happy_x_1 of { (HappyWrap247 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut250 happy_x_3 of { (HappyWrap250 happy_var_3) -> - happyIn247 - (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_621 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_621 = happySpecReduce_2 231# happyReduction_621 -happyReduction_621 happy_x_2 - happy_x_1 - = case happyOut247 happy_x_1 of { (HappyWrap247 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn247 - (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_622 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_622 = happySpecReduce_1 231# happyReduction_622 -happyReduction_622 happy_x_1 - = case happyOut250 happy_x_1 of { (HappyWrap250 happy_var_1) -> - happyIn247 - (happy_var_1 >>= \ happy_var_1 -> - return $ sL1A happy_var_1 (nilOL,[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 231# happyReduction_623 -happyReduction_623 = happyIn247 - (return $ noLoc (nilOL,[]) - ) - -happyReduce_624 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_624 = happyMonadReduce 1# 232# happyReduction_624 -happyReduction_624 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut250 happy_x_1 of { (HappyWrap250 happy_var_1) -> - ( fmap Just (runPV happy_var_1))}) - ) (\r -> happyReturn (happyIn248 r)) - -happyReduce_625 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_625 = happySpecReduce_0 232# happyReduction_625 -happyReduction_625 = happyIn248 - (Nothing - ) - -happyReduce_626 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_626 = happyMonadReduce 1# 233# happyReduction_626 -happyReduction_626 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut250 happy_x_1 of { (HappyWrap250 happy_var_1) -> - ( runPV happy_var_1)}) - ) (\r -> happyReturn (happyIn249 r)) - -happyReduce_627 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_627 = happySpecReduce_1 234# happyReduction_627 -happyReduction_627 happy_x_1 - = case happyOut251 happy_x_1 of { (HappyWrap251 happy_var_1) -> - happyIn250 - (happy_var_1 - )} - -happyReduce_628 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_628 = happySpecReduce_2 234# happyReduction_628 -happyReduction_628 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut246 happy_x_2 of { (HappyWrap246 happy_var_2) -> - happyIn250 - (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_629 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_629 = happySpecReduce_3 235# happyReduction_629 -happyReduction_629 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut243 happy_x_1 of { (HappyWrap243 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut206 happy_x_3 of { (HappyWrap206 happy_var_3) -> - happyIn251 - (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_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 happyOut206 happy_x_1 of { (HappyWrap206 happy_var_1) -> - happyIn251 - (unECP happy_var_1 >>= \ happy_var_1 -> - return $ sL1 happy_var_1 $ mkBodyStmt 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 happyOut129 happy_x_2 of { (HappyWrap129 happy_var_2) -> - happyIn251 - (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_632 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_632 = happySpecReduce_1 236# happyReduction_632 -happyReduction_632 happy_x_1 - = case happyOut253 happy_x_1 of { (HappyWrap253 happy_var_1) -> - happyIn252 - (happy_var_1 - )} - -happyReduce_633 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_633 = happySpecReduce_0 236# happyReduction_633 -happyReduction_633 = happyIn252 - (return ([], Nothing) - ) - -happyReduce_634 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_634 = happySpecReduce_3 237# happyReduction_634 -happyReduction_634 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut254 happy_x_1 of { (HappyWrap254 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut253 happy_x_3 of { (HappyWrap253 happy_var_3) -> - happyIn253 - (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_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 >>= \ happy_var_1 -> - return ([happy_var_1], Nothing) - )} - -happyReduce_636 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_636 = happySpecReduce_1 237# happyReduction_636 -happyReduction_636 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn253 - (return ([], Just (getLoc happy_var_1)) - )} - -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 happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut224 happy_x_3 of { (HappyWrap224 happy_var_3) -> - happyIn254 - (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_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 happyOut298 happy_x_1 of { (HappyWrap298 happy_var_1) -> - happyIn254 - (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_639 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_639 = happyReduce 5# 238# happyReduction_639 -happyReduction_639 (happy_x_5 `HappyStk` - happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) - = case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut255 happy_x_3 of { (HappyWrap255 happy_var_3) -> - case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut224 happy_x_5 of { (HappyWrap224 happy_var_5) -> - happyIn254 - (do - let top = sL1a happy_var_1 $ DotFieldOcc noAnn (reLocA 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 happy_var_1 happy_var_3 - isPun = False - happy_var_5 <- unECP happy_var_5 - fmap Right $ mkHsProjUpdatePV (comb2 happy_var_1 (reLoc happy_var_5)) (L l fields) happy_var_5 isPun - [mj AnnEqual happy_var_4] - ) `HappyStk` happyRest}}}}} - -happyReduce_640 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_640 = happySpecReduce_3 238# 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 happyOut255 happy_x_3 of { (HappyWrap255 happy_var_3) -> - happyIn254 - (do - let top = sL1a happy_var_1 $ DotFieldOcc noAnn (reLocA 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 happy_var_1 happy_var_3 - isPun = True - var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . dfoLabel . unLoc $ final)) - fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun [] - )}}} - -happyReduce_641 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_641 = happyMonadReduce 3# 239# happyReduction_641 -happyReduction_641 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut255 happy_x_1 of { (HappyWrap255 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut299 happy_x_3 of { (HappyWrap299 happy_var_3) -> - ( getCommentsFor (getLoc happy_var_3) >>= \cs -> - return (sLL happy_var_1 happy_var_3 ((sLLa happy_var_2 happy_var_3 (DotFieldOcc (EpAnn (glR happy_var_2) (AnnFieldLabel $ Just $ glAA happy_var_2) cs) (reLocA happy_var_3))) : unLoc happy_var_1)))}}}) - ) (\r -> happyReturn (happyIn255 r)) - -happyReduce_642 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_642 = happyMonadReduce 1# 239# happyReduction_642 -happyReduction_642 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut299 happy_x_1 of { (HappyWrap299 happy_var_1) -> - ( getCommentsFor (getLoc happy_var_1) >>= \cs -> - return (sL1 happy_var_1 [sL1a happy_var_1 (DotFieldOcc (EpAnn (glR happy_var_1) (AnnFieldLabel Nothing) cs) (reLocA happy_var_1))]))}) - ) (\r -> happyReturn (happyIn255 r)) - -happyReduce_643 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_643 = happyMonadReduce 3# 240# happyReduction_643 -happyReduction_643 (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 happyOut257 happy_x_3 of { (HappyWrap257 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 (happyIn256 r)) - -happyReduce_644 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_644 = happyMonadReduce 2# 240# happyReduction_644 -happyReduction_644 (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 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 (happyIn256 r)) - -happyReduce_645 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_645 = happySpecReduce_1 240# happyReduction_645 -happyReduction_645 happy_x_1 - = case happyOut257 happy_x_1 of { (HappyWrap257 happy_var_1) -> - happyIn256 - (let this = happy_var_1 in this `seq` (sL1 (reLoc happy_var_1) [this]) - )} - -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 happyOut258 happy_x_1 of { (HappyWrap258 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut206 happy_x_3 of { (HappyWrap206 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 (happyIn257 r)) - -happyReduce_647 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_647 = happySpecReduce_1 242# happyReduction_647 -happyReduction_647 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn258 - (sL1 happy_var_1 (HsIPName (getIPDUPVARID happy_var_1)) - )} - -happyReduce_648 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_648 = happySpecReduce_1 243# happyReduction_648 -happyReduction_648 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn259 - (sL1 happy_var_1 (getLABELVARID happy_var_1) - )} - -happyReduce_649 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_649 = happySpecReduce_1 244# happyReduction_649 -happyReduction_649 happy_x_1 - = case happyOut261 happy_x_1 of { (HappyWrap261 happy_var_1) -> - happyIn260 - (happy_var_1 - )} - -happyReduce_650 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_650 = happySpecReduce_0 244# happyReduction_650 -happyReduction_650 = happyIn260 - (noLocA mkTrue - ) - -happyReduce_651 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_651 = happySpecReduce_1 245# happyReduction_651 -happyReduction_651 happy_x_1 - = case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> - happyIn261 - (happy_var_1 - )} - -happyReduce_652 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_652 = happyMonadReduce 3# 245# happyReduction_652 -happyReduction_652 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut262 happy_x_1 of { (HappyWrap262 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut261 happy_x_3 of { (HappyWrap261 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 (happyIn261 r)) - -happyReduce_653 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_653 = happySpecReduce_1 246# happyReduction_653 -happyReduction_653 happy_x_1 - = case happyOut263 happy_x_1 of { (HappyWrap263 happy_var_1) -> - happyIn262 - (reLocA $ sLLAA (head happy_var_1) (last happy_var_1) (And (happy_var_1)) - )} - -happyReduce_654 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_654 = happySpecReduce_1 247# happyReduction_654 -happyReduction_654 happy_x_1 - = case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> - happyIn263 - ([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# 247# happyReduction_655 -happyReduction_655 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut264 happy_x_1 of { (HappyWrap264 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut263 happy_x_3 of { (HappyWrap263 happy_var_3) -> - ( do { h <- addTrailingCommaL happy_var_1 (gl happy_var_2) - ; return (h : happy_var_3) })}}}) - ) (\r -> happyReturn (happyIn263 r)) - -happyReduce_656 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_656 = happyMonadReduce 3# 248# happyReduction_656 -happyReduction_656 (happy_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 -> - ( 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 (happyIn264 r)) - -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 happyOut266 happy_x_1 of { (HappyWrap266 happy_var_1) -> - happyIn264 - (reLocA $ sL1N happy_var_1 (Var happy_var_1) - )} - -happyReduce_658 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_658 = happySpecReduce_1 249# happyReduction_658 -happyReduction_658 happy_x_1 - = case happyOut266 happy_x_1 of { (HappyWrap266 happy_var_1) -> - happyIn265 - (sL1N happy_var_1 [happy_var_1] - )} - -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 happyOut266 happy_x_1 of { (HappyWrap266 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut265 happy_x_3 of { (HappyWrap265 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 (happyIn265 r)) - -happyReduce_660 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_660 = happySpecReduce_1 250# happyReduction_660 -happyReduction_660 happy_x_1 - = case happyOut297 happy_x_1 of { (HappyWrap297 happy_var_1) -> - happyIn266 - (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 happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> - happyIn266 - (happy_var_1 - )} - -happyReduce_662 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_662 = happySpecReduce_1 251# happyReduction_662 -happyReduction_662 happy_x_1 - = case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> - happyIn267 - (happy_var_1 - )} - -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 happyOut273 happy_x_1 of { (HappyWrap273 happy_var_1) -> - happyIn267 - (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc 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 252# happyReduction_664 -happyReduction_664 happy_x_1 - = case happyOut269 happy_x_1 of { (HappyWrap269 happy_var_1) -> - happyIn268 - (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 happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> - happyIn268 - (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc 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 253# happyReduction_666 -happyReduction_666 happy_x_1 - = case happyOut309 happy_x_1 of { (HappyWrap309 happy_var_1) -> - happyIn269 - (happy_var_1 - )} - -happyReduce_667 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_667 = happyMonadReduce 3# 253# happyReduction_667 -happyReduction_667 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut311 happy_x_2 of { (HappyWrap311 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameParens (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn269 r)) - -happyReduce_668 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_668 = happySpecReduce_1 254# happyReduction_668 -happyReduction_668 happy_x_1 - = case happyOut310 happy_x_1 of { (HappyWrap310 happy_var_1) -> - happyIn270 - (happy_var_1 - )} - -happyReduce_669 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_669 = happyMonadReduce 3# 254# happyReduction_669 -happyReduction_669 (happy_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_670 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_670 = happySpecReduce_1 254# happyReduction_670 -happyReduction_670 happy_x_1 - = case happyOut274 happy_x_1 of { (HappyWrap274 happy_var_1) -> - happyIn270 - (L (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc happy_var_1)) - )} - -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 happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> - happyIn271 - (sL1N happy_var_1 [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 happyOut270 happy_x_1 of { (HappyWrap270 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut271 happy_x_3 of { (HappyWrap271 happy_var_3) -> - ( do { h <- addTrailingCommaN happy_var_1 (gl happy_var_2) - ; return (sLL (reLocN happy_var_1) happy_var_3 (h : unLoc happy_var_3)) })}}}) - ) (\r -> happyReturn (happyIn271 r)) - -happyReduce_673 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_673 = happySpecReduce_1 256# happyReduction_673 -happyReduction_673 happy_x_1 - = case happyOut268 happy_x_1 of { (HappyWrap268 happy_var_1) -> - happyIn272 - (sL1N happy_var_1 [happy_var_1] - )} - -happyReduce_674 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_674 = happyMonadReduce 3# 256# happyReduction_674 -happyReduction_674 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut268 happy_x_1 of { (HappyWrap268 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut272 happy_x_3 of { (HappyWrap272 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 (happyIn272 r)) - -happyReduce_675 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_675 = happyMonadReduce 2# 257# happyReduction_675 -happyReduction_675 (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 (happyIn273 r)) - -happyReduce_676 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_676 = happyMonadReduce 3# 257# happyReduction_676 -happyReduction_676 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 $ tupleDataCon Boxed (snd happy_var_2 + 1)) - (NameAnnCommas NameParens (glAA happy_var_1) (map (EpaSpan . realSrcSpan) (fst happy_var_2)) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn273 r)) - -happyReduce_677 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_677 = happyMonadReduce 2# 257# happyReduction_677 -happyReduction_677 (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 (happyIn273 r)) - -happyReduce_678 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_678 = happyMonadReduce 3# 257# happyReduction_678 -happyReduction_678 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 $ tupleDataCon Unboxed (snd happy_var_2 + 1)) - (NameAnnCommas NameParensHash (glAA happy_var_1) (map (EpaSpan . realSrcSpan) (fst happy_var_2)) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn273 r)) - -happyReduce_679 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_679 = happySpecReduce_1 258# happyReduction_679 -happyReduction_679 happy_x_1 - = case happyOut273 happy_x_1 of { (HappyWrap273 happy_var_1) -> - happyIn274 - (happy_var_1 - )} - -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 nilDataCon) (NameAnnOnly NameSquare (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 = happySpecReduce_1 259# happyReduction_681 -happyReduction_681 happy_x_1 - = case happyOut312 happy_x_1 of { (HappyWrap312 happy_var_1) -> - happyIn275 - (happy_var_1 - )} - -happyReduce_682 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_682 = happyMonadReduce 3# 259# happyReduction_682 -happyReduction_682 (happy_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 (happyIn275 r)) - -happyReduce_683 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_683 = happySpecReduce_1 260# happyReduction_683 -happyReduction_683 happy_x_1 - = case happyOut311 happy_x_1 of { (HappyWrap311 happy_var_1) -> - happyIn276 - (happy_var_1 - )} - -happyReduce_684 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_684 = happyMonadReduce 3# 260# happyReduction_684 -happyReduction_684 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut309 happy_x_2 of { (HappyWrap309 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_685 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_685 = happySpecReduce_1 261# happyReduction_685 -happyReduction_685 happy_x_1 - = case happyOut278 happy_x_1 of { (HappyWrap278 happy_var_1) -> - happyIn277 - (happy_var_1 - )} - -happyReduce_686 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_686 = happyMonadReduce 2# 261# happyReduction_686 -happyReduction_686 (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 (happyIn277 r)) - -happyReduce_687 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_687 = happyMonadReduce 2# 261# happyReduction_687 -happyReduction_687 (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 (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 3# 262# happyReduction_689 -happyReduction_689 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon Boxed - (snd happy_var_2 + 1))) - (NameAnnCommas NameParens (glAA happy_var_1) (map (EpaSpan . realSrcSpan) (fst happy_var_2)) (glAA happy_var_3) []))}}}) - ) (\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 3# 262# happyReduction_690 -happyReduction_690 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut316 happy_x_2 of { (HappyWrap316 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon Unboxed - (snd happy_var_2 + 1))) - (NameAnnCommas NameParensHash (glAA happy_var_1) (map (EpaSpan . realSrcSpan) (fst happy_var_2)) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn278 r)) - -happyReduce_691 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_691 = happyMonadReduce 3# 262# happyReduction_691 -happyReduction_691 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut318 happy_x_2 of { (HappyWrap318 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 $ getRdrName (sumTyCon (snd happy_var_2 + 1))) - (NameAnnBars NameParensHash (glAA happy_var_1) (map (EpaSpan . realSrcSpan) (fst happy_var_2)) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn278 r)) - -happyReduce_692 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_692 = happyMonadReduce 3# 262# happyReduction_692 -happyReduction_692 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case 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 (happyIn278 r)) - -happyReduce_693 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_693 = happyMonadReduce 2# 262# happyReduction_693 -happyReduction_693 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - ( amsrn (sLL happy_var_1 happy_var_2 $ listTyCon_RDR) - (NameAnnOnly NameSquare (glAA happy_var_1) (glAA happy_var_2) []))}}) - ) (\r -> happyReturn (happyIn278 r)) - -happyReduce_694 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_694 = happySpecReduce_1 263# happyReduction_694 -happyReduction_694 happy_x_1 - = case happyOut282 happy_x_1 of { (HappyWrap282 happy_var_1) -> - happyIn279 - (happy_var_1 - )} - -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 happyOut284 happy_x_2 of { (HappyWrap284 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 (happyIn279 r)) - -happyReduce_696 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_696 = happySpecReduce_1 264# happyReduction_696 -happyReduction_696 happy_x_1 - = case happyOut282 happy_x_1 of { (HappyWrap282 happy_var_1) -> - happyIn280 - (happy_var_1 - )} - -happyReduce_697 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_697 = happyMonadReduce 3# 264# happyReduction_697 -happyReduction_697 (happy_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 (happyIn280 r)) - -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 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 (happyIn280 r)) - -happyReduce_699 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_699 = happyMonadReduce 3# 264# happyReduction_699 -happyReduction_699 (happy_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 (happyIn280 r)) - -happyReduce_700 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_700 = happySpecReduce_1 265# happyReduction_700 -happyReduction_700 happy_x_1 - = case happyOut284 happy_x_1 of { (HappyWrap284 happy_var_1) -> - happyIn281 - (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# 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 happyOut282 happy_x_2 of { (HappyWrap282 happy_var_2) -> - case happyOutTok happy_x_3 of { happy_var_3 -> - ( amsrn (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) - (NameAnn NameBackquotes (glAA happy_var_1) (glNRR happy_var_2) (glAA happy_var_3) []))}}}) - ) (\r -> happyReturn (happyIn281 r)) - -happyReduce_702 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_702 = happySpecReduce_1 266# happyReduction_702 -happyReduction_702 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn282 - (sL1n happy_var_1 $! mkQual tcClsName (getQCONID happy_var_1) - )} - -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 happyOut283 happy_x_1 of { (HappyWrap283 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 = happySpecReduce_1 267# happyReduction_704 -happyReduction_704 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn283 - (sL1n happy_var_1 $! mkUnqual tcClsName (getCONID happy_var_1) - )} - -happyReduce_705 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_705 = happySpecReduce_1 268# happyReduction_705 -happyReduction_705 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn284 - (sL1n happy_var_1 $! mkQual tcClsName (getQCONSYM 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 268# happyReduction_706 -happyReduction_706 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn284 - (sL1n happy_var_1 $! mkQual tcClsName (getQVARSYM 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 happyOut285 happy_x_1 of { (HappyWrap285 happy_var_1) -> - happyIn284 - (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 $! mkUnqual tcClsName (getCONSYM 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 $! mkUnqual tcClsName (getVARSYM 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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn285 - (sL1n happy_var_1 $! consDataCon_RDR - )} - -happyReduce_711 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_711 = happySpecReduce_1 269# happyReduction_711 -happyReduction_711 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn285 - (sL1n happy_var_1 $! mkUnqual tcClsName (fsLit "-") - )} - -happyReduce_712 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_712 = happySpecReduce_1 269# happyReduction_712 -happyReduction_712 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn285 - (sL1n happy_var_1 $! mkUnqual tcClsName (fsLit ".") - )} - -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 happyOut283 happy_x_1 of { (HappyWrap283 happy_var_1) -> - happyIn286 - (happy_var_1 - )} - -happyReduce_714 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_714 = happyMonadReduce 3# 270# happyReduction_714 -happyReduction_714 (happy_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 (happyIn286 r)) - -happyReduce_715 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_715 = happySpecReduce_1 271# happyReduction_715 -happyReduction_715 happy_x_1 - = case happyOut288 happy_x_1 of { (HappyWrap288 happy_var_1) -> - happyIn287 - (happy_var_1 - )} - -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 happyOut275 happy_x_1 of { (HappyWrap275 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 = happySpecReduce_1 271# happyReduction_717 -happyReduction_717 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn287 - (sL1n happy_var_1 $ getRdrName unrestrictedFunTyCon - )} - -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 happyOut305 happy_x_1 of { (HappyWrap305 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 = happyMonadReduce 3# 272# 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 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 (happyIn288 r)) - -happyReduce_720 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_720 = happySpecReduce_1 273# happyReduction_720 -happyReduction_720 happy_x_1 - = case happyOut292 happy_x_1 of { (HappyWrap292 happy_var_1) -> - happyIn289 - (mkHsVarOpPV happy_var_1 - )} - -happyReduce_721 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_721 = happySpecReduce_1 273# happyReduction_721 -happyReduction_721 happy_x_1 - = case happyOut276 happy_x_1 of { (HappyWrap276 happy_var_1) -> - happyIn289 - (mkHsConOpPV happy_var_1 - )} - -happyReduce_722 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_722 = happySpecReduce_1 273# happyReduction_722 -happyReduction_722 happy_x_1 - = case happyOut291 happy_x_1 of { (HappyWrap291 happy_var_1) -> - happyIn289 - (pvN happy_var_1 - )} - -happyReduce_723 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_723 = happySpecReduce_1 274# happyReduction_723 -happyReduction_723 happy_x_1 - = case 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 happyOut276 happy_x_1 of { (HappyWrap276 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 happyOut291 happy_x_1 of { (HappyWrap291 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_3 275# happyReduction_726 -happyReduction_726 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 -> - happyIn291 - (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_727 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_727 = happySpecReduce_1 276# happyReduction_727 -happyReduction_727 happy_x_1 - = case happyOut302 happy_x_1 of { (HappyWrap302 happy_var_1) -> - happyIn292 - (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# 276# 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 happyOut300 happy_x_2 of { (HappyWrap300 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 (happyIn292 r)) - -happyReduce_729 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_729 = happySpecReduce_1 277# happyReduction_729 -happyReduction_729 happy_x_1 - = case happyOut303 happy_x_1 of { (HappyWrap303 happy_var_1) -> - happyIn293 - (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# 277# 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 happyOut300 happy_x_2 of { (HappyWrap300 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_731 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_731 = happySpecReduce_1 278# happyReduction_731 -happyReduction_731 happy_x_1 - = case happyOut296 happy_x_1 of { (HappyWrap296 happy_var_1) -> - happyIn294 - (happy_var_1 - )} - -happyReduce_732 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_732 = happyMonadReduce 3# 279# happyReduction_732 -happyReduction_732 (happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut296 happy_x_2 of { (HappyWrap296 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 (happyIn295 r)) - -happyReduce_733 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_733 = happySpecReduce_1 280# happyReduction_733 -happyReduction_733 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn296 - (sL1n happy_var_1 $! mkUnqual tvName (getVARID happy_var_1) - )} - -happyReduce_734 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_734 = happySpecReduce_1 280# happyReduction_734 -happyReduction_734 happy_x_1 - = case happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> - happyIn296 - (sL1n happy_var_1 $! mkUnqual tvName (unLoc happy_var_1) - )} - -happyReduce_735 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_735 = happySpecReduce_1 280# happyReduction_735 -happyReduction_735 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn296 - (sL1n happy_var_1 $! mkUnqual tvName (fsLit "unsafe") - )} - -happyReduce_736 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_736 = happySpecReduce_1 280# happyReduction_736 -happyReduction_736 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn296 - (sL1n happy_var_1 $! mkUnqual tvName (fsLit "safe") - )} - -happyReduce_737 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_737 = happySpecReduce_1 280# happyReduction_737 -happyReduction_737 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn296 - (sL1n happy_var_1 $! mkUnqual tvName (fsLit "interruptible") - )} - -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 happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> - happyIn297 - (happy_var_1 - )} - -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 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 (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 happyOut300 happy_x_1 of { (HappyWrap300 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 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 (happyIn298 r)) - -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 happyOut304 happy_x_2 of { (HappyWrap304 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 - (reLocN $ fmap (occNameFS . rdrNameOcc) happy_var_1 - )} - -happyReduce_744 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_744 = happySpecReduce_1 284# happyReduction_744 -happyReduction_744 happy_x_1 - = case happyOut301 happy_x_1 of { (HappyWrap301 happy_var_1) -> - happyIn300 - (happy_var_1 - )} - -happyReduce_745 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_745 = happySpecReduce_1 284# happyReduction_745 -happyReduction_745 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn300 - (sL1n happy_var_1 $! mkQual varName (getQVARID happy_var_1) - )} - -happyReduce_746 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_746 = happySpecReduce_1 285# happyReduction_746 -happyReduction_746 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn301 - (sL1n happy_var_1 $! mkUnqual varName (getVARID 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 happyOut307 happy_x_1 of { (HappyWrap307 happy_var_1) -> - happyIn301 - (sL1n happy_var_1 $! mkUnqual varName (unLoc 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 $! mkUnqual varName (fsLit "unsafe") - )} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn301 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "safe") - )} - -happyReduce_750 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_750 = happySpecReduce_1 285# happyReduction_750 -happyReduction_750 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn301 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "interruptible") - )} - -happyReduce_751 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_751 = happySpecReduce_1 285# happyReduction_751 -happyReduction_751 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn301 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "forall") - )} - -happyReduce_752 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_752 = happySpecReduce_1 285# happyReduction_752 -happyReduction_752 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn301 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "family") - )} - -happyReduce_753 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_753 = happySpecReduce_1 285# happyReduction_753 -happyReduction_753 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn301 - (sL1n happy_var_1 $! mkUnqual varName (fsLit "role") - )} - -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 happyOut305 happy_x_1 of { (HappyWrap305 happy_var_1) -> - happyIn302 - (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 286# happyReduction_755 -happyReduction_755 happy_x_1 - = case happyOut304 happy_x_1 of { (HappyWrap304 happy_var_1) -> - happyIn302 - (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 287# happyReduction_756 -happyReduction_756 happy_x_1 - = case happyOut306 happy_x_1 of { (HappyWrap306 happy_var_1) -> - happyIn303 - (happy_var_1 - )} - -happyReduce_757 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_757 = happySpecReduce_1 287# happyReduction_757 -happyReduction_757 happy_x_1 - = case happyOut304 happy_x_1 of { (HappyWrap304 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 288# happyReduction_758 -happyReduction_758 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn304 - (sL1n happy_var_1 $ mkQual varName (getQVARSYM 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 289# happyReduction_759 -happyReduction_759 happy_x_1 - = case happyOut306 happy_x_1 of { (HappyWrap306 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 = happySpecReduce_1 289# happyReduction_760 -happyReduction_760 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn305 - (sL1n happy_var_1 $ mkUnqual varName (fsLit "-") - )} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn306 - (sL1n happy_var_1 $ mkUnqual varName (getVARSYM 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 happyOut308 happy_x_1 of { (HappyWrap308 happy_var_1) -> - happyIn306 - (sL1n happy_var_1 $ mkUnqual varName (unLoc 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 291# happyReduction_763 -happyReduction_763 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "as") - )} - -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 - (sL1 happy_var_1 (fsLit "qualified") - )} - -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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "hiding") - )} - -happyReduce_766 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_766 = happySpecReduce_1 291# happyReduction_766 -happyReduction_766 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "export") - )} - -happyReduce_767 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_767 = happySpecReduce_1 291# happyReduction_767 -happyReduction_767 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "label") - )} - -happyReduce_768 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_768 = happySpecReduce_1 291# happyReduction_768 -happyReduction_768 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "dynamic") - )} - -happyReduce_769 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_769 = happySpecReduce_1 291# happyReduction_769 -happyReduction_769 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "stdcall") - )} - -happyReduce_770 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_770 = happySpecReduce_1 291# happyReduction_770 -happyReduction_770 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "ccall") - )} - -happyReduce_771 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_771 = happySpecReduce_1 291# happyReduction_771 -happyReduction_771 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "capi") - )} - -happyReduce_772 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_772 = happySpecReduce_1 291# happyReduction_772 -happyReduction_772 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "prim") - )} - -happyReduce_773 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_773 = happySpecReduce_1 291# happyReduction_773 -happyReduction_773 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "javascript") - )} - -happyReduce_774 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_774 = happySpecReduce_1 291# happyReduction_774 -happyReduction_774 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "group") - )} - -happyReduce_775 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_775 = happySpecReduce_1 291# happyReduction_775 -happyReduction_775 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "stock") - )} - -happyReduce_776 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_776 = happySpecReduce_1 291# happyReduction_776 -happyReduction_776 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "anyclass") - )} - -happyReduce_777 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_777 = happySpecReduce_1 291# happyReduction_777 -happyReduction_777 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "via") - )} - -happyReduce_778 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_778 = happySpecReduce_1 291# happyReduction_778 -happyReduction_778 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "unit") - )} - -happyReduce_779 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_779 = happySpecReduce_1 291# happyReduction_779 -happyReduction_779 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "dependency") - )} - -happyReduce_780 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_780 = happySpecReduce_1 291# happyReduction_780 -happyReduction_780 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn307 - (sL1 happy_var_1 (fsLit "signature") - )} - -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 ".") - )} - -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 (starSym (isUnicode happy_var_1))) - )} - -happyReduce_783 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_783 = happySpecReduce_1 293# happyReduction_783 -happyReduction_783 happy_x_1 - = case happyOut310 happy_x_1 of { (HappyWrap310 happy_var_1) -> - happyIn309 - (happy_var_1 - )} - -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 - (sL1n happy_var_1 $! mkQual dataName (getQCONID happy_var_1) - )} - -happyReduce_785 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_785 = happySpecReduce_1 294# happyReduction_785 -happyReduction_785 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn310 - (sL1n happy_var_1 $ mkUnqual dataName (getCONID 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 295# happyReduction_786 -happyReduction_786 happy_x_1 - = case happyOut312 happy_x_1 of { (HappyWrap312 happy_var_1) -> - happyIn311 - (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 295# happyReduction_787 -happyReduction_787 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn311 - (sL1n happy_var_1 $ mkQual dataName (getQCONSYM 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 296# happyReduction_788 -happyReduction_788 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn312 - (sL1n happy_var_1 $ mkUnqual dataName (getCONSYM 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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn312 - (sL1n happy_var_1 $ consDataCon_RDR - )} - -happyReduce_790 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_790 = happySpecReduce_1 297# happyReduction_790 -happyReduction_790 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 $ HsChar (getCHARs happy_var_1) $ getCHAR 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 - (sL1 happy_var_1 $ HsString (getSTRINGs happy_var_1) - $ getSTRING 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 - (sL1 happy_var_1 $ HsIntPrim (getPRIMINTEGERs happy_var_1) - $ getPRIMINTEGER 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 297# happyReduction_793 -happyReduction_793 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 $ HsWordPrim (getPRIMWORDs happy_var_1) - $ getPRIMWORD 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 297# happyReduction_794 -happyReduction_794 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 $ HsCharPrim (getPRIMCHARs happy_var_1) - $ getPRIMCHAR 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 297# happyReduction_795 -happyReduction_795 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 $ HsStringPrim (getPRIMSTRINGs happy_var_1) - $ getPRIMSTRING 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 297# happyReduction_796 -happyReduction_796 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 $ HsFloatPrim noExtField $ getPRIMFLOAT 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 297# happyReduction_797 -happyReduction_797 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn313 - (sL1 happy_var_1 $ HsDoublePrim noExtField $ getPRIMDOUBLE 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 - = happyIn314 - (() - ) - -happyReduce_799 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_799 = happyMonadReduce 1# 298# happyReduction_799 -happyReduction_799 (happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((( popContext)) - ) (\r -> happyReturn (happyIn314 r)) - -happyReduce_800 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_800 = happySpecReduce_1 299# happyReduction_800 -happyReduction_800 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn315 - (sL1a happy_var_1 $ mkModuleNameFS (getCONID happy_var_1) - )} - -happyReduce_801 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_801 = happySpecReduce_1 299# happyReduction_801 -happyReduction_801 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn315 - (sL1a happy_var_1 $ let (mod,c) = getQCONID happy_var_1 in - mkModuleNameFS - (mkFastString - (unpackFS mod ++ '.':unpackFS c)) - )} - -happyReduce_802 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_802 = happySpecReduce_2 300# happyReduction_802 -happyReduction_802 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 -> - happyIn316 - (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 1) - )}} - -happyReduce_803 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_803 = happySpecReduce_1 300# happyReduction_803 -happyReduction_803 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn316 - (([gl happy_var_1],1) - )} - -happyReduce_804 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_804 = happySpecReduce_1 301# happyReduction_804 -happyReduction_804 happy_x_1 - = case happyOut318 happy_x_1 of { (HappyWrap318 happy_var_1) -> - happyIn317 - (happy_var_1 - )} - -happyReduce_805 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_805 = happySpecReduce_0 301# happyReduction_805 -happyReduction_805 = happyIn317 - (([], 0) - ) - -happyReduce_806 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_806 = happySpecReduce_2 302# happyReduction_806 -happyReduction_806 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 -> - happyIn318 - (((fst happy_var_1)++[gl happy_var_2],snd 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 happyOutTok happy_x_1 of { happy_var_1 -> - happyIn318 - (([gl happy_var_1],1) - )} - -happyReduce_808 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_808 = happySpecReduce_3 303# happyReduction_808 -happyReduction_808 happy_x_3 - happy_x_2 - happy_x_1 - = 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 -> - happyIn319 - (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_809 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_809 = happySpecReduce_3 303# happyReduction_809 -happyReduction_809 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut323 happy_x_2 of { (HappyWrap323 happy_var_2) -> - happyIn319 - (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_810 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_810 = happySpecReduce_2 303# happyReduction_810 -happyReduction_810 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn319 - (amsrl (sLL happy_var_1 happy_var_2 []) (AnnList Nothing (Just $ moc happy_var_1) (Just $ mcc happy_var_2) [] []) - )}} - -happyReduce_811 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_811 = happySpecReduce_2 303# happyReduction_811 -happyReduction_811 happy_x_2 - happy_x_1 - = happyIn319 - (return $ noLocA [] - ) - -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 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_813 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_813 = happySpecReduce_3 304# happyReduction_813 -happyReduction_813 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_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 - = 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_815 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_815 = happySpecReduce_2 304# happyReduction_815 -happyReduction_815 happy_x_2 - happy_x_1 - = happyIn320 - (return $ noLocA [] - ) - -happyReduce_816 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_816 = happyMonadReduce 2# 305# happyReduction_816 -happyReduction_816 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> - case happyOut206 happy_x_2 of { (HappyWrap206 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 (happyIn321 r)) - -happyReduce_817 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_817 = happyMonadReduce 2# 306# happyReduction_817 -happyReduction_817 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen ((case happyOut211 happy_x_1 of { (HappyWrap211 happy_var_1) -> - case happyOut208 happy_x_2 of { (HappyWrap208 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_818 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_818 = happySpecReduce_1 307# happyReduction_818 -happyReduction_818 happy_x_1 - = case happyOut325 happy_x_1 of { (HappyWrap325 happy_var_1) -> - happyIn323 - (happy_var_1 >>= \ happy_var_1 -> return $ - sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1) - )} - -happyReduce_819 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_819 = happySpecReduce_2 307# happyReduction_819 -happyReduction_819 happy_x_2 - happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut323 happy_x_2 of { (HappyWrap323 happy_var_2) -> - happyIn323 - (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_820 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_820 = happySpecReduce_1 308# happyReduction_820 -happyReduction_820 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_821 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_821 = happySpecReduce_2 308# happyReduction_821 -happyReduction_821 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_822 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_822 = happySpecReduce_3 309# happyReduction_822 -happyReduction_822 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut325 happy_x_1 of { (HappyWrap325 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut327 happy_x_3 of { (HappyWrap327 happy_var_3) -> - happyIn325 - (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_823 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_823 = happySpecReduce_2 309# happyReduction_823 -happyReduction_823 happy_x_2 - happy_x_1 - = case happyOut325 happy_x_1 of { (HappyWrap325 happy_var_1) -> - case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn325 - (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_824 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_824 = happySpecReduce_1 309# happyReduction_824 -happyReduction_824 happy_x_1 - = case happyOut327 happy_x_1 of { (HappyWrap327 happy_var_1) -> - happyIn325 - (happy_var_1 >>= \ happy_var_1 -> return $ sL1 (reLoc happy_var_1) ([],[happy_var_1]) - )} - -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_2 311# happyReduction_828 -happyReduction_828 happy_x_2 - happy_x_1 - = case happyOut245 happy_x_1 of { (HappyWrap245 happy_var_1) -> - case happyOut236 happy_x_2 of { (HappyWrap236 happy_var_2) -> - happyIn327 - (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_829 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) -happyReduce_829 = happySpecReduce_2 312# happyReduction_829 -happyReduction_829 happy_x_2 - happy_x_1 - = case happyOut242 happy_x_1 of { (HappyWrap242 happy_var_1) -> - case happyOut236 happy_x_2 of { (HappyWrap236 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 })) - )}} - -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 {(HappyWrap249 x') = happyOut249 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 {(HappyWrap206 x') = happyOut206 x} in x')) - -parsePattern = happySomeParser where - happySomeParser = happyThen (happyParse 6#) (\x -> happyReturn (let {(HappyWrap241 x') = happyOut241 x} in x')) - -parseTypeSignature = happySomeParser where - happySomeParser = happyThen (happyParse 7#) (\x -> happyReturn (let {(HappyWrap202 x') = happyOut202 x} in x')) - -parseStmt = happySomeParser where - happySomeParser = happyThen (happyParse 8#) (\x -> happyReturn (let {(HappyWrap248 x') = happyOut248 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 {(HappyWrap158 x') = happyOut158 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 - --- 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 (EpaSpan $ rs $ gl l) - -mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn -mjN a l = AddEpAnn a (EpaSpan $ rs $ 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 (EpaSpan $ rs $ gl l)] - -msemi :: Located e -> [TrailingAnn] -msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (EpaSpan $ rs $ gl l)] - -msemim :: Located e -> Maybe EpaLocation -msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (EpaSpan $ rs $ 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) (EpaSpan $ rs 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 = EpaSpan <$> realSrcSpan . 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 = EpaSpan <$> realSrcSpan . 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) -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 (EpaSpan $ rs 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) - --- ------------------------------------- - -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 (EpaSpan $ rs ss)) cs anns - return (L (SrcSpanAnn anns' l) a) - --- ------------------------------------- - -addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a) -addTrailingVbarL la span = addTrailingAnnL la (AddVbarAnn (EpaSpan $ rs span)) - -addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a) -addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (EpaSpan $ rs 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 (EpaSpan $ rs span) +{-# 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 diff --git a/GHC/Parser/Annotation.hs b/GHC/Parser/Annotation.hs --- a/GHC/Parser/Annotation.hs +++ b/GHC/Parser/Annotation.hs @@ -51,7 +51,7 @@ la2na, na2la, n2l, l2n, l2l, la2la, reLoc, reLocA, reLocL, reLocC, reLocN, - la2r, realSrcSpan, + srcSpan2e, la2e, realSrcSpan, -- ** Building up annotations extraToAnnList, reAnn, @@ -95,7 +95,6 @@ import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Hs.DocString -import GHC.Utils.Binary import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic import qualified GHC.Data.Strict as Strict @@ -202,7 +201,6 @@ data AnnKeywordId = AnnAnyclass | AnnAs - | AnnAt | AnnBang -- ^ '!' | AnnBackquote -- ^ '`' | AnnBy @@ -405,7 +403,7 @@ -- 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 +data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan) | EpaDelta !DeltaPos ![LEpaComment] deriving (Data,Eq) @@ -414,6 +412,9 @@ 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 @@ -446,15 +447,15 @@ -- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the -- partial function is safe. epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan -epaLocationRealSrcSpan (EpaSpan r) = r +epaLocationRealSrcSpan (EpaSpan r _) = r epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan" epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation -epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l) -epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) +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 (EpaSpan r _) = text "EpaSpan" <+> ppr r ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs instance Outputable AddEpAnn where @@ -545,7 +546,7 @@ -- 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 occuring before the AST element and those +-- 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 @@ -631,7 +632,7 @@ -- Annotations for items in a list -- --------------------------------------------------------------------- --- | Captures the location of punctuation occuring between items, +-- | Captures the location of punctuation occurring between items, -- normally in a list. It is captured as a trailing annotation. data TrailingAnn = AddSemiAnn EpaLocation -- ^ Trailing ';' @@ -915,9 +916,13 @@ where l = mkRealSrcLoc (fsLit "foo") (-1) (-1) -la2r :: SrcSpanAnn' a -> RealSrcSpan -la2r l = realSrcSpan (locA l) +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 @@ -975,7 +980,7 @@ widenSpan s as = foldl combineSrcSpans s (go as) where go [] = [] - go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Strict.Nothing : go rest + 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 @@ -984,7 +989,7 @@ widenRealSpan s as = foldl combineRealSrcSpans s (go as) where go [] = [] - go (AddEpAnn _ (EpaSpan s):rest) = s : go rest + go (AddEpAnn _ (EpaSpan s _):rest) = s : go rest go (AddEpAnn _ (EpaDelta _ _):rest) = go rest widenAnchor :: Anchor -> [AddEpAnn] -> Anchor @@ -1246,17 +1251,6 @@ instance Outputable IsUnicodeSyntax where ppr = text . show - -instance Binary a => Binary (LocatedL a) where - -- We do not serialise the annotations - put_ bh (L l x) = do - put_ bh (locA l) - put_ bh x - - get bh = do - l <- get bh - x <- get bh - return (L (noAnnSrcSpan l) x) instance (Outputable a) => Outputable (SrcSpanAnn' a) where ppr (SrcSpanAnn a l) = text "SrcSpanAnn" <+> ppr a <+> ppr l 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 @@ -3,6 +3,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage @@ -18,6 +22,7 @@ import GHC.Types.Error import GHC.Types.Hint.Ppr (perhapsAsPat) import GHC.Types.SrcLoc +import GHC.Types.Error.Codes ( constructorCode ) import GHC.Types.Name.Reader ( opIsAt, rdrNameOcc, mkUnqual ) import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName) import GHC.Utils.Outputable @@ -26,16 +31,18 @@ import GHC.Data.Maybe (catMaybes) import GHC.Hs.Expr (prependQualified, HsExpr(..), LamCaseVariant(..), lamCaseKeyword) import GHC.Hs.Type (pprLHsContext) -import GHC.Builtin.Names (allNameStrings) +import GHC.Builtin.Names (allNameStringList) import GHC.Builtin.Types (filterCTuple) import qualified GHC.LanguageExtensions as LangExt import Data.List.NonEmpty (NonEmpty((:|))) instance Diagnostic PsMessage where - diagnosticMessage = \case - PsUnknownMessage m - -> diagnosticMessage m + type DiagnosticOpts PsMessage = NoDiagnosticOpts + defaultDiagnosticOpts = NoDiagnosticOpts + diagnosticMessage _ = \case + PsUnknownMessage (UnknownDiagnostic @e m) + -> diagnosticMessage (defaultDiagnosticOpts @e) m PsHeaderMessage m -> psHeaderMessageDiagnostic m @@ -70,20 +77,20 @@ PsWarnTransitionalLayout reason -> mkSimpleDecorated $ text "transitional layout will not be accepted in the future:" - $$ text (case reason of - TransLayout_Where -> "`where' clause at the same depth as implicit layout block" - TransLayout_Pipe -> "`|' at the same depth as implicit layout block" + $$ (case reason of + TransLayout_Where -> text "`where' clause at the same depth as implicit layout block" + TransLayout_Pipe -> text "`|' at the same depth as implicit layout block" ) PsWarnOperatorWhitespaceExtConflict sym -> let mk_prefix_msg extension_name syntax_meaning = text "The prefix use of a" <+> quotes (pprOperatorWhitespaceSymbol sym) - <+> text "would denote" <+> text syntax_meaning - $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.") + <+> text "would denote" <+> syntax_meaning + $$ nest 2 (text "were the" <+> extension_name <+> text "extension enabled.") in mkSimpleDecorated $ case sym of - OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg "LinearTypes" "a multiplicity annotation" - OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg "TemplateHaskell" "an untyped splice" - OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "TemplateHaskell" "a typed splice" + OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg (text "LinearTypes") (text "a multiplicity annotation") + OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg (text "TemplateHaskell") (text "an untyped splice") + OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg (text "TemplateHaskell") (text "a typed splice") PsWarnOperatorWhitespace sym occ_type -> let mk_msg occ_type_str = text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym) @@ -105,8 +112,9 @@ <+> quotes (text "Data.Kind.Type") $$ text "relies on the StarIsType extension, which will become" $$ text "deprecated in the future." - PsWarnUnrecognisedPragma + PsWarnUnrecognisedPragma prag _ -> mkSimpleDecorated $ text "Unrecognised pragma" + <> if null prag then empty else text ":" <+> text prag PsWarnMisplacedPragma prag -> mkSimpleDecorated $ text "Misplaced" <+> pprFileHeaderPragmaType prag <+> text "pragma" PsWarnImportPreQualified @@ -116,21 +124,21 @@ PsErrLexer err kind -> mkSimpleDecorated $ hcat - [ text $ case err of - LexError -> "lexical error" - 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" + [ case err of + LexError -> text "lexical error" + 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" - , text $ case kind of - LexErrKind_EOF -> " at end of input" - LexErrKind_UTF8 -> " (UTF-8 decoding error)" - LexErrKind_Char c -> " at character " ++ show c + , case kind of + LexErrKind_EOF -> text " at end of input" + LexErrKind_UTF8 -> text " (UTF-8 decoding error)" + LexErrKind_Char c -> text $ " at character " ++ show c ] PsErrParse token _details | null token @@ -445,7 +453,7 @@ PEIP_NegApp -> text "-" <> ppr s PEIP_TypeArgs peipd_tyargs | not (null peipd_tyargs) -> ppr s <+> vcat [ - hsep [text "@" <> ppr t | t <- peipd_tyargs] + hsep (map ppr peipd_tyargs) , text "Type applications in patterns are only allowed on data constructors." ] | otherwise -> ppr s @@ -478,7 +486,7 @@ , nest 2 (what <+> tc' - <+> hsep (map text (takeList tparms allNameStrings)) + <+> hsep (map text (takeList tparms allNameStringList)) <+> equals_or_where) ] ] where -- Avoid printing a constraint tuple in the error message. Print @@ -499,7 +507,23 @@ ] PsErrInvalidCApiImport {} -> mkSimpleDecorated $ vcat [ text "Wrapper stubs can't be used with CApiFFI."] - diagnosticReason = \case + PsErrMultipleConForNewtype tycon n -> mkSimpleDecorated $ vcat + [ sep + [ text "A newtype must have exactly one constructor," + , nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] + , text "In the newtype declaration for" <+> quotes (ppr tycon) ] + + PsErrUnicodeCharLooksLike bad_char looks_like_char looks_like_char_name + -> mkSimpleDecorated $ + hsep [ text "Unicode character" + -- purposefully not using `quotes (text [bad_char])`, because the quotes function adds smart quotes, + -- and smart quotes may be the topic of this error message + , text "'" <> text [bad_char] <> text "' (" <> text (show bad_char) <> text ")" + , text "looks like" + , text "'" <> text [looks_like_char] <> text "' (" <> text looks_like_char_name <> text ")" <> comma + , text "but it is not" ] + + diagnosticReason = \case PsUnknownMessage m -> diagnosticReason m PsHeaderMessage m -> psHeaderMessageReason m PsWarnBidirectionalFormatChars{} -> WarningWithFlag Opt_WarnUnicodeBidirectionalFormatCharacters @@ -511,7 +535,7 @@ PsWarnHaddockIgnoreMulti -> WarningWithFlag Opt_WarnInvalidHaddock PsWarnStarBinder -> WarningWithFlag Opt_WarnStarBinder PsWarnStarIsType -> WarningWithFlag Opt_WarnStarIsType - PsWarnUnrecognisedPragma -> WarningWithFlag Opt_WarnUnrecognisedPragmas + PsWarnUnrecognisedPragma{} -> WarningWithFlag Opt_WarnUnrecognisedPragmas PsWarnMisplacedPragma{} -> WarningWithFlag Opt_WarnMisplacedPragmas PsWarnImportPreQualified -> WarningWithFlag Opt_WarnPrepositiveQualifiedModule PsErrLexer{} -> ErrorWithoutFlag @@ -615,8 +639,10 @@ PsErrParseRightOpSectionInPat{} -> ErrorWithoutFlag PsErrIllegalGadtRecordMultiplicity{} -> ErrorWithoutFlag PsErrInvalidCApiImport {} -> ErrorWithoutFlag + PsErrMultipleConForNewtype {} -> ErrorWithoutFlag + PsErrUnicodeCharLooksLike{} -> ErrorWithoutFlag - diagnosticHints = \case + diagnosticHints = \case PsUnknownMessage m -> diagnosticHints m PsHeaderMessage m -> psHeaderMessageHints m PsWarnBidirectionalFormatChars{} -> noHints @@ -628,7 +654,12 @@ PsWarnHaddockIgnoreMulti -> noHints PsWarnStarBinder -> [SuggestQualifyStarOperator] PsWarnStarIsType -> [SuggestUseTypeFromDataKind Nothing] - PsWarnUnrecognisedPragma -> noHints + PsWarnUnrecognisedPragma "" _ -> noHints + PsWarnUnrecognisedPragma p avail -> + let suggestions = fuzzyMatch p avail + in if null suggestions + then noHints + else [SuggestCorrectPragmaName suggestions] PsWarnMisplacedPragma{} -> [SuggestPlacePragmaInHeader] PsWarnImportPreQualified -> [ SuggestQualifiedAfterModuleName , suggestExtension LangExt.ImportQualifiedPost] @@ -779,6 +810,10 @@ PsErrInvalidPackageName{} -> noHints PsErrIllegalGadtRecordMultiplicity{} -> noHints PsErrInvalidCApiImport {} -> noHints + PsErrMultipleConForNewtype {} -> noHints + PsErrUnicodeCharLooksLike{} -> noHints + + diagnosticCode = constructorCode 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,11 +1,10 @@ -{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} module GHC.Parser.Errors.Types where import GHC.Prelude -import Data.Typeable - import GHC.Core.TyCon (Role) import GHC.Data.FastString import GHC.Hs @@ -15,11 +14,11 @@ import GHC.Types.Hint import GHC.Types.Name.Occurrence (OccName) import GHC.Types.Name.Reader -import GHC.Unit.Module.Name -import GHC.Utils.Outputable import Data.List.NonEmpty (NonEmpty) import GHC.Types.SrcLoc (PsLoc) +import GHC.Generics ( Generic ) + -- The type aliases below are useful to make some type signatures a bit more -- descriptive, like 'handleWarningsThrowErrors' in 'GHC.Driver.Main'. @@ -60,6 +59,7 @@ tests/driver/T2499 -} | PsErrUnknownOptionsPragma !String + deriving Generic data PsMessage @@ -68,7 +68,7 @@ arbitrary messages to be embedded. The typical use case would be GHC plugins willing to emit custom diagnostics. -} - forall a. (Diagnostic a, Typeable a) => PsUnknownMessage a + PsUnknownMessage UnknownDiagnostic {-| A group of parser messages emitted in 'GHC.Parser.Header'. See Note [Messages from GHC.Parser.Header]. @@ -78,7 +78,7 @@ {-| PsWarnBidirectionalFormatChars is a warning (controlled by the -Wwarn-bidirectional-format-characters flag) that occurs when unicode bi-directional format characters are found within in a file - The 'PsLoc' contains the exact position in the buffer the character occured, and the + The 'PsLoc' contains the exact position in the buffer the character occurred, and the string contains a description of the character. -} | PsWarnBidirectionalFormatChars (NonEmpty (PsLoc, Char, String)) @@ -117,8 +117,9 @@ -} | PsWarnTransitionalLayout !TransLayoutReason - -- | Unrecognised pragma - | PsWarnUnrecognisedPragma + -- | Unrecognised pragma. First field is the actual pragma name which + -- might be empty. Second field is the set of valid candidate pragmas. + | PsWarnUnrecognisedPragma !String ![String] | PsWarnMisplacedPragma !FileHeaderPragmaType -- | Invalid Haddock comment position @@ -456,13 +457,22 @@ -- | Parse error in right operator section pattern -- TODO: embed the proper operator, if possible - | forall infixOcc. (OutputableBndr infixOcc) => PsErrParseRightOpSectionInPat !infixOcc !(PatBuilder GhcPs) + | PsErrParseRightOpSectionInPat !RdrName !(PatBuilder GhcPs) -- | Illegal linear arrow or multiplicity annotation in GADT record syntax | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs) | PsErrInvalidCApiImport + | PsErrMultipleConForNewtype !RdrName !Int + + | PsErrUnicodeCharLooksLike + Char -- ^ the problematic character + Char -- ^ the character it looks like + String -- ^ the name of the character that it looks like + + deriving Generic + -- | Extra details about a parse error, which helps -- us in determining which should be the hints to -- suggest. @@ -496,7 +506,7 @@ = ParseContext { is_infix :: !(Maybe RdrName) -- ^ If 'Just', this is an infix - -- pattern with the binded operator name + -- pattern with the bound operator name , incomplete_do_block :: !PatIncompleteDoBlock -- ^ Did the parser likely fail due to an incomplete do block? } deriving Eq @@ -504,7 +514,7 @@ data PsErrInPatDetails = PEIP_NegApp -- ^ Negative application pattern? - | PEIP_TypeArgs [HsPatSigType GhcPs] + | 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? diff --git a/GHC/Parser/HaddockLex.hs b/GHC/Parser/HaddockLex.hs --- a/GHC/Parser/HaddockLex.hs +++ b/GHC/Parser/HaddockLex.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 1 "_build/source-dist/ghc-9.4.8-src/ghc-9.4.8/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 1 "_build/source-dist/ghc-9.6.1-src/ghc-9.6.1/compiler/GHC/Parser/HaddockLex.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -110,7 +110,7 @@ , (0,alex_action_1) ] -{-# LINE 87 "_build/source-dist/ghc-9.4.8-src/ghc-9.4.8/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 87 "_build/source-dist/ghc-9.6.1-src/ghc-9.6.1/compiler/GHC/Parser/HaddockLex.x" #-} data AlexInput = AlexInput { alexInput_position :: !RealSrcLoc , alexInput_string :: !ByteString @@ -174,7 +174,7 @@ RealSrcSpan span _ -> [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs] UnhelpfulSpan reason -> [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc bs] - fakeLoc = mkRealSrcLoc (mkFastString "") 0 0 + fakeLoc = mkRealSrcLoc nilFS 0 0 -- | Lex identifiers from a docstring. lexHsDoc :: P (LocatedN RdrName) -- ^ A precise identifier parser @@ -195,7 +195,7 @@ plausibleIdents (L (UnhelpfulSpan reason) (HsDocStringChunk s)) = [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason - fakeLoc = mkRealSrcLoc (mkFastString "") 0 0 + fakeLoc = mkRealSrcLoc nilFS 0 0 validateIdentWith :: P (LocatedN RdrName) -> SrcSpan -> ByteString -> Maybe (Located RdrName) validateIdentWith identParser mloc str0 = @@ -217,7 +217,7 @@ buffer = stringBufferFromByteString str0 realSrcLc = case mloc of RealSrcSpan loc _ -> realSrcSpanStart loc - UnhelpfulSpan _ -> mkRealSrcLoc (mkFastString "") 0 0 + UnhelpfulSpan _ -> mkRealSrcLoc nilFS 0 0 pstate = initParserState pflags buffer realSrcLc in case unP identParser pstate of POk _ name -> Just $ case mloc of diff --git a/GHC/Parser/Header.hs b/GHC/Parser/Header.hs --- a/GHC/Parser/Header.hs +++ b/GHC/Parser/Header.hs @@ -145,16 +145,18 @@ loc' = noAnnSrcSpan loc preludeImportDecl :: LImportDecl GhcPs preludeImportDecl - = L loc' $ ImportDecl { ideclExt = noAnn, - ideclSourceSrc = NoSourceText, + = L loc' $ ImportDecl { ideclExt = XImportDeclPass + { ideclAnn = noAnn + , ideclSourceText = NoSourceText + , ideclImplicit = True -- Implicit! + }, ideclName = L loc' pRELUDE_NAME, ideclPkgQual = NoRawPkgQual, ideclSource = NotBoot, ideclSafe = False, -- Not a safe import ideclQualified = NotQualified, - ideclImplicit = True, -- Implicit! ideclAs = Nothing, - ideclHiding = Nothing } + ideclImportList = Nothing } -------------------------------------------------------------- -- Get options diff --git a/GHC/Parser/Lexer.hs b/GHC/Parser/Lexer.hs --- a/GHC/Parser/Lexer.hs +++ b/GHC/Parser/Lexer.hs @@ -1,3615 +1,3743 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 43 "_build/source-dist/ghc-9.4.8-src/ghc-9.4.8/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\xec\x00\x00\x00\x06\x01\x00\x00\x22\x01\x00\x00\x3f\x01\x00\x00\x7b\x01\x00\x00\x00\x00\x00\x00\x85\xff\xff\xff\x00\x00\x00\x00\xf8\x01\x00\x00\x00\x00\x00\x00\x74\x02\x00\x00\x00\x00\x00\x00\xf0\x02\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6c\x03\x00\x00\x00\x00\x00\x00\xe8\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x04\x00\x00\x00\x00\x00\x00\x82\x04\x00\x00\xfc\x04\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x56\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\xd7\xff\xff\xff\x00\x00\x00\x00\xd4\x05\x00\x00\x4e\x06\x00\x00\xc8\x06\x00\x00\x42\x07\x00\x00\xbc\x07\x00\x00\x36\x08\x00\x00\xb0\x08\x00\x00\x2a\x09\x00\x00\xa4\x09\x00\x00\x1e\x0a\x00\x00\x98\x0a\x00\x00\x12\x0b\x00\x00\x4c\x0b\x00\x00\xc6\x0b\x00\x00\x40\x0c\x00\x00\xba\x0c\x00\x00\x34\x0d\x00\x00\xae\x0d\x00\x00\x28\x0e\x00\x00\xa2\x0e\x00\x00\x1c\x0f\x00\x00\x96\x0f\x00\x00\x10\x10\x00\x00\x9c\xff\xff\xff\xa0\xff\xff\xff\xa1\xff\xff\xff\xab\xff\xff\xff\xee\xff\xff\xff\xef\xff\xff\xff\xf0\xff\xff\xff\xf1\xff\xff\xff\xf2\xff\xff\xff\xf3\xff\xff\xff\x6a\x10\x00\x00\x9f\x10\x00\x00\xe5\x10\x00\x00\x08\x11\x00\x00\x2b\x11\x00\x00\x3d\x01\x00\x00\x82\x10\x00\x00\x51\x00\x00\x00\x76\x00\x00\x00\xd1\x00\x00\x00\xd4\x01\x00\x00\x3c\x11\x00\x00\x80\x11\x00\x00\xa5\x11\x00\x00\xee\x11\x00\x00\x63\x00\x00\x00\x7e\x00\x00\x00\x4f\x02\x00\x00\xcc\x02\x00\x00\xf8\x11\x00\x00\x31\x12\x00\x00\xe1\x01\x00\x00\x47\x03\x00\x00\xe7\xff\xff\xff\xc4\x03\x00\x00\x5c\x02\x00\x00\x5d\x04\x00\x00\xd7\x04\x00\x00\xaf\x05\x00\x00\x72\x05\x00\x00\xd4\x02\x00\x00\x2f\x06\x00\x00\x72\x12\x00\x00\xa1\x06\x00\x00\x56\x03\x00\x00\xb3\x12\x00\x00\xce\x03\x00\x00\xf4\x12\x00\x00\x1d\x07\x00\x00\x35\x13\x00\x00\x95\x07\x00\x00\xe6\x04\x00\x00\x76\x13\x00\x00\x67\x05\x00\x00\xb7\x13\x00\x00\x11\x08\x00\x00\x60\x00\x00\x00\x68\x00\x00\x00\x69\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\x72\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x13\x00\x00\x09\x01\x00\x00\x00\x00\x00\x00\x1b\x01\x00\x00\x6a\x00\x00\x00\x90\x00\x00\x00\x92\x00\x00\x00\x93\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x98\x00\x00\x00\x99\x00\x00\x00\x74\x14\x00\x00\x9c\x14\x00\x00\x85\x00\x00\x00\xdf\x14\x00\x00\x07\x15\x00\x00\x4a\x15\x00\x00\x72\x15\x00\x00\xba\x00\x00\x00\xf7\x01\x00\x00\x8b\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x05\x09\x00\x00\x5d\x00\x00\x00\x56\x00\x00\x00\xcc\x00\x00\x00\x7f\x09\x00\x00\x84\x15\x00\x00\xb9\x05\x00\x00\xf9\x09\x00\x00\x73\x0a\x00\x00\xa1\x15\x00\x00\x39\x06\x00\x00\xed\x0a\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x75\x00\x00\x00\x74\x00\x00\x00\x71\x00\x00\x00\x7f\x00\x00\x00\x70\x00\x00\x00\xde\x15\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\xcb\x00\x00\x00\x58\x01\x00\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x16\x00\x00\xd6\x16\x00\x00\xef\x02\x00\x00\x50\x17\x00\x00\xca\x17\x00\x00\x44\x18\x00\x00\xbe\x18\x00\x00\x38\x19\x00\x00\xb2\x19\x00\x00\x2c\x1a\x00\x00\xa6\x1a\x00\x00\x24\x1b\x00\x00\x8d\x01\x00\x00\x9e\x1b\x00\x00\xa1\x0b\x00\x00\xbe\x1b\x00\x00\xe5\x00\x00\x00\xe6\x00\x00\x00\x18\x02\x00\x00\xea\x00\x00\x00\xff\x00\x00\x00\x38\x1c\x00\x00\xb6\x1c\x00\x00\x91\x02\x00\x00\x30\x1d\x00\x00\x1b\x0c\x00\x00\x00\x00\x00\x00\xc6\x00\x00\x00\x7d\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\xd3\x00\x00\x00\x3a\x1d\x00\x00\xb9\x0c\x00\x00\x97\x0c\x00\x00\x54\x1d\x00\x00\xa3\x1d\x00\x00\x1d\x1e\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\xe0\x00\x00\x00\x57\x1e\x00\x00\xb1\x1e\x00\x00\x2d\x1f\x00\x00\x87\x1f\x00\x00\xc7\x1f\x00\x00\x84\x04\x00\x00\xed\x00\x00\x00\x41\x20\x00\x00\x00\x00\x00\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x20\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# - "\x00\x00\x0e\x00\x43\x00\xca\x00\x91\x00\x4e\x00\x8f\x00\x1a\x00\x45\x00\x46\x00\x90\x00\xc5\x00\x8f\x00\x8f\x00\x8f\x00\x47\x00\xc3\x00\x48\x00\x49\x00\x4a\x00\x4c\x00\x4a\x00\x4d\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x8f\x00\x4e\x00\x8d\x00\x22\x00\x4e\x00\x4e\x00\x4e\x00\x8c\x00\x20\x00\x25\x00\x4e\x00\x4e\x00\x28\x00\x4f\x00\x4e\x00\x4e\x00\x53\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x52\x00\x29\x00\x4e\x00\x4e\x00\x4e\x00\xea\x00\x4e\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\xf1\x00\x4e\x00\x27\x00\x4e\x00\x40\x00\x2a\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\xf6\x00\x1c\x00\x2c\x00\x4e\x00\x8f\x00\x56\x00\x56\x00\x84\x00\x90\x00\xa4\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x21\x00\x85\x00\x86\x00\x90\x00\x87\x00\x8f\x00\x8f\x00\x8f\x00\xf8\x00\x5e\x00\x5e\x00\x89\x00\x8b\x00\xc8\x00\xf8\x00\x7d\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\x81\x00\xff\xff\xff\xff\x8f\x00\x8f\x00\x56\x00\x56\x00\x9c\x00\x90\x00\xc2\x00\x8f\x00\x8f\x00\x8f\x00\x5e\x00\x5e\x00\x55\x00\x9c\x00\x9b\x00\xd5\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xa5\x00\xa8\x00\x8f\x00\x8f\x00\x5d\x00\x44\x00\xff\xff\x90\x00\xc2\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\xa6\x00\xf8\x00\x9c\x00\x90\x00\xc2\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\xb3\x00\x55\x00\xb4\x00\x90\x00\xb6\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x5d\x00\x98\x00\x44\x00\xb7\x00\xb5\x00\xb8\x00\x1b\x00\x98\x00\x8f\x00\xbb\x00\xbd\x00\x44\x00\x9c\x00\xf8\x00\xc8\x00\xbe\x00\xbc\x00\x8f\x00\xff\xff\xff\xff\x8f\x00\x9c\x00\x9b\x00\xff\xff\x90\x00\x92\x00\x8f\x00\x8f\x00\x8f\x00\xe0\x00\x9c\x00\xe2\x00\xe4\x00\xed\x00\x92\x00\xe5\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\xff\xff\xfa\x00\xd8\x00\x8f\x00\xee\x00\x8f\x00\xd7\x00\xff\xff\xd8\x00\xd8\x00\xd8\x00\x8f\x00\x8f\x00\x8f\x00\x9e\x00\x98\x00\x9c\x00\xf5\x00\xc1\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd8\x00\x8f\x00\x00\x00\x8f\x00\x00\x00\x90\x00\x93\x00\x8f\x00\x8f\x00\x8f\x00\x57\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x98\x00\xc1\x00\xa9\x00\x00\x00\x00\x00\x15\x00\xb9\x00\x00\x00\xf7\x00\xf8\x00\xc1\x00\xc4\x00\x8f\x00\xe0\x00\x8f\x00\xf8\x00\x00\x00\x00\x00\x90\x00\x92\x00\x8f\x00\x8f\x00\x8f\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x8f\x00\x00\x00\x8f\x00\x7c\x00\x00\x00\xe3\x00\x8f\x00\x8f\x00\x8f\x00\x00\x00\x92\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xe1\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x8f\x00\xf8\x00\x00\x00\xbf\x00\x42\x00\x41\x00\x00\x00\x55\x00\x8f\x00\xda\x00\x63\x00\x00\x00\x90\x00\xc5\x00\x8f\x00\x8f\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x00\x00\x00\x00\x00\x59\x00\x00\x00\xf8\x00\xd2\x00\xd2\x00\xd2\x00\x8f\x00\xaf\x00\x92\x00\xef\x00\x55\x00\x00\x00\x00\x00\x63\x00\x24\x00\x25\x00\x00\x00\x00\x00\x28\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x57\x00\xd2\x00\x00\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x29\x00\x00\x00\x00\x00\x00\x00\x92\x00\x00\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x26\x00\x00\x00\x27\x00\x00\x00\x41\x00\x2a\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x2b\x00\x7e\x00\x2c\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\xff\xff\x00\x00\x00\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x65\x00\x00\x00\x65\x00\x00\x00\x00\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x97\x00\x00\x00\xd8\x00\x00\x00\x16\x00\x00\x00\x97\x00\xff\xff\xd8\x00\xd8\x00\xd8\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x97\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x97\x00\x10\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x60\x00\x6c\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\xdd\x00\xdd\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x5f\x00\x00\x00\x00\x00\xdd\x00\x00\x00\xdc\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x82\x00\x12\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\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\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x15\x00\x00\x00\x00\x00\xc7\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\xf8\x00\x14\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x72\x00\x00\x00\x72\x00\x00\x00\x00\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x88\x00\x17\x00\x18\x00\x18\x00\x18\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x66\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\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\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x4e\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\x4e\x00\x19\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x1d\x00\x4e\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\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\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\xfb\x00\x4e\x00\x00\x00\x67\x00\x00\x00\x15\x00\x00\x00\x00\x00\xf4\x00\xf8\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x68\x00\x00\x00\xfc\x00\x00\x00\x4e\x00\x00\x00\x67\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\xf8\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1f\x00\x1f\x00\x1f\x00\xf8\x00\x00\x00\x00\x00\x1f\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\x79\x00\x00\x00\x79\x00\x00\x00\x00\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\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\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x00\x00\x1f\x00\x00\x00\x4e\x00\x1f\x00\x00\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x23\x00\x4e\x00\x4e\x00\x00\x00\xf3\x00\x4e\x00\x4e\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\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x1f\x00\x00\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x6b\x00\x4e\x00\x00\x00\x4e\x00\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\xad\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\x00\x00\x67\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\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\x00\x00\x00\x00\x00\x00\x35\x00\x00\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\x8a\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\x00\x00\x00\x00\x38\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\x6b\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\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\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\x00\x00\x00\x00\x00\x00\x35\x00\x00\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\x30\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\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\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\x48\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x35\x00\x00\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\x00\x00\x00\x00\x00\x00\x38\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\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\x38\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\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\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\x32\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\x38\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\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\xa3\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\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\x35\x00\x35\x00\x35\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\x00\x7b\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\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\xa3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x2f\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\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\x00\x74\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\x48\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x35\x00\x00\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\x2d\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\x00\x00\x00\x00\x35\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\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\x48\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\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\x00\x00\x00\x00\x00\x00\x35\x00\x00\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\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\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\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\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\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\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\x31\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\x38\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\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\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\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\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\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\x2e\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\x38\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\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\x38\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\xb2\x00\x3a\x00\x38\x00\x00\x00\x00\x00\x00\x00\x63\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\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\x38\x00\x00\x00\x38\x00\x38\x00\x38\x00\x37\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x36\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\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\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\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\x3a\x00\xd4\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\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\x00\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x00\x00\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\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\x3b\x00\xdf\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\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\xca\x00\xca\x00\xca\x00\xe8\x00\x00\x00\x00\x00\xca\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\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\x00\x00\xe8\x00\x00\x00\x00\x00\xe6\x00\x4a\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x65\x00\x00\x00\x00\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x00\x00\x00\x00\xe9\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\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\x4a\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\x3c\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\xc9\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\x3c\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\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\x4a\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\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\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\x3e\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\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\x4b\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\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\x00\x3f\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\x3e\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\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\x4a\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\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\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\x40\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\x41\x00\x41\x00\x41\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\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\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\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x41\x00\x42\x00\x42\x00\x42\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x39\x00\x00\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x42\x00\x43\x00\x43\x00\x43\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\x00\x00\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\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x43\x00\x00\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x43\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x7c\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x63\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\xa0\x00\x4e\x00\x4e\x00\x5b\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x63\x00\x4e\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\x4e\x00\x00\x00\x4e\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x51\x00\x00\x00\x00\x00\x50\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x00\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x51\x00\x51\x00\x51\x00\x51\x00\x52\x00\x00\x00\x00\x00\x51\x00\x51\x00\x00\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x51\x00\x50\x00\x51\x00\x51\x00\x51\x00\x51\x00\x51\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x52\x00\x52\x00\x00\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x50\x00\x51\x00\x52\x00\x51\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x51\x00\x00\x00\x51\x00\x52\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x7f\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\xad\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x71\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5d\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\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\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x61\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x83\x00\x00\x00\x00\x00\x61\x00\x00\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x62\x00\x76\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x77\x00\x00\x00\x00\x00\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\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\x77\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\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\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\x77\x00\x00\x00\x00\x00\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\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\x77\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\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\x77\x00\x00\x00\x00\x00\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\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\x77\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\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\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\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x00\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\xff\xff\x0d\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\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\x9a\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\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\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\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\x9a\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\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\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\xd6\x00\x00\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\x00\x00\x00\x00\x00\x00\xd6\x00\xd6\x00\xd6\x00\x9d\x00\xd6\x00\xd6\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xd6\x00\xff\xff\xd6\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\xd6\x00\x00\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\x00\x00\x00\x00\x00\x00\xd6\x00\xd6\x00\x00\x00\x9d\x00\xd6\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\xd6\x00\xd6\x00\xd6\x00\xd6\x00\xd6\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\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x9f\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x4e\x00\xd6\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x00\x00\x9f\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x8a\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x35\x00\x00\x00\x50\x00\xae\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\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\x50\x00\xb2\x00\x50\x00\x50\x00\x50\x00\x50\x00\x00\x00\x63\x00\x00\x00\x50\x00\x50\x00\x00\x00\x50\x00\x50\x00\x50\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\x50\x00\x50\x00\x50\x00\x50\x00\x50\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\x50\x00\x00\x00\x50\x00\x35\x00\x00\x00\x35\x00\x35\x00\x35\x00\x34\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x35\x00\x33\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\x50\x00\x00\x00\x50\x00\xc6\x00\xc6\x00\xc6\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\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\xc6\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\xc7\x00\x00\x00\xc6\x00\x00\x00\x00\x00\xc7\x00\xc7\x00\xc7\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\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\xc6\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\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\x4a\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\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\x3c\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\xc9\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\x3c\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\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\x4a\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\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\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\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\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\xcc\x00\xcc\x00\xcc\x00\x00\x00\xec\x00\x00\x00\xcc\x00\x00\x00\x00\x00\xec\x00\xec\x00\xec\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\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\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\xcd\x00\x00\x00\xcc\x00\x00\x00\x00\x00\xcd\x00\xcd\x00\xcd\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\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\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xce\x00\xce\x00\xce\x00\x00\x00\xec\x00\x00\x00\xce\x00\x00\x00\x00\x00\xec\x00\xec\x00\xec\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\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\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\xcf\x00\x00\x00\xce\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\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\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\x00\x00\xd1\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xd1\x00\xd0\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\x00\x00\xd1\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xd1\x00\xd0\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x00\xd2\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\xd2\x00\xcb\x00\xcb\x00\xcb\x00\x00\x00\xd5\x00\x00\x00\xcb\x00\x00\x00\x00\x00\xc7\x00\xd5\x00\xd5\x00\xd5\x00\x00\x00\x00\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\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\x00\x00\x00\x00\x00\x00\x00\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\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\xdc\x00\xdc\x00\xdc\x00\xdc\x00\x00\x00\xdc\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\xdc\x00\xdc\x00\xdb\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\x00\x00\xdc\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\xdc\x00\xdc\x00\xdb\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\xdd\x00\xdd\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x00\xe8\x00\xe8\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x4e\x00\x00\x00\xe8\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\xe7\x00\x00\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\xdf\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\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\x00\x00\x00\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\x4e\x00\x00\x00\x4e\x00\x1e\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x4e\x00\x00\x00\x4e\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\xeb\x00\xeb\x00\xeb\x00\x00\x00\xec\x00\x00\x00\xeb\x00\x00\x00\x00\x00\xec\x00\xec\x00\xec\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\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\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\xf2\x00\x18\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\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\x16\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x16\x00\x16\x00\x16\x00\x11\x00\x8e\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x0f\x00\x16\x00\x16\x00\x16\x00\x13\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x00\x00\xf9\x00\xf2\x00\xf2\x00\xf2\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\xf0\x00\x00\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x4e\x00\xf2\x00\x00\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\xf2\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\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\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\xce\x00\xce\x00\xce\x00\x00\x00\xcf\x00\x00\x00\xce\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\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\x4e\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\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\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x4e\x00\xed\x00\x4e\x00\x00\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xce\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\xcd\x00\x00\x00\xcc\x00\x00\x00\x00\x00\xcd\x00\xcd\x00\xcd\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\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\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x4e\x00\xcc\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x4e\x00\x00\x00\x4e\x00\x4e\x00\x4e\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\x4e\x00\x4e\x00\x4e\x00\x4e\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x0c\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\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\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\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\x6c\x00\x69\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x6e\x00\x65\x00\x23\x00\x23\x00\x23\x00\x23\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\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\x30\x00\x31\x00\x23\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x23\x00\x23\x00\x23\x00\x09\x00\x23\x00\x0b\x00\x0c\x00\x0d\x00\x24\x00\x30\x00\x31\x00\x23\x00\x23\x00\x2d\x00\x2a\x00\x23\x00\x0a\x00\x20\x00\x0a\x00\x0a\x00\x23\x00\x0a\x00\x0a\x00\x23\x00\x0a\x00\x0a\x00\x20\x00\x05\x00\x30\x00\x31\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x5f\x00\x2d\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\x65\x00\x69\x00\x20\x00\x05\x00\x5f\x00\x23\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x6e\x00\x5e\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x0a\x00\x5f\x00\x61\x00\x09\x00\x67\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x5f\x00\x24\x00\x23\x00\x61\x00\x6d\x00\x72\x00\x7c\x00\x2a\x00\x20\x00\x0a\x00\x0a\x00\x23\x00\x2d\x00\x7c\x00\x2d\x00\x21\x00\x21\x00\x20\x00\x0a\x00\x0a\x00\x05\x00\x2d\x00\x2d\x00\x0a\x00\x09\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\x7d\x00\x2d\x00\x2d\x00\x7d\x00\x7d\x00\x7b\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x0a\x00\x7c\x00\x05\x00\x20\x00\x2d\x00\x05\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x5e\x00\x2d\x00\x2d\x00\x7b\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\x05\x00\xff\xff\x20\x00\xff\xff\x09\x00\x2d\x00\x0b\x00\x0c\x00\x0d\x00\x5f\x00\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\x7c\x00\x7b\x00\x6c\x00\xff\xff\xff\xff\x20\x00\x70\x00\xff\xff\x23\x00\x24\x00\x7b\x00\x7c\x00\x20\x00\x7d\x00\x05\x00\x2a\x00\xff\xff\xff\xff\x09\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\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\x05\x00\xff\xff\x20\x00\x23\x00\xff\xff\x23\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x7b\x00\xff\xff\xff\xff\xff\xff\x2e\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x20\x00\x5e\x00\xff\xff\x23\x00\x01\x00\x02\x00\xff\xff\x42\x00\x05\x00\x7b\x00\x45\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\x58\x00\xff\xff\x7c\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x5f\x00\x7b\x00\x23\x00\x62\x00\xff\xff\xff\xff\x65\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\x2d\x00\xff\xff\xff\xff\xff\xff\x6f\x00\x20\x00\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\x3b\x00\xff\xff\xff\xff\xff\xff\x7b\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\x5b\x00\xff\xff\x5d\x00\xff\xff\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\x23\x00\x7d\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x0a\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\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\x24\x00\xff\xff\x05\x00\xff\xff\x27\x00\xff\xff\x2a\x00\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\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\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\x5e\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7c\x00\x7c\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\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\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\x0b\x00\x0c\x00\x0d\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\x20\x00\xff\xff\x22\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x2a\x00\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\x5f\x00\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\x5e\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7c\x00\x7c\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\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\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\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\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\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\x5f\x00\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\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\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\xff\xff\x45\x00\xff\xff\x20\x00\xff\xff\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\x7c\x00\xff\xff\x7e\x00\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\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\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\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\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\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\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\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x5f\x00\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\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\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\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\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\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\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\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\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\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\x5f\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\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\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\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\x5f\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\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\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\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\x5f\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\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\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\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\x5f\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\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\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\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\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\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\x5f\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\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\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\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\x5f\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\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\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\x05\x00\xff\xff\xff\xff\x07\x00\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\x23\x00\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\x5f\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\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\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\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\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\x3a\x00\x23\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\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\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x5c\x00\x45\x00\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\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x65\x00\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\x30\x00\x31\x00\x32\x00\x33\x00\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\x7c\x00\xff\xff\x7e\x00\x5c\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\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x23\x00\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\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\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x42\x00\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\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\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\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\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x23\x00\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\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\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\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\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\x27\x00\xff\xff\xff\xff\x70\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\x04\x00\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xff\xff\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\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xff\xff\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\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x23\x00\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\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\x23\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\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\x01\x00\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\x65\x00\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\x21\x00\x5f\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x65\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\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\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\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\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\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\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\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\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\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\x04\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\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\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\x5f\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\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\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\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\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\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\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\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\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\x7c\x00\x7d\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\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\x07\x00\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\xd6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\x94\x00\x95\x00\x96\x00\x97\x00\x96\x00\x99\x00\x99\x00\x95\x00\xff\xff\x99\x00\x95\x00\x99\x00\x95\x00\x94\x00\x94\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbc\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd6\x00\xd6\x00\xd6\x00\xd6\x00\xd6\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0 :: Int, 252) - [ AlexAccNone - , AlexAcc 209 - , AlexAccNone - , AlexAcc 208 - , AlexAcc 207 - , AlexAcc 206 - , AlexAcc 205 - , AlexAcc 204 - , AlexAcc 203 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 202 - , AlexAccPred 201 (ifExtension ThQuotesBit)(AlexAccPred 200 (ifExtension QqBit)(AlexAccNone)) - , AlexAccPred 199 (ifExtension ThQuotesBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 198 (ifExtension ThQuotesBit)(AlexAccPred 197 (ifExtension QqBit)(AlexAccNone)) - , AlexAccNone - , AlexAccPred 196 (ifExtension ThQuotesBit)(AlexAccPred 195 (ifExtension QqBit)(AlexAccNone)) - , AlexAccNone - , AlexAccPred 194 (ifExtension ThQuotesBit)(AlexAccPred 193 (ifExtension QqBit)(AlexAccNone)) - , AlexAccNone - , AlexAccNone - , AlexAccPred 192 (ifExtension QqBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 191 (ifExtension QqBit)(AlexAccNone) - , AlexAccPred 190 (ifCurrentChar '⟦' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ThQuotesBit)(AlexAccPred 189 (ifCurrentChar '⟧' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ThQuotesBit)(AlexAccPred 188 (ifCurrentChar '⦇' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ArrowsBit)(AlexAccPred 187 (ifCurrentChar '⦈' `alexAndPred` - ifExtension UnicodeSyntaxBit `alexAndPred` - ifExtension ArrowsBit)(AlexAccNone)))) - , AlexAccPred 186 (ifExtension ArrowsBit `alexAndPred` - notFollowedBySymbol)(AlexAccNone) - , AlexAccPred 185 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 184 (followedByOpeningToken)(AlexAccPred 183 (precededByClosingToken)(AlexAcc 182))) - , AlexAccPred 181 (ifExtension ArrowsBit)(AlexAccNone) - , AlexAccPred 180 (ifExtension IpBit)(AlexAccNone) - , AlexAccPred 179 (ifExtension OverloadedLabelsBit)(AlexAccNone) - , AlexAcc 178 - , AlexAccPred 177 (ifExtension UnboxedParensBit)(AlexAccNone) - , AlexAccPred 176 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 175 (followedByOpeningToken)(AlexAccPred 174 (precededByClosingToken)(AlexAcc 173))) - , AlexAccPred 172 (ifExtension UnboxedParensBit)(AlexAccNone) - , AlexAcc 171 - , AlexAcc 170 - , AlexAcc 169 - , AlexAcc 168 - , AlexAcc 167 - , AlexAcc 166 - , AlexAcc 165 - , AlexAcc 164 - , AlexAcc 163 - , AlexAcc 162 - , AlexAcc 161 - , AlexAcc 160 - , AlexAccPred 159 (ifExtension RecursiveDoBit)(AlexAcc 158) - , AlexAcc 157 - , AlexAccPred 156 (ifExtension RecursiveDoBit)(AlexAcc 155) - , AlexAcc 154 - , AlexAcc 153 - , AlexAcc 152 - , AlexAcc 151 - , AlexAcc 150 - , AlexAcc 149 - , AlexAccNone - , AlexAcc 148 - , AlexAcc 147 - , AlexAcc 146 - , AlexAcc 145 - , AlexAcc 144 - , AlexAcc 143 - , AlexAcc 142 - , AlexAcc 141 - , AlexAcc 140 - , AlexAcc 139 - , AlexAccPred 138 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 137 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 136 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 135 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 134 (ifExtension MagicHashBit)(AlexAccPred 133 (ifExtension MagicHashBit)(AlexAccNone)) - , AlexAccPred 132 (ifExtension MagicHashBit)(AlexAccPred 131 (ifExtension MagicHashBit)(AlexAccNone)) - , AlexAccPred 130 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 129 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 128 (followedByOpeningToken)(AlexAccPred 127 (precededByClosingToken)(AlexAcc 126))) - , AlexAccPred 125 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 124 (followedByOpeningToken)(AlexAccPred 123 (precededByClosingToken)(AlexAcc 122))) - , AlexAcc 121 - , AlexAcc 120 - , AlexAcc 119 - , AlexAcc 118 - , AlexAcc 117 - , AlexAccNone - , AlexAccPred 116 (ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAcc 115 - , AlexAccNone - , AlexAcc 114 - , AlexAccPred 113 (negLitPred)(AlexAccNone) - , AlexAccPred 112 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccPred 111 (negLitPred `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 110 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccPred 109 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 108 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 107 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 106 (ifExtension HexFloatLiteralsBit)(AlexAccNone) - , AlexAccPred 105 (ifExtension HexFloatLiteralsBit)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 104 (ifExtension HexFloatLiteralsBit `alexAndPred` - negLitPred)(AlexAccNone) - , AlexAccPred 103 (ifExtension HexFloatLiteralsBit `alexAndPred` - negLitPred)(AlexAccNone) - , AlexAccPred 102 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 101 (ifExtension MagicHashBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccPred 100 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 99 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 98 (negHashLitPred)(AlexAccNone) - , AlexAccPred 97 (negHashLitPred `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccPred 96 (negHashLitPred)(AlexAccNone) - , AlexAccPred 95 (negHashLitPred)(AlexAccNone) - , AlexAccPred 94 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 93 (ifExtension MagicHashBit `alexAndPred` - ifExtension BinaryLiteralsBit)(AlexAccNone) - , AlexAccPred 92 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 91 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 90 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 89 (ifExtension MagicHashBit)(AlexAccNone) - , AlexAccPred 88 (negHashLitPred)(AlexAccNone) - , AlexAccPred 87 (negHashLitPred)(AlexAccNone) - , AlexAcc 86 - , AlexAcc 85 - , AlexAccNone - , AlexAccSkip - , AlexAcc 84 - , AlexAccPred 83 (isNormalComment)(AlexAccNone) - , AlexAccNone - , AlexAccPred 82 (isNormalComment)(AlexAcc 81) - , AlexAcc 80 - , AlexAcc 79 - , AlexAccPred 78 (alexNotPred (ifExtension HaddockBit))(AlexAccNone) - , AlexAccPred 77 (alexNotPred (ifExtension HaddockBit))(AlexAcc 76) - , AlexAccPred 75 (alexNotPred (ifExtension HaddockBit))(AlexAccPred 74 (ifExtension HaddockBit)(AlexAccNone)) - , AlexAcc 73 - , AlexAccPred 72 (atEOL)(AlexAccNone) - , AlexAccPred 71 (atEOL)(AlexAccNone) - , AlexAccNone - , AlexAccPred 70 (atEOL)(AlexAcc 69) - , AlexAccPred 68 (atEOL)(AlexAcc 67) - , AlexAccPred 66 (atEOL)(AlexAccPred 65 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 64 (followedByOpeningToken)(AlexAccPred 63 (precededByClosingToken)(AlexAcc 62)))) - , AlexAccPred 61 (atEOL)(AlexAccPred 60 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 59 (followedByOpeningToken)(AlexAccPred 58 (precededByClosingToken)(AlexAcc 57)))) - , AlexAccPred 56 (atEOL)(AlexAccNone) - , AlexAccPred 55 (atEOL)(AlexAcc 54) - , AlexAccNone - , AlexAccSkip - , AlexAccPred 53 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 52 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False) `alexAndPred` followedByDigit)(AlexAccNone) - , AlexAccNone - , AlexAccPred 51 (negLitPred)(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 50 - , 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) - , AlexAccNone - , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccNone - , AlexAccNone - , AlexAccSkip - , AlexAccPred 49 (notFollowedBy '-')(AlexAccNone) - , AlexAccSkip - , AlexAccPred 48 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) - , AlexAccPred 47 (notFollowedBySymbol)(AlexAccNone) - , AlexAcc 46 - , AlexAccPred 45 (known_pragma linePrags)(AlexAccNone) - , AlexAccNone - , AlexAccPred 44 (isNormalComment)(AlexAccNone) - , AlexAcc 43 - , AlexAcc 42 - , AlexAccPred 41 (known_pragma linePrags)(AlexAcc 40) - , AlexAccPred 39 (known_pragma linePrags)(AlexAccPred 38 (known_pragma oneWordPrags)(AlexAccPred 37 (known_pragma ignoredPrags)(AlexAccPred 36 (known_pragma fileHeaderPrags)(AlexAccNone)))) - , AlexAccNone - , AlexAccPred 35 (known_pragma linePrags)(AlexAccPred 34 (known_pragma oneWordPrags)(AlexAccPred 33 (known_pragma ignoredPrags)(AlexAccPred 32 (known_pragma fileHeaderPrags)(AlexAccNone)))) - , AlexAccNone - , AlexAcc 31 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 30 - , AlexAcc 29 - , AlexAcc 28 - , AlexAccSkip - , AlexAcc 27 - , AlexAcc 26 - , AlexAcc 25 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 24 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 23 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccPred 22 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 21 (followedByOpeningToken)(AlexAccPred 20 (precededByClosingToken)(AlexAcc 19))) - , AlexAccPred 18 (known_pragma twoWordPrags)(AlexAccNone) - , AlexAccNone - , AlexAcc 17 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 16 - , AlexAccNone - , AlexAccPred 15 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 14 (followedByOpeningToken)(AlexAccPred 13 (precededByClosingToken)(AlexAcc 12))) - , AlexAcc 11 - , AlexAccPred 10 (isNormalComment)(AlexAccNone) - , AlexAcc 9 - , AlexAcc 8 - , AlexAccPred 7 (ifExtension HaddockBit)(AlexAccNone) - , AlexAcc 6 - , AlexAcc 5 - , AlexAcc 4 - , AlexAccPred 3 (precededByClosingToken `alexAndPred` followedByOpeningToken)(AlexAccPred 2 (followedByOpeningToken)(AlexAccPred 1 (precededByClosingToken)(AlexAcc 0))) - ] - -alex_actions = array (0 :: Int, 210) - [ (209,alex_action_15) - , (208,alex_action_21) - , (207,alex_action_22) - , (206,alex_action_20) - , (205,alex_action_23) - , (204,alex_action_27) - , (203,alex_action_28) - , (202,alex_action_44) - , (201,alex_action_45) - , (200,alex_action_50) - , (199,alex_action_46) - , (198,alex_action_47) - , (197,alex_action_50) - , (196,alex_action_48) - , (195,alex_action_50) - , (194,alex_action_49) - , (193,alex_action_50) - , (192,alex_action_50) - , (191,alex_action_51) - , (190,alex_action_52) - , (189,alex_action_53) - , (188,alex_action_56) - , (187,alex_action_57) - , (186,alex_action_54) - , (185,alex_action_81) - , (184,alex_action_82) - , (183,alex_action_83) - , (182,alex_action_84) - , (181,alex_action_55) - , (180,alex_action_58) - , (179,alex_action_59) - , (178,alex_action_62) - , (177,alex_action_60) - , (176,alex_action_81) - , (175,alex_action_82) - , (174,alex_action_83) - , (173,alex_action_84) - , (172,alex_action_61) - , (171,alex_action_62) - , (170,alex_action_63) - , (169,alex_action_64) - , (168,alex_action_65) - , (167,alex_action_66) - , (166,alex_action_67) - , (165,alex_action_68) - , (164,alex_action_69) - , (163,alex_action_70) - , (162,alex_action_71) - , (161,alex_action_71) - , (160,alex_action_73) - , (159,alex_action_72) - , (158,alex_action_73) - , (157,alex_action_73) - , (156,alex_action_72) - , (155,alex_action_73) - , (154,alex_action_73) - , (153,alex_action_73) - , (152,alex_action_73) - , (151,alex_action_73) - , (150,alex_action_73) - , (149,alex_action_73) - , (148,alex_action_74) - , (147,alex_action_74) - , (146,alex_action_75) - , (145,alex_action_75) - , (144,alex_action_75) - , (143,alex_action_75) - , (142,alex_action_75) - , (141,alex_action_75) - , (140,alex_action_76) - , (139,alex_action_76) - , (138,alex_action_18) - , (137,alex_action_77) - , (136,alex_action_78) - , (135,alex_action_79) - , (134,alex_action_79) - , (133,alex_action_112) - , (132,alex_action_79) - , (131,alex_action_113) - , (130,alex_action_80) - , (129,alex_action_81) - , (128,alex_action_82) - , (127,alex_action_83) - , (126,alex_action_84) - , (125,alex_action_81) - , (124,alex_action_82) - , (123,alex_action_83) - , (122,alex_action_84) - , (121,alex_action_85) - , (120,alex_action_86) - , (119,alex_action_87) - , (118,alex_action_88) - , (117,alex_action_88) - , (116,alex_action_89) - , (115,alex_action_90) - , (114,alex_action_91) - , (113,alex_action_92) - , (112,alex_action_92) - , (111,alex_action_93) - , (110,alex_action_94) - , (109,alex_action_95) - , (108,alex_action_96) - , (107,alex_action_97) - , (106,alex_action_98) - , (105,alex_action_98) - , (104,alex_action_99) - , (103,alex_action_99) - , (102,alex_action_100) - , (101,alex_action_101) - , (100,alex_action_102) - , (99,alex_action_103) - , (98,alex_action_104) - , (97,alex_action_105) - , (96,alex_action_106) - , (95,alex_action_107) - , (94,alex_action_108) - , (93,alex_action_109) - , (92,alex_action_110) - , (91,alex_action_111) - , (90,alex_action_112) - , (89,alex_action_113) - , (88,alex_action_114) - , (87,alex_action_115) - , (86,alex_action_116) - , (85,alex_action_117) - , (84,alex_action_1) - , (83,alex_action_2) - , (82,alex_action_2) - , (81,alex_action_28) - , (80,alex_action_3) - , (79,alex_action_4) - , (78,alex_action_5) - , (77,alex_action_5) - , (76,alex_action_28) - , (75,alex_action_5) - , (74,alex_action_39) - , (73,alex_action_6) - , (72,alex_action_7) - , (71,alex_action_7) - , (70,alex_action_7) - , (69,alex_action_28) - , (68,alex_action_7) - , (67,alex_action_28) - , (66,alex_action_7) - , (65,alex_action_81) - , (64,alex_action_82) - , (63,alex_action_83) - , (62,alex_action_84) - , (61,alex_action_7) - , (60,alex_action_81) - , (59,alex_action_82) - , (58,alex_action_83) - , (57,alex_action_84) - , (56,alex_action_8) - , (55,alex_action_8) - , (54,alex_action_28) - , (53,alex_action_10) - , (52,alex_action_11) - , (51,alex_action_97) - , (50,alex_action_96) - , (49,alex_action_16) - , (48,alex_action_18) - , (47,alex_action_19) - , (46,alex_action_24) - , (45,alex_action_25) - , (44,alex_action_2) - , (43,alex_action_75) - , (42,alex_action_75) - , (41,alex_action_25) - , (40,alex_action_28) - , (39,alex_action_25) - , (38,alex_action_33) - , (37,alex_action_34) - , (36,alex_action_36) - , (35,alex_action_25) - , (34,alex_action_33) - , (33,alex_action_34) - , (32,alex_action_37) - , (31,alex_action_26) - , (30,alex_action_28) - , (29,alex_action_28) - , (28,alex_action_1) - , (27,alex_action_28) - , (26,alex_action_28) - , (25,alex_action_29) - , (24,alex_action_30) - , (23,alex_action_31) - , (22,alex_action_81) - , (21,alex_action_82) - , (20,alex_action_83) - , (19,alex_action_84) - , (18,alex_action_32) - , (17,alex_action_35) - , (16,alex_action_64) - , (15,alex_action_81) - , (14,alex_action_82) - , (13,alex_action_83) - , (12,alex_action_84) - , (11,alex_action_38) - , (10,alex_action_2) - , (9,alex_action_69) - , (8,alex_action_38) - , (7,alex_action_40) - , (6,alex_action_41) - , (5,alex_action_42) - , (4,alex_action_43) - , (3,alex_action_81) - , (2,alex_action_82) - , (1,alex_action_83) - , (0,alex_action_84) - ] - -{-# LINE 700 "_build/source-dist/ghc-9.4.8-src/ghc-9.4.8/compiler/GHC/Parser/Lexer.x" #-} --- ----------------------------------------------------------------------------- --- 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 FastString -- Overloaded label: #x - - | 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) - - -- For 'forall a . t' - ,(".", ITdot, NormalSyntax, 0 ) - - ,("-<", 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 -> P (PsLocated Token) - -special :: Token -> Action -special tok span _buf _len = return (L span tok) - -token, layout_token :: Token -> Action -token t span _buf _len = return (L span t) -layout_token t span _buf _len = pushLexState layout >> return (L span t) - -idtoken :: (StringBuffer -> Int -> Token) -> Action -idtoken f span buf len = return (L span $! (f buf len)) - -qdo_token :: (Maybe FastString -> Token) -> Action -qdo_token con span buf len = 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 - = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) - -skip_two_varid :: (FastString -> Token) -> Action -skip_two_varid f span buf len - = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2))) - -strtoken :: (String -> Token) -> Action -strtoken f span buf len = - return (L span $! (f $! lexemeToString buf len)) - -begin :: Int -> Action -begin code _span _str _len = do pushLexState code; lexToken - -pop :: Action -pop _span _buf _len = do _ <- popLexState - lexToken --- See Note [Nested comment line pragmas] -failLinePrag1 :: Action -failLinePrag1 span _buf _len = 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 = 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 - = 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 - else addFatalError $ - mkPlainErrorMsgEnvelope (mkSrcSpanPs span) PsErrMissingBlock - -pop_and :: Action -> Action -pop_and act span buf len = do _ <- popLexState - act span buf len - --- See Note [Whitespace-sensitive operator parsing] -followedByOpeningToken :: AlexAccPred ExtsBitmap -followedByOpeningToken _ _ _ (AI _ buf) - | atEnd buf = False - | otherwise = - case nextChar buf of - ('{', buf') -> nextCharIsNot buf' (== '-') - ('(', _) -> True - ('[', _) -> True - ('\"', _) -> True - ('\'', _) -> True - ('_', _) -> True - ('⟦', _) -> True - ('⦇', _) -> True - (c, _) -> isAlphaNum c - --- See Note [Whitespace-sensitive operator parsing] -precededByClosingToken :: AlexAccPred ExtsBitmap -precededByClosingToken _ (AI _ buf) _ _ = - case prevChar buf '\n' of - '}' -> decodePrevNChars 1 buf /= "-" - ')' -> True - ']' -> True - '\"' -> True - '\'' -> True - '_' -> True - '⟧' -> True - '⦈' -> True - c -> isAlphaNum c - -{-# 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 = {-# 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 = do - b <- getBit RawTokenStreamBit - if b then do - lt <- getLastLocComment - strtoken (\s -> ITlineComment s lt) span buf len - else lexToken - - -{- - nested comments require traversing by hand, they can't be parsed - using regular expressions. --} -nested_comment :: Action -nested_comment span buf len = {-# 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 = {-# SCC "nested_doc_comment" #-} withLexedDocType worker - where - worker input docType _checkNextLine = nested_comment_logic endComment "" input 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 = 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 = do - usePosPrags <- getBit UsePosPragsBit - if usePosPrags - then begin line_prag2 span buf len - 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 = do - usePosPrags <- getBit UsePosPragsBit - let !src = lexemeToString buf len - if usePosPrags - then begin column_prag span buf len - else let !src = lexemeToString buf len - in return (L span (ITcolumn_prag (SourceText src))) - -endPrag :: Action -endPrag span _buf _len = 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 = do - ctx <- getContext - setContext (NoLayout:ctx) - return (L span ITocurly) -close_brace span _str _len = 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 = - 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_prefix :: Action -varsym_prefix = 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 { addPsMessage - (mkSrcSpanPs span) - (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Prefix) - ; return (ITvarsym s) } - --- See Note [Whitespace-sensitive operator parsing] -varsym_suffix :: Action -varsym_suffix = sym $ \span _ s -> - if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT) - | s == fsLit "." -> return ITdot - | otherwise -> - do { addPsMessage - (mkSrcSpanPs span) - (PsWarnOperatorWhitespace s OperatorWhitespaceOccurrence_Suffix) - ; return (ITvarsym s) } - --- See Note [Whitespace-sensitive operator parsing] -varsym_tight_infix :: Action -varsym_tight_infix = sym $ \span exts s -> - if | s == fsLit "@" -> return ITat - | s == fsLit ".", OverloadedRecordDotBit `xtest` exts -> return (ITproj False) - | s == fsLit "." -> return ITdot - | otherwise -> - do { addPsMessage - (mkSrcSpanPs span) - (PsWarnOperatorWhitespace s (OperatorWhitespaceOccurrence_TightInfix)) - ; return (ITvarsym s) } - --- See Note [Whitespace-sensitive operator parsing] -varsym_loose_infix :: Action -varsym_loose_infix = sym $ \_ _ s -> - if | s == fsLit "." - -> return ITdot - | otherwise - -> return $ ITvarsym s - -consym :: Action -consym = sym (\_span _exts s -> return $ ITconsym s) - -sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action -sym con span buf len = - case lookupUFM reservedSymsFM fs of - Just (keyword, NormalSyntax, 0) -> do - exts <- getExts - if fs == fsLit "." && - exts .&. (xbit OverloadedRecordDotBit) /= 0 && - xtest OverloadedRecordDotBit exts - then L span <$!> con span exts fs -- Process by varsym_*. - else 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 - = 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 = do - tok <- lex_string "" - (AI end bufEnd) <- getInput - let - tok' = case tok of - ITprimstring _ bs -> ITprimstring (SourceText src) bs - ITstring _ s -> ITstring (SourceText src) s - _ -> panic "lex_string_tok" - src = lexemeToString buf (cur bufEnd - cur buf) - return (L (mkPsSpan (psSpanStart span) end) tok') - -lex_string :: String -> P Token -lex_string s = do - i <- getInput - case alexGetChar' i of - Nothing -> lit_error i - - Just ('"',i) -> do - setInput i - let s' = reverse s - 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 (ITprimstring (SourceText s') (unsafeMkByteString s')) - _other -> - return (ITstring (SourceText s') (mkFastString s')) - else - return (ITstring (SourceText s') (mkFastString s')) - - Just ('\\',i) - | Just ('&',i) <- next -> do - setInput i; lex_string s - | Just (c,i) <- next, c <= '\x7f' && is_space c -> do - -- is_space only works for <= '\x7f' (#3751, #5425) - setInput i; lex_stringgap s - where next = alexGetChar' i - - Just (c, i1) -> do - case c of - '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s) - c | isAny c -> do setInput i1; lex_string (c:s) - _other -> lit_error i - -lex_stringgap :: String -> P Token -lex_stringgap s = do - i <- getInput - c <- getCharOrFail i - case c of - '\\' -> lex_string s - c | c <= '\x7f' && is_space c -> lex_stringgap s - -- 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 = 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 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 - _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 _)) -> do - setInput i - 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 <- 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 '\'' - '^' -> 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 = 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 = 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)) - --- ----------------------------------------------------------------------------- --- Warnings - -warnTab :: Action -warnTab srcspan _buf _len = do - addTabWarning (psRealSpan srcspan) - lexToken - -warnThen :: PsMessage -> Action -> Action -warnThen warning action srcspan buf len = do - addPsMessage (RealSrcSpan (psRealSpan srcspan) Strict.Nothing) warning - action srcspan buf len - --- ----------------------------------------------------------------------------- --- 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 whan 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 - 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 = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of - Just found -> found span buf len - 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)) - - - -{- -%************************************************************************ -%* * - 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),AddEpAnn AnnCloseP (EpaSpan lc)) - 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) - -allocatePriorComments - :: RealSrcSpan - -> [LEpaComment] - -> Strict.Maybe [LEpaComment] - -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment]) -allocatePriorComments ss comment_q mheader_comments = - let - cmp (L l _) = anchor l <= ss - (before,after) = partition cmp comment_q - newAnns = before - comment_q'= after - in - case mheader_comments of - Strict.Nothing -> (Strict.Just (reverse newAnns), comment_q', []) - 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_10 = begin line_prag1 -alex_action_11 = begin line_prag1 -alex_action_15 = do_bol -alex_action_16 = hopefully_open_brace -alex_action_18 = begin line_prag1 -alex_action_19 = new_layout_context True dontGenerateSemic ITvbar -alex_action_20 = pop -alex_action_21 = new_layout_context True generateSemic ITvocurly -alex_action_22 = new_layout_context False generateSemic ITvocurly -alex_action_23 = do_layout_left -alex_action_24 = begin bol -alex_action_25 = dispatch_pragmas linePrags -alex_action_26 = setLineAndFile line_prag1a -alex_action_27 = failLinePrag1 -alex_action_28 = popLinePrag1 -alex_action_29 = setLineAndFile line_prag2a -alex_action_30 = pop -alex_action_31 = setColumn -alex_action_32 = dispatch_pragmas twoWordPrags -alex_action_33 = dispatch_pragmas oneWordPrags -alex_action_34 = dispatch_pragmas ignoredPrags -alex_action_35 = endPrag -alex_action_36 = dispatch_pragmas fileHeaderPrags -alex_action_37 = nested_comment -alex_action_38 = warnThen PsWarnUnrecognisedPragma - (nested_comment ) -alex_action_39 = multiline_doc_comment -alex_action_40 = nested_doc_comment -alex_action_41 = token (ITopenExpQuote NoE NormalSyntax) -alex_action_42 = token (ITopenTExpQuote NoE) -alex_action_43 = token (ITcloseQuote NormalSyntax) -alex_action_44 = token ITcloseTExpQuote -alex_action_45 = token (ITopenExpQuote HasE NormalSyntax) -alex_action_46 = token (ITopenTExpQuote HasE) -alex_action_47 = token ITopenPatQuote -alex_action_48 = layout_token ITopenDecQuote -alex_action_49 = token ITopenTypQuote -alex_action_50 = lex_quasiquote_tok -alex_action_51 = lex_qquasiquote_tok -alex_action_52 = token (ITopenExpQuote NoE UnicodeSyntax) -alex_action_53 = token (ITcloseQuote UnicodeSyntax) -alex_action_54 = special (IToparenbar NormalSyntax) -alex_action_55 = special (ITcparenbar NormalSyntax) -alex_action_56 = special (IToparenbar UnicodeSyntax) -alex_action_57 = special (ITcparenbar UnicodeSyntax) -alex_action_58 = skip_one_varid ITdupipvarid -alex_action_59 = skip_one_varid ITlabelvarid -alex_action_60 = token IToubxparen -alex_action_61 = token ITcubxparen -alex_action_62 = special IToparen -alex_action_63 = special ITcparen -alex_action_64 = special ITobrack -alex_action_65 = special ITcbrack -alex_action_66 = special ITcomma -alex_action_67 = special ITsemi -alex_action_68 = special ITbackquote -alex_action_69 = open_brace -alex_action_70 = close_brace -alex_action_71 = qdo_token ITdo -alex_action_72 = qdo_token ITmdo -alex_action_73 = idtoken qvarid -alex_action_74 = idtoken qconid -alex_action_75 = varid -alex_action_76 = idtoken conid -alex_action_77 = idtoken qvarid -alex_action_78 = idtoken qconid -alex_action_79 = varid -alex_action_80 = idtoken conid -alex_action_81 = varsym_tight_infix -alex_action_82 = varsym_prefix -alex_action_83 = varsym_suffix -alex_action_84 = varsym_loose_infix -alex_action_85 = idtoken qvarsym -alex_action_86 = idtoken qconsym -alex_action_87 = consym +{-# LINE 43 "_build/source-dist/ghc-9.6.1-src/ghc-9.6.1/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.1-src/ghc-9.6.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.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 docType _checkNextLine = nested_comment_logic endComment "" input 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 diff --git a/GHC/Parser/PostProcess.hs b/GHC/Parser/PostProcess.hs --- a/GHC/Parser/PostProcess.hs +++ b/GHC/Parser/PostProcess.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -9,8 +10,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- -- (c) The University of Glasgow 2002-2006 -- @@ -39,6 +38,7 @@ fromSpecTyVarBndr, fromSpecTyVarBndrs, annBinds, fixValbindsAnn, + stmtsAnchor, stmtsLoc, cvBindGroup, cvBindsAndSigs, @@ -94,8 +94,8 @@ warnStarIsType, warnPrepositiveQualifiedModule, failOpFewArgs, - failOpNotEnabledImportQualifiedPost, - failOpImportQualifiedTwice, + failNotEnabledImportQualifiedPost, + failImportQualifiedTwice, SumOrTuple (..), @@ -124,7 +124,6 @@ import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) import GHC.Types.Name.Reader import GHC.Types.Name -import GHC.Unit.Module (ModuleName) import GHC.Types.Basic import GHC.Types.Error import GHC.Types.Fixity @@ -136,10 +135,11 @@ import GHC.Parser.Errors.Ppr () import GHC.Utils.Lexeme ( okConOcc ) import GHC.Types.TyThing -import GHC.Core.Type ( unrestrictedFunTyCon, Specificity(..) ) +import GHC.Core.Type ( Specificity(..) ) import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey, - listTyConName, listTyConKey ) + listTyConName, listTyConKey, + unrestrictedFunTyCon ) import GHC.Types.ForeignCall import GHC.Types.SrcLoc import GHC.Types.Unique ( hasKey ) @@ -157,6 +157,8 @@ 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 @@ -190,7 +192,7 @@ -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a,[LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) - -> LayoutInfo + -> LayoutInfo GhcPs -> [AddEpAnn] -> P (LTyClDecl GhcPs) @@ -201,7 +203,8 @@ ; 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, layoutInfo) + ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey) + , tcdLayout = layoutInfo , tcdCtxt = mcxt , tcdLName = cls, tcdTyVars = tyvars , tcdFixity = fixity @@ -212,6 +215,7 @@ , tcdDocs = docs })) } mkTyData :: SrcSpan + -> Bool -> NewOrData -> Maybe (LocatedP CType) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) @@ -220,36 +224,35 @@ -> Located (HsDeriving GhcPs) -> [AddEpAnn] -> P (LTyClDecl GhcPs) -mkTyData loc' new_or_data cType (L _ (mcxt, tycl_hdr)) +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 - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; 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 :: NewOrData - -> Maybe (LocatedP CType) +mkDataDefn :: Maybe (LocatedP CType) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) - -> [LConDecl GhcPs] + -> DataDefnCons (LConDecl GhcPs) -> HsDeriving GhcPs -> P (HsDataDefn GhcPs) -mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv +mkDataDefn cType mcxt ksig data_cons maybe_deriv = do { checkDatatypeContext mcxt ; return (HsDataDefn { dd_ext = noExtField - , dd_ND = new_or_data, dd_cType = cType + , 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 @@ -324,7 +327,8 @@ = 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 - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; 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 @@ -398,19 +402,19 @@ -- 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) - | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr = do + | HsUntypedSplice _ splice@(HsUntypedSpliceExpr {}) <- expr = do cs <- getCommentsFor (locA loc) - return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) + return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice) - | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr = do + | HsUntypedSplice _ splice@(HsQuasiQuote {}) <- expr = do cs <- getCommentsFor (locA loc) - return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice) + 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 (mkUntypedSplice noAnn BareSplice lexpr)) - ImplicitSplice) + (L loc (HsUntypedSpliceExpr noAnn lexpr)) + BareSplice) mkRoleAnnotDecl :: SrcSpan -> LocatedN RdrName -- type being annotated @@ -467,13 +471,13 @@ 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 +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 +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" @@ -494,6 +498,18 @@ 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. @@ -674,7 +690,7 @@ fromDecl (L loc decl@(ValD _ (PatBind _ -- AZ: where should these anns come from? pat@(L _ (ConPat noAnn ln@(L _ name) details)) - rhs _))) = + rhs))) = do { unless (name == patsyn_name) $ wrongNameBindingErr (locA loc) decl ; match <- case details of @@ -737,11 +753,11 @@ -- records whether this is a prefix or record GADT constructor. See -- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. mkGadtDecl :: SrcSpan - -> [LocatedN RdrName] + -> NonEmpty (LocatedN RdrName) + -> LHsUniToken "::" "∷" GhcPs -> LHsSigType GhcPs - -> [AddEpAnn] -> P (LConDecl GhcPs) -mkGadtDecl loc names ty annsIn = do +mkGadtDecl loc names dcol ty = do cs <- getCommentsFor loc let l = noAnnSrcSpan loc @@ -761,11 +777,12 @@ let (anns, cs, arg_types, res_type) = splitHsFunType body_ty return (PrefixConGADT arg_types, res_type, anns, cs) - let an = EpAnn (spanAsAnchor loc) (annsIn ++ annsa) (cs Semi.<> csa) + 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 @@ -947,8 +964,7 @@ checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P () checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) where check (L loc (Unqual occ)) = - -- TODO: don't use string here, OccName has a Unique/FastString - when ((occNameString occ ==) `any` ["forall","family","role"]) + when (occNameFS occ `elem` [fsLit "forall",fsLit "family",fsLit "role"]) (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrParseErrorOnInput occ)) check _ = panic "checkRuleTyVarBndrNames" @@ -991,7 +1007,7 @@ -- workaround to define '*' despite StarIsType go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix = do { addPsMessage (locA l) PsWarnStarBinder - ; let name = mkOccName tcClsName (starSym isUni) + ; let name = mkOccNameFS tcClsName (starSym isUni) ; let a' = newAnns l an ; return (L a' (Unqual name), acc, fix , (reverse ops') ++ cps') } @@ -1023,13 +1039,13 @@ 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 (EpaSpan $ realSrcSpan l) c []) cs) + 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 (EpaSpan $ realSrcSpan l) c ta) (csp Semi.<> cs)) + 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 @@ -1116,13 +1132,13 @@ -- 'ImportQualifiedPost' is not in effect. whenJust mPost $ \post -> when (not importQualifiedPostEnabled) $ - failOpNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) + failNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) -- Error if 'qualified' occurs in both pre and postpositive -- positions. whenJust mPost $ \post -> when (isJust mPre) $ - failOpImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) + failImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing) -- Warn if 'qualified' found in prepositive position and -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. @@ -1144,7 +1160,7 @@ checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(L l _) = checkPat l e [] [] -checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs] +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 @@ -1157,8 +1173,8 @@ | (not (null args) && patIsRec c) = do ctx <- askParseContext patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx -checkPat loc (L _ (PatBuilderAppType f t)) tyargs args = - checkPat loc f (t : tyargs) args +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) @@ -1293,8 +1309,7 @@ makeFunBind fn ms = FunBind { fun_ext = noExtField, fun_id = fn, - fun_matches = mkMatchGroup FromSource ms, - fun_tick = [] } + fun_matches = mkMatchGroup FromSource ms } -- See Note [FunBind vs PatBind] checkPatBind :: SrcSpan @@ -1316,7 +1331,7 @@ checkPatBind loc annsIn lhs (L _ grhss) = do cs <- getCommentsFor loc - return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss ([],[])) + return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss) checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName) checkValSigLhs (L _ (HsVar _ lrdr@(L _ v))) @@ -1516,7 +1531,7 @@ -- | 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 -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b) + mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> LHsToken "@" GhcPs -> LHsType GhcPs -> PV (LocatedA b) -- | Disambiguate "if ... then ... else ..." mkHsIfPV :: SrcSpan -> LHsExpr GhcPs @@ -1549,7 +1564,7 @@ -- | Disambiguate "[a,b,c]" (list syntax) mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b) -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices) - mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b) + mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (Located b) -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates) mkHsRecordPV :: Bool -> -- Is OverloadedRecordUpdate in effect? @@ -1569,7 +1584,7 @@ :: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) -- | Disambiguate "a@b" (as-pattern) mkHsAsPatPV - :: SrcSpan -> LocatedN RdrName -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b) + :: 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) @@ -1675,8 +1690,8 @@ mkHsWildCardPV l = cmdFail l (text "_") mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig) mkHsExplicitListPV l xs _ = cmdFail l $ - brackets (fsep (punctuate comma (map ppr xs))) - mkHsSplicePV (L l sp) = cmdFail l (ppr sp) + 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) @@ -1689,7 +1704,7 @@ in pp_op <> ppr c mkHsViewPatPV l a b _ = cmdFail l $ ppr a <+> text "->" <+> ppr b - mkHsAsPatPV l v c _ = cmdFail l $ + mkHsAsPatPV l v _ c = cmdFail l $ pprPrefixOcc (unLoc v) <> text "@" <> ppr c mkHsLazyPatPV l c _ = cmdFail l $ text "~" <> ppr c @@ -1743,9 +1758,9 @@ checkExpBlockArguments e1 checkExpBlockArguments e2 return $ L l (HsApp (comment (realSrcSpan $ locA l) cs) e1 e2) - mkHsAppTypePV l e la t = do + mkHsAppTypePV l e at t = do checkExpBlockArguments e - return $ L l (HsAppType la e (mkHsWildCardBndrs t)) + 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 @@ -1772,7 +1787,7 @@ return $ L (noAnnSrcSpan l) (ExplicitList (EpAnn (spanAsAnchor l) anns cs) xs) mkHsSplicePV sp@(L l _) = do cs <- getCommentsFor l - return $ mapLoc (HsSpliceE (EpAnn (spanAsAnchor l) NoEpAnns cs)) sp + 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) @@ -1785,7 +1800,7 @@ 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) + 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)) @@ -1800,7 +1815,7 @@ rejectPragmaPV _ = return () hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs -hsHoleExpr anns = HsUnboundVar anns (mkVarOcc "_") +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 @@ -1825,10 +1840,10 @@ type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs superFunArg m = m mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2) - mkHsAppTypePV l p la t = do + mkHsAppTypePV l p at t = do cs <- getCommentsFor (locA l) - let anns = EpAnn (spanAsAnchor (combineSrcSpans la (getLocA t))) (EpaSpan (realSrcSpan la)) cs - return $ L l (PatBuilderAppType p (mkHsPatSigType anns t)) + 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) @@ -1867,10 +1882,10 @@ p <- checkLPat b cs <- getCommentsFor l return $ L (noAnnSrcSpan l) (PatBuilderPat (ViewPat (EpAnn (spanAsAnchor l) anns cs) a p)) - mkHsAsPatPV l v e a = do + mkHsAsPatPV l v at e = do p <- checkLPat e cs <- getCommentsFor l - return $ L (noAnnSrcSpan l) (PatBuilderPat (AsPat (EpAnn (spanAsAnchor l) a cs) v p)) + 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 @@ -2497,10 +2512,10 @@ | isRdrDataCon c = do let (fs, ps) = partitionEithers fbinds - if not (null ps) - then addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head ps)) $ - PsErrOverloadedRecordDotInvalid - else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns) + 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 @@ -2530,15 +2545,13 @@ [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs' , isQual . rdrNameAmbiguousFieldOcc $ lbl ] - if not $ null qualifiedFields - then - addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head qualifiedFields)) $ + case qualifiedFields of + qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $ PsErrOverloadedRecordUpdateNoQualifiedFields - else -- This is a RecordDotSyntax update. - return RecordUpd { - rupd_ext = anns - , rupd_expr = exp - , rupd_flds = Right (toProjUpdates fbinds) } + _ -> 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 }) @@ -2549,7 +2562,7 @@ 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 f) + fl = DotFieldOcc noAnn (L loc (FieldLabelString f)) lf = locA loc in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns where @@ -2568,7 +2581,7 @@ 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 (length 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) @@ -2606,6 +2619,28 @@ , 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 @@ -2638,7 +2673,7 @@ PsErrMalformedEntityString Just importSpec -> return importSpec - isCWrapperImport (CImport _ _ _ CWrapper _) = True + isCWrapperImport (CImport _ _ _ _ CWrapper) = True isCWrapperImport _ = False -- currently, all the other import conventions only support a symbol name in @@ -2649,7 +2684,7 @@ then mkExtName (unLoc v) else entity funcTarget = CFunction (StaticTarget esrc entity' Nothing True) - importSpec = CImport cconv safety Nothing funcTarget (L loc esrc) + importSpec = CImport (L loc esrc) cconv safety Nothing funcTarget returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport { fd_i_ext = ann @@ -2665,7 +2700,7 @@ -- that one. parseCImport :: Located CCallConv -> Located Safety -> FastString -> String -> Located SourceText - -> Maybe ForeignImport + -> Maybe (ForeignImport (GhcPass p)) parseCImport cconv safety nm str sourceText = listToMaybe $ map fst $ filter (null.snd) $ readP_to_S parse str @@ -2692,7 +2727,7 @@ | id_char c -> pfail _ -> return () - mk h n = CImport cconv safety h n sourceText + mk h n = CImport sourceText cconv safety h n hdr_char c = not (isSpace c) -- header files are filenames, which can contain @@ -2727,8 +2762,7 @@ 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 lc (CExportStatic esrc entity' cconv)) - (L le esrc) } + , fd_fe = CExport (L le esrc) (L lc (CExportStatic esrc entity' cconv)) } where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity @@ -2740,7 +2774,7 @@ -- want z-encoding (e.g. names with z's in them shouldn't be doubled) -- mkExtName :: RdrName -> CLabelString -mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) +mkExtName rdrNm = occNameFS (rdrNameOcc rdrNm) -------------------------------------------------------------------------------- -- Help with module system imports/exports @@ -2774,7 +2808,7 @@ let withs = map unLoc xs pos = maybe NoIEWildcard IEWildcard (findIndex isImpExpQcWildcard withs) - ies :: [LocatedA (IEWrappedName RdrName)] + ies :: [LocatedA (IEWrappedName GhcPs)] ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName -> IEThingWith ann (L l newName) pos ies) @@ -2793,11 +2827,12 @@ ieNameVal (ImpExpQcType _ ln) = unLoc ln ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" - ieNameFromSpec (ImpExpQcName ln) = IEName ln - ieNameFromSpec (ImpExpQcType r ln) = IEType r ln + 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 (mapLoc ieNameFromSpec) + wrapped = map (fmap ieNameFromSpec) mkTypeImpExp :: LocatedN RdrName -- TcCls or Var name space -> P (LocatedN RdrName) @@ -2820,7 +2855,7 @@ mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec) mkImpExpSubSpec [] = return ([], ImpExpList []) mkImpExpSubSpec [L la ImpExpQcWildcard] = - return ([AddEpAnn AnnDotdot (EpaSpan $ la2r la)], ImpExpAll) + return ([AddEpAnn AnnDotdot (la2e la)], ImpExpAll) mkImpExpSubSpec xs = if (any (isImpExpQcWildcard . unLoc) xs) then return $ ([], ImpExpAllWith xs) @@ -2837,12 +2872,12 @@ warnPrepositiveQualifiedModule span = addPsMessage span PsWarnImportPreQualified -failOpNotEnabledImportQualifiedPost :: SrcSpan -> P () -failOpNotEnabledImportQualifiedPost loc = +failNotEnabledImportQualifiedPost :: SrcSpan -> P () +failNotEnabledImportQualifiedPost loc = addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified -failOpImportQualifiedTwice :: SrcSpan -> P () -failOpImportQualifiedTwice loc = +failImportQualifiedTwice :: SrcSpan -> P () +failImportQualifiedTwice loc = addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice warnStarIsType :: SrcSpan -> P () @@ -2873,6 +2908,7 @@ } 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 @@ -2894,9 +2930,7 @@ -- abParser :: forall x. DisambAB x => P (PV x) -- newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a } - -instance Functor PV where - fmap = liftM + deriving (Functor) instance Applicative PV where pure a = a `seq` PV (\_ acc -> PV_Ok acc a) @@ -2971,7 +3005,7 @@ {- Note [Parser-Validator Details] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A PV computation is parametrized by some 'ParseContext' for diagnostic messages, which can be set +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': @@ -3090,14 +3124,14 @@ mkTokenLocation :: SrcSpan -> TokenLocation mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc -mkTokenLocation (RealSrcSpan r _) = TokenLoc (EpaSpan r) +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)) (RealSrcSpan r2 _) = - (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2))) +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" @@ -3106,9 +3140,9 @@ ----------------------------------------------------------------------------- -- Token symbols -starSym :: Bool -> String -starSym True = "★" -starSym False = "*" +starSym :: Bool -> FastString +starSym True = fsLit "★" +starSym False = fsLit "*" ----------------------------------------- -- Bits and pieces for RecordDotSyntax. 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 @@ -48,7 +48,7 @@ -} module GHC.Parser.PostProcess.Haddock (addHaddockToModule) where -import GHC.Prelude hiding (mod) +import GHC.Prelude hiding (head, init, last, mod, tail) import GHC.Hs @@ -60,6 +60,8 @@ 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.Monad.Trans.State.Strict import Control.Monad.Trans.Reader @@ -178,7 +180,7 @@ -- to a parsed HsModule. -- -- Reports badly positioned comments when -Winvalid-haddock is enabled. -addHaddockToModule :: Located HsModule -> P (Located HsModule) +addHaddockToModule :: Located (HsModule GhcPs) -> P (Located (HsModule GhcPs)) addHaddockToModule lmod = do pState <- getPState let all_comments = toList (hdk_comments pState) @@ -239,7 +241,7 @@ -- item4 -- ) where -- -instance HasHaddock (Located HsModule) where +instance HasHaddock (Located (HsModule GhcPs)) where addHaddock (L l_mod mod) = do -- Step 1, get the module header documentation comment: -- @@ -287,13 +289,13 @@ -- data C = MkC -- ^ Comment on MkC -- -- ^ Comment on C -- - let layout_info = hsmodLayout mod + let layout_info = hsmodLayout (hsmodExt mod) hsmodDecls' <- addHaddockInterleaveItems layout_info (mkDocHsDecl layout_info) (hsmodDecls mod) pure $ L l_mod $ mod { hsmodExports = hsmodExports' , hsmodDecls = hsmodDecls' - , hsmodHaddockModHeader = join @Maybe headerDocs } + , hsmodExt = (hsmodExt mod) { hsmodHaddockModHeader = join @Maybe headerDocs } } lexHsDocString :: HsDocString -> HsDoc GhcPs lexHsDocString = lexHsDoc parseIdentifier @@ -338,7 +340,7 @@ The inputs to addHaddockInterleaveItems are: - * layout_info :: LayoutInfo + * layout_info :: LayoutInfo GhcPs In the example above, note that the indentation level inside the module is 2 spaces. It would be represented as layout_info = VirtualBraces 2. @@ -370,7 +372,7 @@ addHaddockInterleaveItems :: forall a. HasHaddock a - => LayoutInfo + => LayoutInfo GhcPs -> (PsLocated HdkComment -> Maybe a) -- Get a documentation item -> [a] -- Unprocessed (non-documentation) items -> HdkA [a] -- Documentation items & processed non-documentation items @@ -387,7 +389,7 @@ with_layout_info :: HdkA a -> HdkA a with_layout_info = case layout_info of NoLayoutInfo -> id - ExplicitBraces -> id + ExplicitBraces{} -> id VirtualBraces n -> let loc_range = mempty { loc_range_col = ColumnFrom (n+1) } in hoistHdkA (inLocRange loc_range) @@ -496,7 +498,7 @@ -- -- ^ Comment on the second method -- addHaddock (TyClD _ decl) - | ClassDecl { tcdCExt = (x, NoAnnSortKey, tcdLayout), + | ClassDecl { tcdCExt = (x, NoAnnSortKey), tcdLayout, tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs, tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl = do @@ -507,7 +509,7 @@ 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, NoAnnSortKey), tcdLayout , tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs , tcdSigs = tcdSigs' , tcdMeths = tcdMeths' @@ -584,7 +586,7 @@ -- = MkT1 Int Bool -- ^ Comment on MkT1 -- | MkT2 Char Int -- ^ Comment on MkT2 -- - dd_cons' <- addHaddock (dd_cons defn) + dd_cons' <- traverse addHaddock (dd_cons defn) -- Process the deriving clauses: -- @@ -696,9 +698,9 @@ addHaddock (L l_con_decl con_decl) = extendHdkA (locA l_con_decl) $ case con_decl of - ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do + 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 (head con_names)) + con_doc' <- discardHasInnerDocs $ getConDoc (getLocA (NE.head con_names)) con_g_args' <- case con_g_args of PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts @@ -708,7 +710,7 @@ pure $ RecConGADT (L l_rec flds') arr con_res_ty' <- addHaddock con_res_ty pure $ L l_con_decl $ - ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, + ConDeclGADT { con_g_ext, con_names, con_dcolon, con_bndrs, con_mb_cxt, con_doc = lexLHsDocString <$> con_doc', con_g_args = con_g_args', con_res_ty = con_res_ty' } @@ -872,13 +874,13 @@ doc <- selectDocString trailingDocs return $ L l' (con_fld { cd_fld_doc = fmap lexLHsDocString doc }) con_args' <- case con_args con_decl of - x@(PrefixCon _ []) -> x <$ reportExtraDocs trailingDocs - x@(RecCon (L _ [])) -> x <$ reportExtraDocs trailingDocs - PrefixCon _ ts -> PrefixCon noTypeArgs <$> mapLastM mk_doc_ty ts + 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 - RecCon (L l_rec flds) -> do - flds' <- mapLastM mk_doc_fld flds - return (RecCon (L l_rec flds')) return $ L l (con_decl{ con_args = con_args' }) else do con_doc' <- selectDoc (con_doc con_decl `mcons` (map lexLHsDocString trailingDocs)) @@ -1307,10 +1309,10 @@ * * ********************************************************************* -} -mkDocHsDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) -mkDocHsDecl layout_info a = mapLoc (DocD noExtField) <$> mkDocDecl layout_info a +mkDocHsDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) +mkDocHsDecl layout_info a = fmap (DocD noExtField) <$> mkDocDecl layout_info a -mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) +mkDocDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) mkDocDecl layout_info (L l_comment hdk_comment) | indent_mismatch = Nothing | otherwise = @@ -1344,7 +1346,7 @@ -- -- ^ indent mismatch indent_mismatch = case layout_info of NoLayoutInfo -> False - ExplicitBraces -> False + ExplicitBraces{} -> False VirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment) mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) @@ -1530,7 +1532,7 @@ -- Map a function over a list of located items. mapLL :: (a -> b) -> [GenLocated l a] -> [GenLocated l b] -mapLL f = map (mapLoc f) +mapLL f = map (fmap f) {- Note [Old solution: Haddock in the grammar] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1576,7 +1578,7 @@ We could use EPA (exactprint annotations) to fix this, but not without modification. For example, EpaLocation contains RealSrcSpan but not BufSpan. -Also, the fix would be more straghtforward after #19623. +Also, the fix would be more straightforward after #19623. For examples, see tests/haddock/should_compile_flag_haddock/T17544_kw.hs -} diff --git a/GHC/Parser/Types.hs b/GHC/Parser/Types.hs --- a/GHC/Parser/Types.hs +++ b/GHC/Parser/Types.hs @@ -55,7 +55,7 @@ = PatBuilderPat (Pat p) | PatBuilderPar (LHsToken "(" p) (LocatedA (PatBuilder p)) (LHsToken ")" p) | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) - | PatBuilderAppType (LocatedA (PatBuilder p)) (HsPatSigType GhcPs) + | PatBuilderAppType (LocatedA (PatBuilder p)) (LHsToken "@" p) (HsPatSigType GhcPs) | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName) (LocatedA (PatBuilder p)) (EpAnn [AddEpAnn]) | PatBuilderVar (LocatedN RdrName) @@ -65,7 +65,7 @@ ppr (PatBuilderPat p) = ppr p ppr (PatBuilderPar _ (L _ p) _) = parens (ppr p) ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2 - ppr (PatBuilderAppType (L _ p) t) = ppr p <+> text "@" <> ppr t + ppr (PatBuilderAppType (L _ p) _ t) = ppr p <+> text "@" <> ppr t ppr (PatBuilderOpApp (L _ p1) op (L _ p2) _) = ppr p1 <+> ppr op <+> ppr p2 ppr (PatBuilderVar v) = ppr v ppr (PatBuilderOverLit l) = ppr l diff --git a/GHC/Platform.hs b/GHC/Platform.hs --- a/GHC/Platform.hs +++ b/GHC/Platform.hs @@ -206,6 +206,7 @@ osElfTarget OSQNXNTO = False osElfTarget OSAIX = False osElfTarget OSHurd = True +osElfTarget OSWasi = 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 @@ -262,6 +263,7 @@ ArchPPC_64 _ -> True ArchS390X -> True ArchRISCV64 -> True + ArchLoongArch64 -> True ArchAArch64 -- Apple's AArch64 ABI requires that the caller sign-extend -- small integer arguments. See diff --git a/GHC/Platform/LoongArch64.hs b/GHC/Platform/LoongArch64.hs new file mode 100644 --- /dev/null +++ b/GHC/Platform/LoongArch64.hs @@ -0,0 +1,9 @@ +{-# 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/Regs.hs b/GHC/Platform/Regs.hs --- a/GHC/Platform/Regs.hs +++ b/GHC/Platform/Regs.hs @@ -15,6 +15,8 @@ import qualified GHC.Platform.X86 as X86 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.NoRegs as NoRegs -- | Returns 'True' if this global register is stored in a caller-saves @@ -31,6 +33,8 @@ ArchARM {} -> ARM.callerSaves ArchAArch64 -> AArch64.callerSaves ArchRISCV64 -> RISCV64.callerSaves + ArchWasm32 -> Wasm32.callerSaves + ArchLoongArch64 -> LoongArch64.callerSaves arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.callerSaves @@ -53,6 +57,8 @@ ArchARM {} -> ARM.activeStgRegs ArchAArch64 -> AArch64.activeStgRegs ArchRISCV64 -> RISCV64.activeStgRegs + ArchWasm32 -> Wasm32.activeStgRegs + ArchLoongArch64 -> LoongArch64.activeStgRegs arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.activeStgRegs @@ -70,6 +76,8 @@ ArchARM {} -> ARM.haveRegBase ArchAArch64 -> AArch64.haveRegBase ArchRISCV64 -> RISCV64.haveRegBase + ArchWasm32 -> Wasm32.haveRegBase + ArchLoongArch64 -> LoongArch64.haveRegBase arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.haveRegBase @@ -87,6 +95,8 @@ ArchARM {} -> ARM.globalRegMaybe ArchAArch64 -> AArch64.globalRegMaybe ArchRISCV64 -> RISCV64.globalRegMaybe + ArchWasm32 -> Wasm32.globalRegMaybe + ArchLoongArch64 -> LoongArch64.globalRegMaybe arch | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] -> PPC.globalRegMaybe @@ -104,6 +114,8 @@ ArchARM {} -> ARM.freeReg ArchAArch64 -> AArch64.freeReg ArchRISCV64 -> RISCV64.freeReg + ArchWasm32 -> Wasm32.freeReg + ArchLoongArch64 -> LoongArch64.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 new file mode 100644 --- /dev/null +++ b/GHC/Platform/Wasm32.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE CPP #-} + +module GHC.Platform.Wasm32 where + +import GHC.Prelude + +-- TODO +#define MACHREGS_NO_REGS 1 +-- #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 @@ -61,7 +61,7 @@ -- | A way -- --- Don't change the constructor order as it us used by `waysTag` to create a +-- Don't change the constructor order as it is used by `waysTag` to create a -- unique tag (e.g. thr_debug_p) which is expected by other tools (e.g. Cabal). data Way = WayCustom String -- ^ for GHC API clients building custom variants diff --git a/GHC/Plugins.hs b/GHC/Plugins.hs --- a/GHC/Plugins.hs +++ b/GHC/Plugins.hs @@ -17,6 +17,8 @@ , module GHC.Types.Id.Info , module GHC.Types.PkgQual , module GHC.Core.Opt.Monad + , module GHC.Core.Opt.Pipeline.Types + , module GHC.Core.Opt.Stats , module GHC.Core , module GHC.Types.Literal , module GHC.Core.DataCon @@ -83,6 +85,8 @@ -- Core import GHC.Core.Opt.Monad +import GHC.Core.Opt.Pipeline.Types +import GHC.Core.Opt.Stats import GHC.Core import GHC.Types.Literal import GHC.Core.DataCon @@ -193,7 +197,7 @@ -- For now, the easiest and recommended way to ensure a consistent -- 'NameCache' is used it to retrieve the preexisting one from an active -- 'HscEnv'. A single 'HscEnv' is created per GHC "session", and this --- ensures everything in that sesssion will getthe same name cache. +-- 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) diff --git a/GHC/Prelude.hs b/GHC/Prelude.hs --- a/GHC/Prelude.hs +++ b/GHC/Prelude.hs @@ -13,9 +13,8 @@ -- * Explicitly imports GHC.Prelude module GHC.Prelude - (module X - ,module Bits - ,shiftL, shiftR + (module GHC.Prelude + ,module GHC.Utils.Trace ) where @@ -47,54 +46,7 @@ extensions. -} -import Prelude as X hiding ((<>)) -import Data.Foldable as X (foldl') - -#if MIN_VERSION_base(4,16,0) -import GHC.Bits as Bits hiding (shiftL, shiftR) -# 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 -other depending on the DEBUG setting. - -Why do we then continue on to re-export the rest of Data.Bits? -If we would not what is likely to happen is: -* Someone imports Data.Bits, uses xor. Things are fine. -* They add a shift and get an ambigious definition error. -* The are puzzled for a bit. -* They either: - + Remove the import of Data.Bits and get an error because xor is not in scope. - + Add the hiding clause to the Data.Bits import for the shifts. - -Either is quite annoying. Simply re-exporting all of Data.Bits avoids this -making for a smoother developer experience. At the cost of having a few more -names in scope at all time. But that seems like a fair tradeoff. - -See also #19618 --} +import GHC.Prelude.Basic as GHC.Prelude --- We always want the Data.Bits method to show up for rules etc. -{-# INLINE shiftL #-} -{-# INLINE shiftR #-} -shiftL, shiftR :: Bits.Bits a => a -> Int -> a -#if defined(DEBUG) -shiftL = Bits.shiftL -shiftR = Bits.shiftR -#else -shiftL = Bits.unsafeShiftL -shiftR = Bits.unsafeShiftR -#endif +-- import {-# SOURCE #-} GHC.Utils.Trace +import GHC.Utils.Trace hiding ( trace ) diff --git a/GHC/Prelude/Basic.hs b/GHC/Prelude/Basic.hs new file mode 100644 --- /dev/null +++ b/GHC/Prelude/Basic.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -O2 #-} -- See Note [-O2 Prelude] + +-- | Custom minimal GHC "Prelude" +-- +-- This module serves as a replacement for the "Prelude" module +-- and abstracts over differences between the bootstrapping +-- GHC version, and may also provide a common default vocabulary. + +-- Every module in GHC +-- * Is compiled with -XNoImplicitPrelude +-- * Explicitly imports GHC.BasicPrelude 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 + ) where + + +{- Note [-O2 Prelude] +~~~~~~~~~~~~~~~~~~~~~ +There is some code in GHC that is *always* compiled with -O[2] because +of it's impact on compile time performance. Some of this code might depend +on the definitions like shiftL being defined here being performant. + +So we always compile this module with -O2. It's (currently) tiny so I +have little reason to suspect this impacts overall GHC compile times +negatively. + +-} +-- We export the 'Semigroup' class but w/o the (<>) operator to avoid +-- clashing with the (Outputable.<>) operator which is heavily used +-- through GHC's code-base. + +{- +Note [Why do we import Prelude here?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The files ghc-boot-th.cabal, ghc-boot.cabal, ghci.cabal and +ghc-heap.cabal contain the directive default-extensions: +NoImplicitPrelude. There are two motivations for this: + - Consistency with the compiler directory, which enables + NoImplicitPrelude; + - Allows loading the above dependent packages with ghc-in-ghci, + giving a smoother development experience when adding new + extensions. +-} + +import Prelude as X hiding ((<>), Applicative(..)) +import Control.Applicative (Applicative(..)) +import Data.Foldable as X (foldl') + +#if MIN_VERSION_base(4,16,0) +import GHC.Bits as Bits hiding (shiftL, shiftR) +# 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 +other depending on the DEBUG setting. + +Why do we then continue on to re-export the rest of Data.Bits? +If we would not what is likely to happen is: +* Someone imports Data.Bits, uses xor. Things are fine. +* They add a shift and get an ambiguous definition error. +* The are puzzled for a bit. +* They either: + + Remove the import of Data.Bits and get an error because xor is not in scope. + + Add the hiding clause to the Data.Bits import for the shifts. + +Either is quite annoying. Simply re-exporting all of Data.Bits avoids this +making for a smoother developer experience. At the cost of having a few more +names in scope at all time. But that seems like a fair tradeoff. + +See also #19618 +-} + +-- We always want the Data.Bits method to show up for rules etc. +{-# INLINE shiftL #-} +{-# INLINE shiftR #-} +shiftL, shiftR :: Bits.Bits a => a -> Int -> a +#if defined(DEBUG) +shiftL = Bits.shiftL +shiftR = Bits.shiftR +#else +shiftL = Bits.unsafeShiftL +shiftR = Bits.unsafeShiftR +#endif diff --git a/GHC/Rename/Bind.hs b/GHC/Rename/Bind.hs --- a/GHC/Rename/Bind.hs +++ b/GHC/Rename/Bind.hs @@ -3,7 +3,6 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -70,6 +69,8 @@ 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 ) @@ -491,18 +492,10 @@ bind' = bind { pat_rhs = grhss' , pat_ext = fvs' } - ok_nobind_pat - = -- See Note [Pattern bindings that bind no variables] - case unLoc pat of - WildPat {} -> True - BangPat {} -> True -- #9127, #13646 - SplicePat {} -> True - _ -> False - -- Warn if the pattern binds no variables -- See Note [Pattern bindings that bind no variables] ; whenWOptM Opt_WarnUnusedPatternBinds $ - when (null bndrs && not ok_nobind_pat) $ + when (null bndrs && not (isOkNoBindPattern pat)) $ addTcRnDiagnostic (TcRnUnusedPatternBinds bind') ; fvs' `seq` -- See Note [Free-variable space leak] @@ -538,29 +531,66 @@ rnBind _ b = pprPanic "rnBind" (ppr b) + -- See Note [Pattern bindings that bind no variables] +isOkNoBindPattern :: LPat GhcRn -> Bool +isOkNoBindPattern (L _ pat) = + case pat of + WildPat{} -> True -- Exception (1) + BangPat {} -> True -- Exception (2) #9127, #13646 + p -> patternContainsSplice p -- Exception (3) + + where + lpatternContainsSplice :: LPat GhcRn -> Bool + lpatternContainsSplice (L _ p) = patternContainsSplice p + patternContainsSplice :: Pat GhcRn -> Bool + patternContainsSplice p = + case p of + -- A top-level splice has been evaluated by this point, so we know the pattern it is evaluated to + SplicePat (HsUntypedSpliceTop _ p) _ -> patternContainsSplice p + -- A nested splice isn't evaluated so we can't guess what it will expand to + SplicePat (HsUntypedSpliceNested {}) _ -> True + -- The base cases + VarPat {} -> False + WildPat {} -> False + LitPat {} -> False + NPat {} -> False + NPlusKPat {} -> False + -- Recursive cases + BangPat _ lp -> lpatternContainsSplice lp + LazyPat _ lp -> lpatternContainsSplice lp + AsPat _ _ _ lp -> lpatternContainsSplice lp + ParPat _ _ lp _ -> lpatternContainsSplice lp + ViewPat _ _ lp -> lpatternContainsSplice lp + SigPat _ lp _ -> lpatternContainsSplice lp + ListPat _ lps -> any lpatternContainsSplice lps + TuplePat _ lps _ -> any lpatternContainsSplice lps + SumPat _ lp _ _ -> lpatternContainsSplice lp + ConPat _ _ cpd -> any lpatternContainsSplice (hsConPatArgs cpd) + XPat (HsPatExpanded _orig new) -> patternContainsSplice new + {- Note [Pattern bindings that bind no variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Generally, we want to warn about pattern bindings like Just _ = e because they don't do anything! But we have three exceptions: -* A wildcard pattern +(1) A wildcard pattern _ = rhs which (a) is not that different from _v = rhs (b) is sometimes used to give a type sig for, or an occurrence of, a variable on the RHS -* A strict pattern binding; that is, one with an outermost bang +(2) A strict pattern binding; that is, one with an outermost bang !Just _ = e This can fail, so unlike the lazy variant, it is not a no-op. Moreover, #13646 argues that even for single constructor types, you might want to write the constructor. See also #9127. -* A splice pattern +(3) A splice pattern $(th-lhs) = rhs It is impossible to determine whether or not th-lhs really - binds any variable. We should disable the warning for any pattern - which contain splices, but that is a more expensive check. + binds any variable. You have to recurse all the way into the pattern to check + it doesn't contain any splices like this. See #22057. Note [Free-variable space leak] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -666,7 +696,7 @@ dupFixityDecl :: SrcSpan -> RdrName -> TcRnMessage dupFixityDecl loc rdr_name - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), text "also at " <+> ppr loc] @@ -710,7 +740,7 @@ RecCon vars -> do { checkDupRdrNames (map (foLabel . recordPatSynField) vars) ; fls <- lookupConstructorFields name - ; let fld_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ] + ; let fld_env = mkFsEnv [ (field_label $ flLabel fl, fl) | fl <- fls ] ; let rnRecordPatSynField (RecordPatSynField { recordPatSynField = visible , recordPatSynPatVar = hidden }) @@ -757,7 +787,7 @@ patternSynonymErr :: TcRnMessage patternSynonymErr - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal pattern synonym declaration") 2 (text "Use -XPatternSynonyms to enable this extension") @@ -765,7 +795,7 @@ Note [Renaming pattern synonym variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We rename pattern synonym declaractions backwards to normal to reuse +We rename pattern synonym declarations backwards to normal to reuse the logic already implemented for renaming patterns. We first rename the RHS of a declaration which brings into @@ -950,7 +980,7 @@ -- 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) $ TcRnUnknownMessage $ mkPlainError noHints $ + = do { addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ what <+> text "not allowed in" <+> decl_sort , nest 2 (ppr bind) ] ; return rest } @@ -1007,9 +1037,6 @@ -- Doesn't seem worth much trouble to sort this. renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) -renameSig _ (IdSig _ x) - = return (IdSig noExtField x, emptyFVs) -- Actually this never occurs - renameSig ctxt sig@(TypeSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs ; let doc = TypeSigCtx (ppr_sig_bndrs vs) @@ -1029,7 +1056,7 @@ ty_ctxt = GenericCtx (text "a class method signature for" <+> quotes (ppr v1)) -renameSig _ (SpecInstSig _ src ty) +renameSig _ (SpecInstSig (_, src) ty) = do { checkInferredVars doc inf_msg ty ; (new_ty, fvs) <- rnHsSigType doc TypeLevel ty -- Check if there are any nested `forall`s or contexts, which are @@ -1038,7 +1065,7 @@ -- GHC.Hs.Type). ; addNoNestedForallsContextsErr doc (text "SPECIALISE instance type") (getLHsInstDeclHead new_ty) - ; return (SpecInstSig noAnn src new_ty,fvs) } + ; return (SpecInstSig (noAnn, src) new_ty,fvs) } where doc = SpecInstSigCtx inf_msg = Just (text "Inferred type variables are not allowed") @@ -1068,9 +1095,9 @@ = do { new_fsig <- rnSrcFixityDecl ctxt fsig ; return (FixSig noAnn new_fsig, emptyFVs) } -renameSig ctxt sig@(MinimalSig _ s (L l bf)) +renameSig ctxt sig@(MinimalSig (_, s) (L l bf)) = do new_bf <- traverse (lookupSigOccRnN ctxt sig) bf - return (MinimalSig noAnn s (L l new_bf), emptyFVs) + return (MinimalSig (noAnn, s) (L l new_bf), emptyFVs) renameSig ctxt sig@(PatSynSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs @@ -1080,13 +1107,13 @@ ty_ctxt = GenericCtx (text "a pattern synonym signature for" <+> ppr_sig_bndrs vs) -renameSig ctxt sig@(SCCFunSig _ st v s) +renameSig ctxt sig@(SCCFunSig (_, st) v s) = do { new_v <- lookupSigOccRnN ctxt sig v - ; return (SCCFunSig noAnn st new_v s, emptyFVs) } + ; 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) +renameSig _ctxt sig@(CompleteMatchSig (_, s) (L l bf) mty) = do new_bf <- traverse lookupLocatedOccRn bf new_mty <- traverse lookupLocatedOccRn mty @@ -1095,10 +1122,10 @@ -- Why 'any'? See Note [Orphan COMPLETE pragmas] addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError - return (CompleteMatchSig noAnn s (L l new_bf) new_mty, emptyFVs) + return (CompleteMatchSig (noAnn, s) (L l new_bf) new_mty, emptyFVs) where orphanError :: TcRnMessage - orphanError = TcRnUnknownMessage $ mkPlainError noHints $ + 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." @@ -1145,10 +1172,6 @@ (FixSig {}, InstDeclCtxt {}) -> False (FixSig {}, _) -> True - (IdSig {}, TopSigCtxt {}) -> True - (IdSig {}, InstDeclCtxt {}) -> True - (IdSig {}, _) -> False - (InlineSig {}, HsBootCtxt {}) -> False (InlineSig {}, _) -> True @@ -1169,6 +1192,11 @@ (CompleteMatchSig {}, TopSigCtxt {} ) -> True (CompleteMatchSig {}, _) -> False + (XSig {}, TopSigCtxt {}) -> True + (XSig {}, InstDeclCtxt {}) -> True + (XSig {}, _) -> False + + ------------------- findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)] -- Check for duplicates on RdrName version, @@ -1188,7 +1216,7 @@ expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns] expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns] expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns] - expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)] + expand_sig sig@(SCCFunSig (_, _) n _) = [(n,sig)] expand_sig _ = [] matching_sig :: (LocatedN RdrName, Sig GhcPs) -> (LocatedN RdrName, Sig GhcPs) -> Bool --AZ @@ -1253,7 +1281,7 @@ -> (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_origin = origin }) +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)) ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms @@ -1287,7 +1315,7 @@ , m_grhss = grhss'}, grhss_fvs ) } emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage -emptyCaseErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $ message ctxt +emptyCaseErr ctxt = mkTcRnUnknownMessage $ mkPlainError noHints $ message ctxt where pp_ctxt :: HsMatchContext GhcRn -> SDoc pp_ctxt c = case c of @@ -1345,7 +1373,7 @@ rnBody rhs ; unless (pattern_guards_allowed || is_standard_guard guards') $ - let diag = TcRnUnknownMessage $ + let diag = mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints (nonStdGuardErr guards') in addDiagnostic diag @@ -1400,7 +1428,7 @@ dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM () dupSigDeclErr pairs@((L loc name, sig) :| _) - = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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 @@ -1412,18 +1440,18 @@ misplacedSigErr :: LSig GhcRn -> RnM () misplacedSigErr (L loc sig) - = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] defaultSigErr :: Sig GhcPs -> TcRnMessage -defaultSigErr sig = TcRnUnknownMessage $ mkPlainError noHints $ +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) $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Bindings in hs-boot files are not allowed" ] nonStdGuardErr :: (Outputable body, @@ -1435,7 +1463,7 @@ dupMinimalSigErr :: [LSig GhcPs] -> RnM () dupMinimalSigErr sigs@(L loc _ : _) - = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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 `|'" ] diff --git a/GHC/Rename/Env.hs b/GHC/Rename/Env.hs --- a/GHC/Rename/Env.hs +++ b/GHC/Rename/Env.hs @@ -77,7 +77,7 @@ import GHC.Types.Error import GHC.Unit.Module import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Warnings ( WarningTxt, pprWarningTxtForMsg ) +import GHC.Unit.Module.Warnings ( WarningTxt ) import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon @@ -104,6 +104,7 @@ import GHC.Types.FieldLabel import GHC.Data.Bag import GHC.Types.PkgQual +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) {- ********************************************************* @@ -206,6 +207,11 @@ -- 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! @@ -275,7 +281,7 @@ let occ = rdrNameOcc rdr_name ; when (isTcOcc occ && isSymOcc occ) (do { op_ok <- xoptM LangExt.TypeOperators - ; unless op_ok (addErr (opDeclErr rdr_name)) }) + ; unless op_ok (addErr (TcRnIllegalTypeOperatorDecl rdr_name)) }) ; env <- getGlobalRdrEnv ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of @@ -498,7 +504,7 @@ = lookupExactOrOrig rdr_name id $ -- See Note [Record field names and Template Haskell] do { flds <- lookupConstructorFields con ; env <- getGlobalRdrEnv - ; let lbl = occNameFS (rdrNameOcc rdr_name) + ; 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 @@ -761,7 +767,7 @@ -- monoid will combine them to this failing case. instance Outputable DisambigInfo where - ppr NoOccurrence = text "NoOccurence" + 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 @@ -865,7 +871,7 @@ 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 encloseing instance decl, if any. +the enclosing instance decl, if any. Note [Looking up Exact RdrNames] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1111,10 +1117,10 @@ badVarInType :: RdrName -> RnM Name badVarInType rdr_name - = do { addErr (TcRnUnknownMessage $ mkPlainError noHints - (text "Illegal promoted term variable in a type:" - <+> ppr rdr_name)) - ; return (mkUnboundNameRdr rdr_name) } + = do { addErr (TcRnUnpromotableThing name TermVariablePE) + ; return name } + where + name = mkUnboundNameRdr rdr_name {- Note [Promoted variables in types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1553,34 +1559,22 @@ -- See Note [Handling of deprecations] do { iface <- loadInterfaceForName doc name ; case lookupImpDeprec iface gre of - Just txt -> do - let msg = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations) - noHints - (mk_msg imp_spec txt) - - addDiagnostic msg + 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 - name_mod = assertPpr (isExternalName name) (ppr name) (nameModule name) + definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name) doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" - mk_msg imp_spec txt - = sep [ sep [ text "In the use of" - <+> pprNonVarNameSpace (occNameSpace occ) - <+> quotes (ppr occ) - , parens imp_msg <> colon ] - , pprWarningTxtForMsg txt ] - where - imp_mod = importSpecModule imp_spec - imp_msg = text "imported from" <+> ppr imp_mod <> extra - extra | imp_mod == moduleName name_mod = Outputable.empty - | otherwise = text ", but defined in" <+> ppr name_mod - lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) lookupImpDeprec iface gre = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing, @@ -2093,25 +2087,9 @@ -- Error messages -opDeclErr :: RdrName -> TcRnMessage -opDeclErr n - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n)) - 2 (text "Use TypeOperators to declare operators in type and declarations") - badOrigBinding :: RdrName -> TcRnMessage badOrigBinding name - | Just _ <- isBuiltInOcc_maybe occ - = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal binding of built-in syntax:" <+> ppr occ - -- Use an OccName here because we don't want to print Prelude.(,) - | otherwise - = TcRnUnknownMessage $ mkPlainError noHints $ - text "Cannot redefine a Name retrieved by a Template Haskell quote:" <+> ppr name - -- This can happen when one tries to use a Template Haskell splice to - -- define a top-level identifier with an already existing name, e.g., - -- - -- $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []]) - -- - -- (See #13968.) + | Just _ <- isBuiltInOcc_maybe occ = TcRnIllegalBindingOfBuiltIn occ + | otherwise = TcRnNameByTemplateHaskellQuote name where occ = rdrNameOcc $ filterCTuple name diff --git a/GHC/Rename/Expr.hs b/GHC/Rename/Expr.hs --- a/GHC/Rename/Expr.hs +++ b/GHC/Rename/Expr.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -23,11 +24,12 @@ -} module GHC.Rename.Expr ( - rnLExpr, rnExpr, rnStmts, - AnnoBody + rnLExpr, rnExpr, rnStmts, mkExpandedExpr, + AnnoBody, UnexpectedStatement(..) ) where import GHC.Prelude +import GHC.Data.FastString import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS , rnMatchGroup, rnGRHS, makeMiniFixityEnv) @@ -47,7 +49,7 @@ , genHsVar, genLHsVar, genHsApp, genHsApps , genAppType ) import GHC.Rename.Unbound ( reportUnboundName ) -import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnSpliceExpr, checkThLocalName ) +import GHC.Rename.Splice ( rnTypedBracket, rnUntypedBracket, rnTypedSplice, rnUntypedSpliceExpr, checkThLocalName ) import GHC.Rename.HsType import GHC.Rename.Pat import GHC.Driver.Session @@ -55,7 +57,6 @@ import GHC.Types.FieldLabel import GHC.Types.Fixity -import GHC.Types.Hint (suggestExtension) import GHC.Types.Id.Make import GHC.Types.Name import GHC.Types.Name.Set @@ -73,8 +74,10 @@ import GHC.Builtin.Types ( nilDataConName ) import qualified GHC.LanguageExtensions as LangExt +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + import Data.List (unzip4, minimumBy) -import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.List.NonEmpty ( NonEmpty(..), nonEmpty ) import Data.Maybe (isJust, isNothing) import Control.Arrow (first) import Data.Ord @@ -122,7 +125,7 @@ * HsIf (if-the-else) if b then e1 else e2 ==> ifThenElse b e1 e2 We do this /only/ if rebindable syntax is on, because the coverage - checker looks for HsIf (see GHC.HsToCore.Coverage.addTickHsExpr) + checker looks for HsIf (see GHC.HsToCore.Ticks.addTickHsExpr) That means the typechecker and desugarer need to understand HsIf for the non-rebindable-syntax case. @@ -151,6 +154,41 @@ on the fly, in GHC.Tc.Gen.Head.splitHsApps. RebindableSyntax does not affect this. +* RecordUpd: we desugar record updates into case expressions, + in GHC.Tc.Gen.Expr.tcExpr. + + Example: + + 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 + + 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' + + See Note [Record Updates] in GHC.Tc.Gen.Expr for more details. + + This is done in the typechecker, 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 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. + Note [Overloaded labels] ~~~~~~~~~~~~~~~~~~~~~~~~ For overloaded labels, note that we /only/ apply `fromLabel` to the @@ -210,8 +248,9 @@ rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) rnUnboundVar 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 (rdrNameOcc v), emptyFVs) + return (HsUnboundVar noExtField v, emptyFVs) rnExpr (HsVar _ (L l v)) = do { dflags <- getDynFlags @@ -245,10 +284,10 @@ = return (HsUnboundVar noExtField v, emptyFVs) -- HsOverLabel: see Note [Handling overloaded and rebindable constructs] -rnExpr (HsOverLabel _ v) +rnExpr (HsOverLabel _ src v) = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName - ; return ( mkExpandedExpr (HsOverLabel noAnn v) $ - HsAppType noExtField (genLHsVar from_label) hs_ty_arg + ; return ( mkExpandedExpr (HsOverLabel noAnn src v) $ + HsAppType noExtField (genLHsVar from_label) noHsTok hs_ty_arg , fvs ) } where hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $ @@ -279,12 +318,12 @@ ; (arg',fvArg) <- rnLExpr arg ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } -rnExpr (HsAppType _ fun arg) +rnExpr (HsAppType _ fun at arg) = do { type_app <- xoptM LangExt.TypeApplications ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg ; (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg - ; return (HsAppType NoExtField fun' arg', fvFun `plusFV` fvArg) } + ; return (HsAppType NoExtField fun' at arg', fvFun `plusFV` fvArg) } rnExpr (OpApp _ e1 op e2) = do { (e1', fv_e1) <- rnLExpr e1 @@ -340,7 +379,8 @@ rnExpr e@(HsTypedBracket _ br_body) = rnTypedBracket e br_body rnExpr e@(HsUntypedBracket _ br_body) = rnUntypedBracket e br_body -rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice +rnExpr (HsTypedSplice _ splice) = rnTypedSplice splice +rnExpr (HsUntypedSplice _ splice) = rnUntypedSpliceExpr splice --------------------------------------------- -- Sections @@ -368,7 +408,7 @@ ; return (HsPragE x (rn_prag prag) expr', fvs_expr) } where rn_prag :: HsPragE GhcPs -> HsPragE GhcRn - rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann + rn_prag (HsPragSCC x ann) = HsPragSCC x ann rnExpr (HsLam x matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches @@ -446,13 +486,11 @@ } Right flds -> -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring. do { ; unlessXOptM LangExt.RebindableSyntax $ - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ - text "RebindableSyntax is required if OverloadedRecordUpdate is enabled." + addErr TcRnNoRebindableSyntaxRecordDot ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld] ; punsEnabled <-xoptM LangExt.NamedFieldPuns ; unless (null punnedFields || punsEnabled) $ - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ - text "For this to work enable NamedFieldPuns." + addErr TcRnNoFieldPunsRecordDot ; (getField, fv_getField) <- lookupSyntaxName getFieldName ; (setField, fv_setField) <- lookupSyntaxName setFieldName ; (e, fv_e) <- rnLExpr expr @@ -527,16 +565,11 @@ -- absolutely prepared to cope with static forms, we check for -- -XStaticPointers here as well. unlessXOptM LangExt.StaticPointers $ - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Illegal static expression:" <+> ppr e) - 2 (text "Use StaticPointers to enable this extension") + addErr $ TcRnIllegalStaticExpression e (expr',fvExpr) <- rnLExpr expr stage <- getStage case stage of - Splice _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ sep - [ text "static forms cannot be used in splices:" - , nest 2 $ ppr e - ] + Splice _ -> addErr $ TcRnIllegalStaticFormInSplice e _ -> return () mod <- getModule let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr @@ -659,6 +692,16 @@ (e `op`) ==> op e with no auxiliary function at all. Simple! +* leftSection and rightSection switch on ImpredicativeTypes locally, + during Quick Look; see GHC.Tc.Gen.App.wantQuickLook. Consider + test DeepSubsumption08: + type Setter st t a b = forall f. Identical f => blah + (.~) :: Setter s t a b -> b -> s -> t + clear :: Setter a a' b (Maybe b') -> a -> a' + clear = (.~ Nothing) + The expansion look like (rightSection (.~) Nothing). So we must + instantiate `rightSection` first type argument to a polytype! + Hence the special magic in App.wantQuickLook. Historical Note [Desugaring operator sections] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -709,6 +752,28 @@ case expr of y -> (\x -> op y x) See #18151. + +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 + 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. + +When it is not, we follow plan B for unqualified names, and plan A for qualified names. + +If a name is qualified, and out of scope, then by default an error will be raised +because the user was already more precise. They specified a specific qualification +and either + * The qualification didn't exist, so that precision was wrong. + * Or the qualification existed and the thing we were looking for wasn't where + the qualification said it would be. + +However we can still defer this error completely, and we do defer it if +`-fdefer-out-of-scope-variables` is enabled. + -} {- @@ -972,9 +1037,6 @@ type AnnoBody body = ( Outputable (body GhcPs) - , Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA - , Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA - , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA ) -- | Rename some Stmts @@ -1039,15 +1101,13 @@ ; (thing, fvs) <- thing_inside [] ; return (([], thing), fvs) } -rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody stmts thing_inside -- Deal with mdo +rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody (nonEmpty -> Just stmts) thing_inside -- Deal with mdo = -- Behave like do { rec { ...all but last... }; last } do { ((stmts1, (stmts2, thing)), fvs) - <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA all_but_last)) $ \ _ -> - do { last_stmt' <- checkLastStmt mDoExpr last_stmt + <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA (NE.init stmts))) $ \ _ -> + do { last_stmt' <- checkLastStmt mDoExpr (NE.last stmts) ; rnStmt mDoExpr rnBody last_stmt' thing_inside } ; return (((stmts1 ++ stmts2), thing), fvs) } - where - Just (all_but_last, last_stmt) = snocView stmts rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside | null lstmts @@ -1059,7 +1119,7 @@ = do { ((stmts1, (stmts2, thing)), fvs) <- setSrcSpanA loc $ do { checkStmt ctxt lstmt - ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> + ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 -> thing_inside (bndrs1 ++ bndrs2) } ; return (((stmts1 ++ stmts2), thing), fvs) } @@ -1154,9 +1214,10 @@ = do { (return_op, fvs1) <- lookupQualifiedDoStmtName ctxt returnMName ; (mfix_op, fvs2) <- lookupQualifiedDoStmtName ctxt mfixName ; (bind_op, fvs3) <- lookupQualifiedDoStmtName ctxt bindMName - ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op - , recS_mfix_fn = mfix_op - , recS_bind_fn = bind_op } + ; let empty_rec_stmt = (emptyRecStmtName :: StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) + { recS_ret_fn = return_op + , recS_mfix_fn = mfix_op + , recS_bind_fn = bind_op } -- Step1: Bring all the binders of the mdo into scope -- (Remember that this also removes the binders from the @@ -1262,9 +1323,7 @@ ; return ((seg':segs', thing), fvs) } cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 - dupErr vs = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ - (text "Duplicate binding in parallel list comprehension for:" - <+> quotes (ppr (NE.head vs))) + dupErr vs = addErr $ TcRnListComprehensionDuplicateBinding (NE.head vs) lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) -- Like lookupStmtName, but respects QualifiedDo @@ -1332,7 +1391,7 @@ (c) The 'bs' in the second group must obviously not be captured by the binding in the first group -To satisfy (a) we nest the segements. +To satisfy (a) we nest the segments. To satisfy (b) we check for duplicates just before thing_inside. To satisfy (c) we reset the LocalRdrEnv each time. @@ -1353,8 +1412,8 @@ -- wrapper that does both the left- and right-hand sides -rnRecStmtsAndThen :: AnnoBody body => - HsStmtContext GhcRn +rnRecStmtsAndThen :: AnnoBody body + => HsStmtContext GhcRn -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -> [LStmt GhcPs (LocatedA (body GhcPs))] -- assumes that the FreeVars returned includes @@ -1417,8 +1476,9 @@ return [(L loc (BindStmt noAnn pat' body), fv_pat)] rn_rec_stmt_lhs _ (L _ (LetStmt _ binds@(HsIPBinds {}))) - = failWith (badIpBinds (text "an mdo expression") binds) + = failWith (badIpBinds (Left binds)) + rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (HsValBinds x binds))) = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds return [(L loc (LetStmt noAnn (HsValBinds x binds')), @@ -1491,7 +1551,7 @@ L loc (BindStmt xbsrn pat' (L lb body')))] } rn_rec_stmt _ _ _ (L _ (LetStmt _ binds@(HsIPBinds {})), _) - = failWith (badIpBinds (text "an mdo expression") binds) + = failWith (badIpBinds (Right binds)) rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (HsValBinds x binds')), _) = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' @@ -1516,8 +1576,8 @@ rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _) = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) -rn_rec_stmts :: AnnoBody body => - HsStmtContext GhcRn +rn_rec_stmts :: AnnoBody body + => HsStmtContext GhcRn -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -> [Name] -> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)] @@ -1527,8 +1587,7 @@ ; return (concat segs_s) } --------------------------------------------- -segmentRecStmts :: AnnoBody body - => SrcSpan -> HsStmtContext GhcRn +segmentRecStmts :: SrcSpan -> HsStmtContext GhcRn -> Stmt GhcRn (LocatedA (body GhcRn)) -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] -> (FreeVars, Bool) @@ -1759,7 +1818,7 @@ The algorithm works by first splitting the sequence of statements into independent "segments", and a separate "tail" (the final statement). In -our example above, the segements would be +our example above, the segments would be [ x <- A , y <- B x ] @@ -2114,7 +2173,9 @@ if | L _ ApplicativeStmt{} <- last stmts' -> return (unLoc tup, emptyNameSet) | otherwise -> do - (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) returnMName + -- 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 return (expr, emptyFVs) return ( ApplicativeArgMany @@ -2132,19 +2193,19 @@ segments :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]] -segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) +segments stmts = merge $ reverse $ map reverse $ walk (reverse stmts) where allvars = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts) -- We would rather not have a segment that just has LetStmts in - -- it, so combine those with an adjacent segment where possible. + -- it, so combine those with the next segment where possible. + -- We don't merge it with the previous segment because the merged segment + -- would require 'Monad' while it may otherwise only require 'Applicative'. merge [] = [] merge (seg : segs) = case rest of - [] -> [(seg,all_lets)] - ((s,s_lets):ss) | all_lets || s_lets - -> (seg ++ s, all_lets && s_lets) : ss - _otherwise -> (seg,all_lets) : rest + s:ss | all_lets -> (seg ++ s) : ss + _otherwise -> seg : rest where rest = merge segs all_lets = all (isLetStmt . fst) seg @@ -2182,7 +2243,7 @@ {- Note [ApplicativeDo and strict patterns] - +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A strict pattern match is really a dependency. For example, do @@ -2211,7 +2272,7 @@ WildPat{} -> False VarPat{} -> False LazyPat{} -> False - AsPat _ _ p -> isStrictPattern p + AsPat _ _ _ p -> isStrictPattern p ParPat _ _ p _ -> isStrictPattern p ViewPat _ _ p -> isStrictPattern p SigPat _ p _ -> isStrictPattern p @@ -2237,7 +2298,7 @@ {- Note [ApplicativeDo and refutable patterns] - +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Refutable patterns in do blocks are desugared to use the monadic 'fail' operation. This means that sometimes an applicative block needs to be wrapped in 'join' simply because of a refutable pattern, in order for the types to work out. @@ -2384,7 +2445,7 @@ _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 _ (HsAppType _ e _ _)) = is_var f e is_var f (L _ (HsVar _ (L _ r))) = f r -- TODO: I don't know how to get this right for rebindable syntax is_var _ _ = False @@ -2405,24 +2466,18 @@ checkEmptyStmts :: HsStmtContext GhcRn -> RnM () -- We've seen an empty sequence of Stmts... is that ok? checkEmptyStmts ctxt - = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) - -okEmpty :: HsStmtContext a -> Bool -okEmpty (PatGuard {}) = True -okEmpty _ = False - -emptyErr :: HsStmtContext GhcRn -> TcRnMessage -emptyErr (ParStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $ - text "Empty statement group in parallel comprehension" -emptyErr (TransStmtCtxt {}) = TcRnUnknownMessage $ mkPlainError noHints $ - text "Empty statement group preceding 'group' or 'then'" -emptyErr ctxt@(HsDoStmt _) = TcRnUnknownMessage $ mkPlainError [suggestExtension LangExt.NondecreasingIndentation] $ - text "Empty" <+> pprStmtContext ctxt -emptyErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $ - text "Empty" <+> pprStmtContext ctxt + = mapM_ (addErr . TcRnEmptyStmtsGroup) mb_err + where + mb_err = case ctxt of + PatGuard {} -> Nothing -- Pattern guards can be empty + ParStmtCtxt {} -> Just EmptyStmtsGroupInParallelComp + TransStmtCtxt {} -> Just EmptyStmtsGroupInTransformListComp + HsDoStmt flav -> Just $ EmptyStmtsGroupInDoNotation flav + ArrowExpr -> Just EmptyStmtsGroupInArrowNotation ---------------------- -checkLastStmt :: AnnoBody body => HsStmtContext GhcRn +checkLastStmt :: AnnoBody body + => HsStmtContext GhcRn -> LStmt GhcPs (LocatedA (body GhcPs)) -> RnM (LStmt GhcPs (LocatedA (body GhcPs))) checkLastStmt ctxt lstmt@(L loc stmt) @@ -2439,12 +2494,11 @@ BodyStmt _ e _ _ -> return (L loc (mkLastStmt e)) LastStmt {} -> return lstmt -- "Deriving" clauses may generate a -- LastStmt directly (unlike the parser) - _ -> do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $ - (hang last_error 2 (ppr stmt)) + _ -> do { addErr $ TcRnLastStmtNotExpr ctxt + $ UnexpectedStatement stmt ; return lstmt } - last_error = (text "The last statement in" <+> pprAStmtContext ctxt - <+> text "must be an expression") + check_comp -- Expect LastStmt; this should be enforced by the parser! = case stmt of LastStmt {} -> return lstmt @@ -2454,35 +2508,25 @@ = do { checkStmt ctxt lstmt; return lstmt } -- Checking when a particular Stmt is ok -checkStmt :: HsStmtContext GhcRn +checkStmt :: AnnoBody body + => HsStmtContext GhcRn -> LStmt GhcPs (LocatedA (body GhcPs)) -> RnM () checkStmt ctxt (L _ stmt) = do { dflags <- getDynFlags ; case okStmt dflags ctxt stmt of - IsValid -> return () - NotValid extra -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (msg $$ extra) } - where - msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement" - , text "in" <+> pprAStmtContext ctxt ] - -pprStmtCat :: Stmt (GhcPass a) 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 {}) = panic "pprStmtCat: ApplicativeStmt" + IsValid -> return () + NotValid ext -> addErr $ + TcRnUnexpectedStatementInContext + ctxt (UnexpectedStatement stmt) ext } ------------ -emptyInvalid :: Validity -- Payload is the empty document -emptyInvalid = NotValid Outputable.empty +emptyInvalid :: Validity' (Maybe LangExt.Extension) +emptyInvalid = NotValid Nothing -- Invalid, and no extension to suggest okStmt, okDoStmt, okCompStmt, okParStmt :: DynFlags -> HsStmtContext GhcRn - -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity + -> 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 @@ -2496,7 +2540,7 @@ okDoFlavourStmt :: DynFlags -> HsDoFlavour -> HsStmtContext GhcRn - -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity + -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension) okDoFlavourStmt dflags flavour ctxt stmt = case flavour of DoExpr{} -> okDoStmt dflags ctxt stmt MDoExpr{} -> okDoStmt dflags ctxt stmt @@ -2505,7 +2549,7 @@ MonadComp -> okCompStmt dflags ctxt stmt ------------- -okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity +okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension) okPatGuardStmt stmt = case stmt of BodyStmt {} -> IsValid @@ -2525,7 +2569,7 @@ RecStmt {} | LangExt.RecursiveDo `xopt` dflags -> IsValid | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec' - | otherwise -> NotValid (text "Use RecursiveDo") + | otherwise -> NotValid (Just LangExt.RecursiveDo) BindStmt {} -> IsValid LetStmt {} -> IsValid BodyStmt {} -> IsValid @@ -2539,10 +2583,10 @@ BodyStmt {} -> IsValid ParStmt {} | LangExt.ParallelListComp `xopt` dflags -> IsValid - | otherwise -> NotValid (text "Use ParallelListComp") + | otherwise -> NotValid (Just LangExt.ParallelListComp) TransStmt {} | LangExt.TransformListComp `xopt` dflags -> IsValid - | otherwise -> NotValid (text "Use TransformListComp") + | otherwise -> NotValid (Just LangExt.TransformListComp) RecStmt {} -> emptyInvalid LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) ApplicativeStmt {} -> emptyInvalid @@ -2554,21 +2598,14 @@ ; checkErr (all tupArgPresent args || tuple_section) msg } where msg :: TcRnMessage - msg = TcRnUnknownMessage $ mkPlainError noHints $ - text "Illegal tuple section: use TupleSections" + msg = TcRnIllegalTupleSection --------- sectionErr :: HsExpr GhcPs -> TcRnMessage -sectionErr expr - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "A section must be enclosed in parentheses") - 2 (text "thus:" <+> (parens (ppr expr))) +sectionErr = TcRnSectionWithoutParentheses -badIpBinds :: Outputable a => SDoc -> a -> TcRnMessage -badIpBinds what binds - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Implicit-parameter bindings illegal in" <+> what) - 2 (ppr binds) +badIpBinds :: Either (HsLocalBindsLR GhcPs GhcPs) (HsLocalBindsLR GhcRn GhcPs) -> TcRnMessage +badIpBinds = TcRnIllegalImplicitParameterBindings --------- @@ -2638,7 +2675,7 @@ | (isQualifiedDo || rebindableSyntax) && overloadedStrings = do (failExpr, failFvs) <- lookupQualifiedDoExpr ctxt failMName (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName - let arg_lit = mkVarOcc "arg" + let arg_lit = mkVarOccFS (fsLit "arg") arg_name <- newSysName arg_lit let arg_syn_expr = nlHsVar arg_name body :: LHsExpr GhcRn = @@ -2673,7 +2710,7 @@ -- -- See Note [Overview of record dot syntax] in GHC.Hs.Expr. --- mkGetField arg field calcuates a get_field @field arg expression. +-- 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) @@ -2681,11 +2718,11 @@ -- 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"). mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn -mkSetField set_field a (L _ field) b = +mkSetField set_field a (L _ (FieldLabelString field)) b = genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field) a) b mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn] -mkGet get_field l@(r : _) (L _ field) = +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!" @@ -2702,7 +2739,7 @@ f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc] proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn - proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f + proj (L _ (FieldLabelString f)) = genHsVar getFieldName `genAppType` genHsTyLit f -- mkProjUpdateSetField calculates functions representing dot notation record updates. -- e.g. Suppose an update like foo.bar = 1. 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 @@ -1,12 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} module GHC.Rename.Expr where -#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) -import Data.Type.Equality (type (~)) -#endif - import GHC.Types.Name import GHC.Hs import GHC.Types.Name.Set ( FreeVars ) @@ -21,10 +15,8 @@ type AnnoBody body = ( Outputable (body GhcPs) - , Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA - , Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA - , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA ) + rnStmts :: --forall thing body. AnnoBody body => HsStmtContext GhcRn -> (body GhcPs -> RnM (body GhcRn, FreeVars)) diff --git a/GHC/Rename/Fixity.hs b/GHC/Rename/Fixity.hs --- a/GHC/Rename/Fixity.hs +++ b/GHC/Rename/Fixity.hs @@ -127,7 +127,7 @@ lookupFixityRn_help' name occ | isUnboundName name = return (False, Fixity NoSourceText minPrecedence InfixL) - -- Minimise errors from ubound names; eg + -- Minimise errors from unbound names; eg -- a>0 `foo` b>0 -- where 'foo' is not in scope, should not give an error (#7937) diff --git a/GHC/Rename/HsType.hs b/GHC/Rename/HsType.hs --- a/GHC/Rename/HsType.hs +++ b/GHC/Rename/HsType.hs @@ -57,7 +57,7 @@ import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) ) import GHC.Tc.Errors.Types import GHC.Tc.Errors.Ppr ( pprScopeError - , inHsDocContext, withHsDocContext, pprHsDocContext ) + , inHsDocContext, pprHsDocContext ) import GHC.Tc.Utils.Monad import GHC.Types.Name.Reader import GHC.Builtin.Names @@ -71,14 +71,16 @@ import GHC.Utils.Misc import GHC.Types.Fixity ( compareFixity, negateFixity , Fixity(..), FixityDirection(..), LexicalFixity(..) ) -import GHC.Types.Basic ( PromotionFlag(..), isPromoted, TypeOrKind(..) ) +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 Data.List (sortBy, nubBy, partition) +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 @@ -213,7 +215,7 @@ -- 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 $ TcRnUnknownMessage $ mkPlainError noHints $ + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Type variable" <> plural varsInScope <+> hcat (punctuate (text ",") (map (quotes . ppr) varsInScope)) @@ -441,10 +443,10 @@ -> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnImplicitTvBndrs ctx mb_assoc implicit_vs_with_dups thing_inside - = do { implicit_vs <- forM (NE.groupBy eqLocated $ sortBy cmpLocated $ implicit_vs_with_dups) $ \case + = do { implicit_vs <- forM (NE.groupAllWith unLoc $ implicit_vs_with_dups) $ \case (x :| []) -> return x (x :| _) -> do - let msg = TcRnUnknownMessage $ mkPlainError noHints $ + 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 @@ -620,8 +622,9 @@ rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ - unlessXOptM LangExt.PolyKinds $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $ - withHsDocContext (rtke_ctxt env) $ + 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" ] -- Any type variable at the kind level is illegal without the use @@ -661,7 +664,7 @@ get_fields (ConDeclCtx names) = concatMapM (lookupConstructorFields . unLoc) names get_fields _ - = do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = do { addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ (hang (text "Record syntax is illegal here:") 2 (ppr ty)) ; return [] } @@ -703,17 +706,18 @@ ; return (HsSumTy x tys', fvs) } -- Ensure that a type-level integer is nonnegative (#8306, #8412) -rnHsTyKi env tyLit@(HsTyLit _ t) +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 noExtField t, emptyFVs) } + ; 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 = TcRnUnknownMessage $ mkPlainError noHints $ + negLitErr = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit rnHsTyKi env (HsAppTy _ ty1 ty2) @@ -755,10 +759,11 @@ check_in_scope :: RdrName -> RnM () check_in_scope rdr_name = do mb_name <- lookupLocalOccRn_maybe rdr_name - -- TODO: refactor this to avoid TcRnUnknownMessage + -- TODO: refactor this to avoid mkTcRnUnknownMessage when (isNothing mb_name) $ - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ - withHsDocContext (rtke_ctxt env) $ + addErr $ + TcRnWithHsDocContext (rtke_ctxt env) $ + mkTcRnUnknownMessage $ mkPlainError noHints $ pprScopeError rdr_name (notInScopeErr WL_LocalOnly rdr_name) rnHsTyKi env ty@(HsExplicitListTy _ ip tys) @@ -779,6 +784,13 @@ = 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 + + 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) @@ -850,7 +862,8 @@ -> Maybe BadAnonWildcardContext -> RnM () checkWildCard env mb_name (Just bad) - = addErr $ TcRnIllegalWildcardInType mb_name bad (Just $ rtke_ctxt env) + = addErr $ TcRnWithHsDocContext (rtke_ctxt env) $ + TcRnIllegalWildcardInType mb_name bad checkWildCard _ _ Nothing = return () @@ -914,7 +927,7 @@ | isRnKindLevel env = do { polykinds <- xoptM LangExt.PolyKinds ; unless polykinds $ - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ (text "Illegal kind:" <+> ppr ty $$ text "Did you mean to enable PolyKinds?") } checkPolyKinds _ _ = return () @@ -925,7 +938,7 @@ -> RnM () notInKinds env ty | isRnKindLevel env - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "Illegal kind:" <+> ppr ty notInKinds _ _ = return () @@ -1274,7 +1287,7 @@ = mapFvRn (rnField fl_env env) fields where env = mkTyKiEnv ctxt TypeLevel RnTypeBody - fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ] + fl_env = mkFsEnv [ (field_label $ flLabel fl, fl) | fl <- fls ] rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs -> RnM (LConDeclField GhcRn, FreeVars) @@ -1332,7 +1345,7 @@ = do { fix2 <- lookupTyFixityRn op2 ; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 } -mkHsOpTyRn prom1 op1 _ ty1 ty2 -- Default case, no rearrangment +mkHsOpTyRn prom1 op1 _ ty1 ty2 -- Default case, no rearrangement = return (HsOpTy noAnn prom1 ty1 op1 ty2) --------------- @@ -1400,7 +1413,7 @@ --------------------------- -- Default case -mkOpAppRn _ e1 op fix e2 -- Default case, no rearrangment +mkOpAppRn _ e1 op fix e2 -- Default case, no rearrangement = assertPpr (right_op_ok fix (unLoc e2)) (ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2) $ return (OpApp fix e1 op e2) @@ -1412,7 +1425,7 @@ -- | Name of an operator in an operator application or section data OpName = NormalOp Name -- ^ A normal identifier | NegateOp -- ^ Prefix negation - | UnboundOp OccName -- ^ An unbound indentifier + | UnboundOp RdrName -- ^ An unbound identifier | RecFldOp (FieldOcc GhcRn) -- ^ A record field occurrence instance Outputable OpName where @@ -1476,7 +1489,7 @@ (nofix_error, associate_right) = compareFixity fix1 fix2 -- Default case -mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment +mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangement = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2]) @@ -1514,7 +1527,7 @@ } } -mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment +mkConOpPatRn op _ p1 p2 -- Default case, no rearrangement = assert (not_op_pat (unLoc p2)) $ return $ ConPat { pat_con_ext = noExtField @@ -1594,7 +1607,7 @@ lookupFixityOp :: OpName -> RnM Fixity lookupFixityOp (NormalOp n) = lookupFixityRn n lookupFixityOp NegateOp = lookupFixityRn negateName -lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName u) +lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (occName u)) lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f @@ -1605,7 +1618,7 @@ | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade | otherwise - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Precedence parsing error") 4 (hsep [text "cannot mix", ppr_opfix op1, text "and", ppr_opfix op2, @@ -1616,7 +1629,7 @@ | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade | otherwise - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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)]), @@ -1642,20 +1655,21 @@ unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> TcRnMessage unexpectedPatSigTypeErr ty - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal type signature:" <+> quotes (ppr ty)) 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () badKindSigErr doc (L loc ty) - = setSrcSpanA loc $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $ - withHsDocContext doc $ + = setSrcSpanA loc $ addErr $ + TcRnWithHsDocContext doc $ + mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal kind signature:" <+> quotes (ppr ty)) 2 (text "Perhaps you intended to use KindSignatures") dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> TcRnMessage dataKindsErr env thing - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) 2 (text "Perhaps you intended to use DataKinds") where @@ -1666,7 +1680,7 @@ => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tv) used_names = unless (hsTyVarName tv `elemNameSet` used_names) $ do - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedForalls) noHints $ vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) , inHsDocContext doc ] diff --git a/GHC/Rename/Module.hs b/GHC/Rename/Module.hs --- a/GHC/Rename/Module.hs +++ b/GHC/Rename/Module.hs @@ -4,7 +4,6 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -16,7 +15,7 @@ rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt ) where -import GHC.Prelude +import GHC.Prelude hiding ( head ) import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) @@ -38,7 +37,7 @@ import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names import GHC.Tc.Errors.Types -import GHC.Tc.Errors.Ppr (withHsDocContext, pprScopeError ) +import GHC.Tc.Errors.Ppr (pprScopeError) import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad @@ -69,12 +68,14 @@ 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(..) ) +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 ) @@ -319,12 +320,12 @@ -} rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) -rnAnnDecl ann@(HsAnnotation _ s provenance expr) +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', + ; return (HsAnnotation (noAnn, s) provenance' expr', provenance_fvs `plusFV` expr_fvs) } rnAnnProvenance :: AnnProvenance GhcPs @@ -381,7 +382,7 @@ ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty ; return (ForeignExport { fd_e_ext = noExtField , fd_name = name', fd_sig_ty = ty' - , fd_fe = spec } + , 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, @@ -392,9 +393,9 @@ -- package, so if they get inlined across a package boundary we'll still -- know where they're from. -- -patchForeignImport :: Unit -> ForeignImport -> ForeignImport -patchForeignImport unit (CImport cconv safety fs spec src) - = CImport cconv safety fs (patchCImportSpec unit spec) src +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 @@ -552,7 +553,7 @@ -- got "lhs = rhs" but expected something different addWarnNonCanonicalMethod1 refURL flag lhs rhs = do - let dia = TcRnUnknownMessage $ + let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $ vcat [ text "Noncanonical" <+> quotes (text (lhs ++ " = " ++ rhs)) <+> @@ -568,7 +569,7 @@ -- expected "lhs = rhs" but got something else addWarnNonCanonicalMethod2 refURL flag lhs rhs = do - let dia = TcRnUnknownMessage $ + let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $ vcat [ text "Noncanonical" <+> quotes (text lhs) <+> @@ -616,7 +617,8 @@ Just (L _ cls) -> Right cls Nothing -> Left ( getLocA head_ty' - , hang (text "Illegal head of an instance declaration:" + , 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" @@ -679,7 +681,7 @@ -- 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 $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg) + addErrAt l $ TcRnWithHsDocContext ctxt err_msg pure $ mkUnboundName (mkTcOccFS (fsLit "")) rnFamEqn :: HsDocContext @@ -843,7 +845,7 @@ badAssocRhs :: [Name] -> RnM () badAssocRhs ns - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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) @@ -1206,7 +1208,7 @@ standaloneDerivErr :: TcRnMessage standaloneDerivErr - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal standalone deriving declaration") 2 (text "Use StandaloneDeriving to enable this extension") @@ -1219,15 +1221,15 @@ -} rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) -rnHsRuleDecls (HsRules { rds_src = src +rnHsRuleDecls (HsRules { rds_ext = (_, src) , rds_rules = rules }) = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules - ; return (HsRules { rds_ext = noExtField - , rds_src = src + ; return (HsRules { rds_ext = src , rds_rules = rn_rules }, fvs) } rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) -rnHsRuleDecl (HsRule { rd_name = rule_name +rnHsRuleDecl (HsRule { rd_ext = (_, st) + , rd_name = rule_name , rd_act = act , rd_tyvs = tyvs , rd_tmvs = tmvs @@ -1238,13 +1240,13 @@ ; checkDupRdrNamesN rdr_names_w_loc ; checkShadowedRdrNames rdr_names_w_loc ; names <- newLocalBndrsRn rdr_names_w_loc - ; let doc = RuleCtx (snd $ unLoc rule_name) + ; 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 (snd $ unLoc rule_name) names lhs' fv_lhs' - ; return (HsRule { rd_ext = HsRuleRn fv_lhs' fv_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' @@ -1299,7 +1301,7 @@ (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 simmpler not to check at all, and that is why +lambdas. So it seems simpler not to check at all, and that is why check_e is commented out. -} @@ -1325,7 +1327,7 @@ check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2 - check (HsAppType _ e _) = checkl e + check (HsAppType _ e _ _) = checkl e check (HsVar _ lv) | (unLoc lv) `notElem` foralls = Nothing check other = Just other -- Failure @@ -1351,14 +1353,14 @@ badRuleVar :: FastString -> Name -> TcRnMessage badRuleVar name var - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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 - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sep [text "Rule" <+> pprRuleName name <> colon, nest 2 (vcat [err, text "in left-hand side:" <+> ppr lhs])] @@ -1368,8 +1370,7 @@ err = case bad_e of HsUnboundVar _ uv -> - let rdr = mkRdrUnqual uv - in pprScopeError rdr $ notInScopeErr WL_Global (mkRdrUnqual uv) + pprScopeError uv $ notInScopeErr WL_Global uv _ -> text "Illegal expression:" <+> ppr bad_e {- ************************************************************** @@ -1396,7 +1397,7 @@ 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 -comoponent analysis to build these groups. We do this for a number of +component analysis to build these groups. We do this for a number of reasons: * Improve kind error messages. Consider @@ -1516,7 +1517,7 @@ -> RnM ([TyClGroup GhcRn], FreeVars) -- Rename the declarations and do dependency analysis on them rnTyClDecls tycl_ds - = do { -- Rename the type/class, instance, and role declaraations + = 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) @@ -1623,7 +1624,7 @@ } where standaloneKiSigErr :: TcRnMessage - standaloneKiSigErr = TcRnUnknownMessage $ mkPlainError noHints $ + standaloneKiSigErr = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal standalone kind signature") 2 (text "Did you mean to enable StandaloneKindSignatures?") @@ -1696,7 +1697,7 @@ dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () dupRoleAnnotErr list - = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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) @@ -1711,7 +1712,7 @@ dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () dupKindSig_Err list - = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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) @@ -1819,11 +1820,11 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdFixity = fixity, - tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data - , dd_kindSig = kind_sig} }) + 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 @@ -1837,7 +1838,8 @@ , tcdDataDefn = defn' , tcdDExt = rn_info }, fvs) } } -rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, +rnTyClDecl (ClassDecl { tcdLayout = layout, + tcdCtxt = context, tcdLName = lcls, tcdTyVars = tyvars, tcdFixity = fixity, tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, @@ -1891,7 +1893,8 @@ ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs ; docs' <- traverse rnLDocDecl docs - ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', + ; return (ClassDecl { tcdLayout = rnLayoutInfo layout, + tcdCtxt = context', tcdLName = lcls', tcdTyVars = tyvars', tcdFixity = fixity, tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', @@ -1900,6 +1903,11 @@ 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 @@ -1940,14 +1948,17 @@ rnDataDefn :: HsDocContext -> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, FreeVars) -rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = context, dd_cons = condecls +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) @@ -1966,17 +1977,14 @@ ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` con_fvs `plusFV` sig_fvs - ; return ( HsDataDefn { dd_ext = noExtField - , dd_ND = new_or_data, dd_cType = cType + ; 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 = case condecls of -- Note [Stupid theta] - (L _ (ConDeclGADT {})) : _ -> False - _ -> True + h98_style = not $ anyLConIsGadt condecls -- Note [Stupid theta] rn_derivs ds = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies @@ -1985,6 +1993,202 @@ ; (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 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 () @@ -1992,7 +2196,7 @@ = do { dyn_flags <- getDynFlags ; case mds of Nothing -> - let dia = TcRnUnknownMessage $ + let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingDerivingStrategies) noHints $ (if xopt LangExt.DerivingStrategies dyn_flags then no_strat_warning @@ -2100,13 +2304,13 @@ badGadtStupidTheta :: HsDocContext -> TcRnMessage badGadtStupidTheta _ - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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 - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds , text enableStrategy ] @@ -2120,7 +2324,7 @@ multipleDerivClausesErr :: TcRnMessage multipleDerivClausesErr - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Illegal use of multiple, consecutive deriving clauses" , text "Use DerivingStrategies to allow this" ] @@ -2186,7 +2390,7 @@ rdr_env <- getLocalRdrEnv ; let resName = hsLTyVarName tvbndr ; when (resName `elemLocalRdrEnv` rdr_env) $ - addErrAt (getLocA tvbndr) $ TcRnUnknownMessage $ mkPlainError noHints $ + addErrAt (getLocA tvbndr) $ mkTcRnUnknownMessage $ mkPlainError noHints $ (hsep [ text "Type variable", quotes (ppr resName) <> comma , text "naming a type family result," ] $$ @@ -2260,7 +2464,7 @@ -- not-in-scope variables) don't check the validity of injectivity -- annotation. This gives better error messages. ; when (noRnErrors && not lhsValid) $ - addErrAt (getLocA injFrom) $ TcRnUnknownMessage $ mkPlainError noHints $ + addErrAt (getLocA injFrom) $ mkTcRnUnknownMessage $ mkPlainError noHints $ ( vcat [ text $ "Incorrect type variable on the LHS of " ++ "injectivity condition" , nest 5 @@ -2269,7 +2473,7 @@ ; when (noRnErrors && not (Set.null rhsValid)) $ do { let errorVars = Set.toList rhsValid - ; addErrAt (locA srcSpan) $ TcRnUnknownMessage $ mkPlainError noHints $ + ; addErrAt (locA srcSpan) $ mkTcRnUnknownMessage $ mkPlainError noHints $ ( hsep [ text "Unknown type variable" <> plural errorVars , text "on the RHS of injectivity condition:" @@ -2312,7 +2516,7 @@ ***************************************************** -} ----------------- -rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars) +rnConDecls :: DataDefnCons (LConDecl GhcPs) -> RnM (DataDefnCons (LConDecl GhcRn), FreeVars) rnConDecls = mapFvRn (wrapLocFstMA rnConDecl) rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) @@ -2350,6 +2554,7 @@ all_fvs) }} rnConDecl (ConDeclGADT { con_names = names + , con_dcolon = dcol , con_bndrs = L l outer_bndrs , con_mb_cxt = mcxt , con_g_args = args @@ -2369,7 +2574,7 @@ extractConDeclGADTDetailsTyVars args $ extractHsTysRdrTyVars [res_ty] [] - ; let ctxt = ConDeclCtx new_names + ; let ctxt = ConDeclCtx (toList new_names) ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' -> do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt @@ -2388,6 +2593,7 @@ (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 }, @@ -2543,15 +2749,15 @@ = do { -- We've found a top-level splice. If it is an *implicit* one -- (i.e. a naked top level expression) case flag of - ExplicitSplice -> return () - ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell + 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 = TcRnUnknownMessage $ mkPlainError noHints $ + 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 diff --git a/GHC/Rename/Names.hs b/GHC/Rename/Names.hs --- a/GHC/Rename/Names.hs +++ b/GHC/Rename/Names.hs @@ -11,9 +11,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Rename.Names ( rnImports, getLocalNonValBinders, newRecordSelector, extendGlobalRdrEnvRn, @@ -30,7 +27,7 @@ ImportDeclUsage ) where -import GHC.Prelude +import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Driver.Env import GHC.Driver.Session @@ -56,7 +53,6 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc as Utils import GHC.Utils.Panic -import GHC.Utils.Trace import GHC.Types.Fixity.Env import GHC.Types.SafeHaskell @@ -86,14 +82,19 @@ 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, groupBy, sortOn ) +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 @@ -114,7 +115,7 @@ 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 dependecy +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 @@ -308,8 +309,9 @@ (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name , ideclPkgQual = raw_pkg_qual , ideclSource = want_boot, ideclSafe = mod_safe - , ideclQualified = qual_style, ideclImplicit = implicit - , ideclAs = as_mod, ideclHiding = imp_details }), import_reason) + , ideclQualified = qual_style + , ideclExt = XImportDeclPass { ideclImplicit = implicit } + , ideclAs = as_mod, ideclImportList = imp_details }), import_reason) = setSrcSpanA loc $ do case raw_pkg_qual of @@ -349,17 +351,17 @@ NoPkgQual -> True ThisPkg uid -> uid == homeUnitId_ (hsc_dflags hsc_env) OtherPkg _ -> False)) - (addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + (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 (False, _) -> return () -- Explicit import list + Just (Exactly, _) -> return () -- Explicit import list _ | implicit -> return () -- Do not bleat for implicit imports | qual_only -> return () | otherwise -> whenWOptM Opt_WarnMissingImportList $ do - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingImportList) noHints (missingImportListWarn imp_mod_name) @@ -384,7 +386,7 @@ warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags)) (warnRedundantSourceImport imp_mod_name) when (mod_safe && not (safeImportsOn dflags)) $ - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + 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")) @@ -402,8 +404,8 @@ let gbl_env = mkGlobalRdrEnv gres - is_hiding | Just (True,_) <- imp_details = True - | otherwise = False + is_hiding | Just (EverythingBut,_) <- imp_details = True + | otherwise = False -- should the import be safe? mod_safe' = mod_safe @@ -426,7 +428,7 @@ -- Complain if we import a deprecated module case mi_warns iface of WarnAll txt -> do - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations) noHints (moduleWarn imp_mod_name txt) @@ -437,16 +439,14 @@ warnUnqualifiedImport decl iface let new_imp_decl = ImportDecl - { ideclExt = noExtField - , ideclSourceSrc = ideclSourceSrc decl + { ideclExt = ideclExt decl , ideclName = ideclName decl , ideclPkgQual = pkg_qual , ideclSource = ideclSource decl , ideclSafe = mod_safe' , ideclQualified = ideclQualified decl - , ideclImplicit = ideclImplicit decl , ideclAs = ideclAs decl - , ideclHiding = new_imp_details + , ideclImportList = new_imp_details } return (L loc new_imp_decl, gbl_env, imports, mi_hpc iface) @@ -609,7 +609,7 @@ warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM () warnUnqualifiedImport decl iface = when bad_import $ do - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnCompatUnqualifiedImports) noHints warning @@ -622,8 +622,8 @@ 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 ideclHiding decl of - Just (False, _) -> True + case ideclImportList decl of + Just (Exactly, _) -> True _ -> False bad_import = not is_qual @@ -642,7 +642,7 @@ warnRedundantSourceImport :: ModuleName -> TcRnMessage warnRedundantSourceImport mod_name - = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ + = mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name) {- @@ -751,7 +751,7 @@ -- This establishes INVARIANT 1 of GlobalRdrEnvs add_gre env gre | not (null dups) -- Same OccName defined twice - = do { addDupDeclErr (gre : dups); return env } + = do { addDupDeclErr (gre :| dups); return env } | otherwise = return (extendGlobalRdrEnv env gre) @@ -916,8 +916,15 @@ -- 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 = hs_boot_sig_bndrs - | otherwise = for_hs_bndrs + ; 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 @@ -938,16 +945,9 @@ ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env]) ; return (envs, new_bndrs) } } where - ValBinds _ _val_binds val_sigs = binds - for_hs_bndrs :: [LocatedN RdrName] for_hs_bndrs = hsForeignDeclsBinders foreign_decls - -- In a hs-boot file, the value binders come from the - -- *signatures*, and there should be no foreign binders - hs_boot_sig_bndrs = [ L (l2l decl_loc) (unLoc n) - | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] - -- the SrcSpan attached to the input should be the span of the -- declaration, not just the name new_simple :: LocatedN RdrName -> RnM AvailInfo @@ -981,7 +981,7 @@ , con_g_args = RecConGADT flds _ })) = [ ( find_con_name rdr , concatMap find_con_decl_flds (unLoc flds)) - | L _ rdr <- rdrs ] + | L _ rdr <- toList rdrs ] find_con_flds _ = [] @@ -994,7 +994,7 @@ find_con_decl_fld (L _ (FieldOcc _ (L _ rdr))) = expectJust "getLocalNonValBinders/find_con_decl_fld" $ find (\ fl -> flLabel fl == lbl) flds - where lbl = occNameFS (rdrNameOcc rdr) + where lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr) new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs -> RnM ([AvailInfo], [(Name, [FieldLabel])]) @@ -1056,7 +1056,7 @@ , flHasFieldSelector = has_sel , flSelector = selName } } where - fieldLabelString = occNameFS $ rdrNameOcc fld + 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 @@ -1164,7 +1164,7 @@ data T = mkT { foo :: Int } module N where - import M (foo) -- this is an ambiguity error (A) + 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' @@ -1175,8 +1175,8 @@ , $sel:foo:MKT -> (foo, T(foo), Nothing) ] -Then when we look up 'foo' in lookup_name for case (A) we get both entries and -hence report an ambiguity error. Whereas in case (B) we reach the lookup_ie +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. @@ -1187,8 +1187,8 @@ filterImports :: ModIface -> ImpDeclSpec -- The span for the entire import decl - -> Maybe (Bool, LocatedL [LIE GhcPs]) -- Import spec; True => hiding - -> RnM (Maybe (Bool, LocatedL [LIE GhcRn]), -- Import spec w/ Names + -> 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)) @@ -1210,8 +1210,8 @@ pruned_avails = filterAvails keep all_avails hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } - gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails - | otherwise = concatMap (gresFromIE decl_spec) items2 + 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 @@ -1251,13 +1251,21 @@ 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 + 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 = case nonDetNameEnvElts succ of - -- See Note [Importing DuplicateRecordFields] - [(c,a,x)] -> return (greNameMangledName c, a, x) - xs -> failLookupWith (AmbiguousImport rdr (map sndOf3 xs)) + | 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) @@ -1276,7 +1284,7 @@ emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ addTcRnDiagnostic (TcRnMissingImportList ieRdr) emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ do - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyImports) noHints (lookup_err_msg (BadImport ie)) @@ -1285,7 +1293,7 @@ run_lookup :: IELookupM a -> TcRn (Maybe a) run_lookup m = case m of Failed err -> do - addErr $ TcRnUnknownMessage $ mkPlainError noHints (lookup_err_msg err) + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints (lookup_err_msg err) return Nothing Succeeded a -> return (Just a) @@ -1310,9 +1318,11 @@ lookup_ie ie = handle_bad_import $ case ie of IEVar _ (L l n) -> do - (name, avail, _) <- lookup_name ie $ ieWrappedName n + -- See Note [Importing DuplicateRecordFields] + xs <- lookup_names ie (ieWrappedName n) return ([(IEVar noExtField (L l (replaceWrappedName n name)), - trimAvail avail name)], []) + trimAvail avail name) + | (name, avail, _) <- xs ], []) IEThingAll _ (L l tc) -> do (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc @@ -1341,7 +1351,7 @@ -- associated type IEThingAbs _ (L l tc') - | want_hiding -- hiding ( C ) + | want_hiding == EverythingBut -- hiding ( C ) -- Here the 'C' can be a data constructor -- *or* a type/class, or even both -> let tc = ieWrappedName tc' @@ -1403,8 +1413,8 @@ , availTC parent [n] []) handle_bad_import m = catchIELookup m $ \err -> case err of - BadImport ie | want_hiding -> return ([], [BadImportW ie]) - _ -> failLookupWith err + BadImport ie | want_hiding == EverythingBut -> return ([], [BadImportW ie]) + _ -> failLookupWith err type IELookupM = MaybeErr IELookupError @@ -1480,8 +1490,8 @@ findChildren :: NameEnv [a] -> Name -> [a] findChildren env n = lookupNameEnv env n `orElse` [] -lookupChildren :: [GreName] -> [LIEWrappedName RdrName] - -> MaybeErr [LIEWrappedName RdrName] -- The ones for which the lookup failed +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 @@ -1699,7 +1709,7 @@ warnUnusedImportDecls gbl_env hsc_src = do { uses <- readMutVar (tcg_used_gres gbl_env) ; let user_imports = filterOut - (ideclImplicit . unLoc) + (ideclImplicit . ideclExt . unLoc) (tcg_rn_imports gbl_env) -- This whole function deals only with *user* imports -- both for warning about unnecessary ones, and for @@ -1731,7 +1741,7 @@ import_usage = mkImportMap used_gres unused_decl :: LImportDecl GhcRn -> (LImportDecl GhcRn, [GlobalRdrElt], [Name]) - unused_decl decl@(L loc (ImportDecl { ideclHiding = imps })) + unused_decl decl@(L loc (ImportDecl { ideclImportList = imps })) = (decl, used_gres, nameSetElemsStable unused_imps) where used_gres = lookupSrcLoc (srcSpanEnd $ locA loc) import_usage @@ -1743,7 +1753,7 @@ unused_imps -- Not trivial; see eg #7454 = case imps of - Just (False, L _ imp_ies) -> + Just (Exactly, L _ imp_ies) -> foldr (add_unused . unLoc) emptyNameSet imp_ies _other -> emptyNameSet -- No explicit import list => no unused-name list @@ -1822,18 +1832,18 @@ warnUnusedImport flag fld_env (L loc decl, used, unused) -- Do not warn for 'import M()' - | Just (False,L _ []) <- ideclHiding decl + | Just (Exactly, L _ []) <- ideclImportList decl = return () -- Note [Do not warn about Prelude hiding] - | Just (True, L _ hides) <- ideclHiding decl + | Just (EverythingBut, L _ hides) <- ideclImportList decl , not (null hides) , pRELUDE_NAME == unLoc (ideclName decl) = return () -- Nothing used; drop entire declaration | null used - = let dia = TcRnUnknownMessage $ + = let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg1 in addDiagnosticAt (locA loc) dia @@ -1843,15 +1853,15 @@ -- Only one import is unused, with `SrcSpan` covering only the unused item instead of -- the whole import statement - | Just (_, L _ imports) <- ideclHiding decl + | Just (_, L _ imports) <- ideclImportList decl , length unused == 1 , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports - = let dia = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 + = let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 in addDiagnosticAt (locA loc) dia -- Some imports are unused | otherwise - = let dia = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 + = let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2 in addDiagnosticAt (locA loc) dia where @@ -1910,7 +1920,7 @@ where mk_minimal (L l decl, used_gres, unused) | null unused - , Just (False, _) <- ideclHiding decl + , Just (Exactly, _) <- ideclImportList decl = return (L l decl) | otherwise = do { let ImportDecl { ideclName = L _ mod_name @@ -1919,7 +1929,7 @@ ; 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 { ideclHiding = Just (False, L (l2l l) lies) })) } + ; return (L l (decl { ideclImportList = Just (Exactly, L (l2l l) lies) })) } where doc = text "Compute minimal imports for" <+> ppr decl @@ -1956,7 +1966,7 @@ all_non_overloaded = all (not . flIsOverloaded) combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn] - combine = map merge . groupBy ((==) `on` getKey) . sortOn getKey + combine = map merge . NE.groupAllWith getKey getKey :: LImportDecl GhcRn -> (Bool, Maybe ModuleName, ModuleName) getKey decl = @@ -1968,10 +1978,9 @@ idecl :: ImportDecl GhcRn idecl = unLoc decl - merge :: [LImportDecl GhcRn] -> LImportDecl GhcRn - merge [] = error "getMinimalImports: unexpected empty list" - merge decls@((L l decl) : _) = L l (decl { ideclHiding = Just (False, L (noAnnSrcSpan (locA l)) lies) }) - where lies = concatMap (unLoc . snd) $ mapMaybe (ideclHiding . unLoc) decls + 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 () @@ -2000,16 +2009,16 @@ basefn = moduleNameString (moduleName this_mod) ++ suffix -to_ie_post_rn_var :: (HasOccName name) => LocatedA name -> LIEWrappedName name +to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn to_ie_post_rn_var (L l n) - | isDataOcc $ occName n = L l (IEPattern (EpaSpan $ la2r l) (L (la2na l) n)) - | otherwise = L l (IEName (L (la2na 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 :: (HasOccName name) => LocatedA name -> LIEWrappedName name +to_ie_post_rn :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn to_ie_post_rn (L l n) - | isTcOcc occ && isSymOcc occ = L l (IEType (EpaSpan $ la2r l) (L (la2na l) n)) - | otherwise = L l (IEName (L (la2na 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 {- @@ -2140,10 +2149,9 @@ illegalImportItemErr :: SDoc illegalImportItemErr = text "Illegal import item" -addDupDeclErr :: [GlobalRdrElt] -> TcRn () -addDupDeclErr [] = panic "addDupDeclErr: empty list" -addDupDeclErr gres@(gre : _) - = addErrAt (getSrcSpan (last sorted_names)) $ TcRnUnknownMessage $ mkPlainError noHints $ +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)), @@ -2151,11 +2159,11 @@ -- latter might not be in scope in the RdrEnv and so will -- be printed qualified. text "Declared at:" <+> - vcat (map (ppr . nameSrcLoc) sorted_names)] + vcat (toList $ ppr . nameSrcLoc <$> sorted_names)] where sorted_names = - sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) - (map greMangledName gres) + NE.sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) + (fmap greMangledName gres) @@ -2174,7 +2182,7 @@ packageImportErr :: TcRnMessage packageImportErr - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Package-qualified imports are not enabled; use PackageImports" -- This data decl will parse OK @@ -2186,11 +2194,15 @@ -- 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) (badDataCon name) +checkConName name + = checkErr (isRdrDataCon name || isRdrTc name) (badDataCon name) badDataCon :: RdrName -> TcRnMessage badDataCon name - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hsep [text "Illegal data constructor name", quotes (ppr name)] diff --git a/GHC/Rename/Pat.hs b/GHC/Rename/Pat.hs --- a/GHC/Rename/Pat.hs +++ b/GHC/Rename/Pat.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} @@ -7,9 +7,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DisambiguateRecordFields #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -22,7 +19,7 @@ free variables. -} module GHC.Rename.Pat (-- main entry points - rnPat, rnPats, rnBindPat, rnPatAndThen, + rnPat, rnPats, rnBindPat, NameMaker, applyNameMaker, -- a utility for making names: localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names, @@ -77,11 +74,14 @@ import GHC.Driver.Session ( getDynFlags, xopt_DuplicateRecordFields ) import qualified GHC.LanguageExtensions as LangExt -import Control.Monad ( when, ap, guard, forM, unless ) +import Control.Monad ( when, ap, guard, unless ) +import Data.Foldable +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(..)) {- ********************************************************* @@ -404,9 +404,10 @@ -- * local namemaker -- * unused and duplicate checking -- * no fixities -rnPats :: HsMatchContext GhcRn -- for error messages - -> [LPat GhcPs] - -> ([LPat GhcRn] -> RnM (a, FreeVars)) +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 @@ -423,7 +424,7 @@ -- complain *twice* about duplicates e.g. f (x,x) = ... -- -- See Note [Don't report shadowing for pattern synonyms] - ; let bndrs = collectPatsBinders CollNoDictBinders pats' + ; let bndrs = collectPatsBinders CollNoDictBinders (toList pats') ; addErrCtxt doc_pat $ if isPatSynCtxt ctxt then checkDupNames bndrs @@ -431,6 +432,8 @@ ; 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 -> LPat GhcPs @@ -438,7 +441,7 @@ -> RnM (a, FreeVars) -- Variables bound by pattern do not -- appear in the result FreeVars rnPat ctxt pat thing_inside - = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat') + = rnPats ctxt (Identity pat) (thing_inside . runIdentity) applyNameMaker :: NameMaker -> LocatedN RdrName -> RnM (LocatedN Name) applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr) @@ -468,9 +471,9 @@ -} -- ----------- Entry point 3: rnLPatAndThen ------------------- --- General version: parametrized by how you make new names +-- General version: parameterized by how you make new names -rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn] +rnLPatsAndThen :: Traversable f => NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn)) rnLPatsAndThen mk = mapM (rnLPatAndThen mk) -- Despite the map, the monad ensures that each pattern binds -- variables that may be mentioned in subsequent patterns in the list @@ -551,10 +554,10 @@ (L l lit') lit' ge minus) } -- The Report says that n+k patterns must be in Integral -rnPatAndThen mk (AsPat _ rdr pat) +rnPatAndThen mk (AsPat _ rdr at pat) = do { new_name <- newPatLName mk rdr ; pat' <- rnLPatAndThen mk pat - ; return (AsPat noExtField new_name pat') } + ; return (AsPat noExtField new_name at pat') } rnPatAndThen mk p@(ViewPat _ expr pat) = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns @@ -609,15 +612,13 @@ ; return (SumPat noExtField pat alt arity) } --- If a splice has been run already, just rename the result. -rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat))) - = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat - rnPatAndThen mk (SplicePat _ splice) = do { eith <- liftCpsFV $ rnSplicePat splice ; case eith of -- See Note [rnSplicePat] in GHC.Rename.Splice - Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed - Right already_renamed -> return already_renamed } + (rn_splice, HsUntypedSpliceTop mfs pat) -> -- Splice was top-level and thus run, creating Pat GhcPs + gParPat . (fmap (flip SplicePat rn_splice . HsUntypedSpliceTop mfs)) <$> rnLPatAndThen mk pat + (rn_splice, HsUntypedSpliceNested splice_name) -> return (SplicePat (HsUntypedSpliceNested splice_name) rn_splice) -- Splice was nested and thus already renamed + } -------------------- rnConPatAndThen :: NameMaker @@ -628,8 +629,7 @@ rnConPatAndThen mk con (PrefixCon tyargs pats) = do { con' <- lookupConCps con ; liftCps check_lang_exts - ; tyargs' <- forM tyargs $ \t -> - liftCpsWithCont $ rnHsPatSigTypeBindingVars HsTypeCtx t + ; tyargs' <- mapM rnConPatTyArg tyargs ; pats' <- rnLPatsAndThen mk pats ; return $ ConPat { pat_con_ext = noExtField @@ -644,12 +644,15 @@ type_app <- xoptM LangExt.TypeApplications unless (scoped_tyvars && type_app) $ case listToMaybe tyargs of - Nothing -> pure () - Just tyarg -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + Nothing -> pure () + Just tyarg -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal visible type application in a pattern:" - <+> quotes (char '@' <> ppr tyarg)) + <+> 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 @@ -689,13 +692,13 @@ where mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n) rn_field (L l fld, n') = - do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hfbRHS fld) + 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 -> n) = collectPatsBinders CollNoDictBinders implicit_pats + implicit_binders fs (unLoc -> RecFieldsDotDot n) = collectPatsBinders CollNoDictBinders implicit_pats where implicit_pats = map (hfbRHS . unLoc) (drop n fs) @@ -794,12 +797,12 @@ , hfbPun = pun })) } - rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat + rn_dotdot :: Maybe (Located RecFieldsDotDot) -- See Note [DotDot fields] in GHC.Hs.Pat -> Maybe Name -- The constructor (Nothing for an -- out of scope constructor) -> [LHsRecField GhcRn (LocatedA arg)] -- Explicit fields -> RnM ([LHsRecField GhcRn (LocatedA arg)]) -- Field Labels we need to fill in - rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match + rn_dotdot (Just (L loc (RecFieldsDotDot n))) (Just con) flds -- ".." on record construction / pat match | not (isUnboundName con) -- This test is because if the constructor -- isn't in scope the constructor lookup will add -- an error but still return an unbound name. We @@ -822,7 +825,7 @@ (dot_dot_fields, dot_dot_gres) = unzip [ (fl, gre) | fl <- con_fields - , let lbl = mkVarOccFS (flLabel fl) + , let lbl = mkVarOccFS (field_label $ flLabel fl) , not (lbl `elemOccSet` present_flds) , Just gre <- [lookupGRE_FieldLabel rdr_env fl] -- Check selector is in scope @@ -840,7 +843,7 @@ , hfbPun = False }) | fl <- dot_dot_fields , let sel = flSelector fl - , let arg_rdr = mkVarUnqual (flLabel fl) ] } + , let arg_rdr = mkVarUnqual (field_label $ flLabel fl) ] } rn_dotdot _dotdot _mb_con _flds = return [] @@ -962,7 +965,7 @@ , denominator val == 1 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val}) generalizeOverLitVal lit = lit -isNegativeZeroOverLit :: HsOverLit t -> Bool +isNegativeZeroOverLit :: (XXOverLit t ~ DataConCantHappen) => HsOverLit t -> Bool isNegativeZeroOverLit lit = case ol_val lit of HsIntegral i -> 0 == il_value i && il_neg i @@ -984,7 +987,7 @@ can apply it explicitly. In this case it stays negative zero. #13211 -} -rnOverLit :: HsOverLit t -> +rnOverLit :: (XXOverLit t ~ DataConCantHappen) => HsOverLit t -> RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars) rnOverLit origLit = do { opt_NumDecimals <- xoptM LangExt.NumDecimals diff --git a/GHC/Rename/Splice.hs b/GHC/Rename/Splice.hs --- a/GHC/Rename/Splice.hs +++ b/GHC/Rename/Splice.hs @@ -1,14 +1,18 @@ - +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Rename.Splice ( rnTopSpliceDecls, - rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl, + + -- Typed splices + rnTypedSplice, + -- Untyped splices + rnSpliceType, rnUntypedSpliceExpr, rnSplicePat, rnSpliceDecl, + + -- Brackets rnTypedBracket, rnUntypedBracket, - checkThLocalName - , traceSplice, SpliceInfo(..) + + checkThLocalName, traceSplice, SpliceInfo(..) ) where import GHC.Prelude @@ -27,7 +31,7 @@ import GHC.Rename.Module ( rnSrcDecls, findSplice ) import GHC.Rename.Pat ( rnPat ) import GHC.Types.Error -import GHC.Types.Basic ( TopLevelFlag, isTopLevel ) +import GHC.Types.Basic ( TopLevelFlag, isTopLevel, maxPrec ) import GHC.Types.SourceText ( SourceText(..) ) import GHC.Utils.Outputable import GHC.Unit.Module @@ -78,7 +82,7 @@ checkForTemplateHaskellQuotes e = do { thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes ; unless thQuotesEnabled $ - failWith ( TcRnUnknownMessage $ mkPlainError noHints $ vcat + failWith ( mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Syntax error on" <+> ppr e , text ("Perhaps you intended to use TemplateHaskell" ++ " or TemplateHaskellQuotes") ] ) @@ -229,21 +233,21 @@ 2 (ppr br_body) illegalBracket :: TcRnMessage -illegalBracket = TcRnUnknownMessage $ mkPlainError noHints $ +illegalBracket = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Template Haskell brackets cannot be nested" <+> text "(without intervening splices)" illegalTypedBracket :: TcRnMessage -illegalTypedBracket = TcRnUnknownMessage $ mkPlainError noHints $ +illegalTypedBracket = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Typed brackets may only appear in typed splices." illegalUntypedBracket :: TcRnMessage -illegalUntypedBracket = TcRnUnknownMessage $ mkPlainError noHints $ +illegalUntypedBracket = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Untyped brackets may only appear in untyped splices." quotedNameStageErr :: HsQuote GhcPs -> TcRnMessage quotedNameStageErr br - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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" ] @@ -284,63 +288,53 @@ We don't want the type checker to see these bogus unbound variables. -} -rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars)) - -- Outside brackets, run splice - -> (HsSplice GhcRn -> (PendingRnSplice, a)) - -- Inside brackets, make it pending - -> HsSplice GhcPs - -> RnM (a, FreeVars) -rnSpliceGen run_splice pend_splice splice +rnUntypedSpliceGen :: (HsUntypedSplice GhcRn -> RnM (a, FreeVars)) + -- Outside brackets, run splice + -> (Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, 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 pop_stage RnPendingTyped - -> do { checkTc is_typed_splice illegalUntypedSplice - ; (splice', fvs) <- setStage pop_stage $ - rnSplice splice - ; let (_pending_splice, result) = pend_splice splice' - ; return (result, fvs) } + Brack _ RnPendingTyped + -> failWithTc illegalUntypedSplice Brack pop_stage (RnPendingUntyped ps_var) - -> do { checkTc (not is_typed_splice) illegalTypedSplice - ; (splice', fvs) <- setStage pop_stage $ - rnSplice splice - ; let (pending_splice, result) = pend_splice splice' + -> do { (splice', fvs) <- setStage pop_stage $ + rnUntypedSplice splice + ; loc <- getSrcSpanM + ; splice_name <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice) + ; let (pending_splice, result) = pend_splice splice_name splice' ; ps <- readMutVar ps_var ; writeMutVar ps_var (pending_splice : ps) ; return (result, fvs) } _ -> do { checkTopSpliceAllowed splice ; (splice', fvs1) <- checkNoErrs $ - setStage (Splice splice_type) $ - rnSplice splice + setStage (Splice Untyped) $ + rnUntypedSplice 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 ; (result, fvs2) <- run_splice splice' ; return (result, fvs1 `plusFV` fvs2) } } - where - is_typed_splice = isTypedSplice splice - splice_type = if is_typed_splice - then Typed - else Untyped -- Nested splices are fine without TemplateHaskell because they -- are not executed until the top-level splice is run. -checkTopSpliceAllowed :: HsSplice GhcPs -> RnM () +checkTopSpliceAllowed :: HsUntypedSplice GhcPs -> RnM () checkTopSpliceAllowed splice = do let (herald, ext) = spliceExtension splice extEnabled <- xoptM ext unless extEnabled - (failWith $ TcRnUnknownMessage $ mkPlainError noHints $ + (failWith $ mkTcRnUnknownMessage $ mkPlainError noHints $ text herald <+> text "are not permitted without" <+> ppr ext) where - spliceExtension :: HsSplice GhcPs -> (String, LangExt.Extension) + spliceExtension :: HsUntypedSplice GhcPs -> (String, LangExt.Extension) spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes) - spliceExtension (HsTypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell) - spliceExtension (HsUntypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell) - spliceExtension s@(HsSpliced {}) = pprPanic "spliceExtension" (ppr s) + spliceExtension (HsUntypedSpliceExpr {}) = ("Top-level splices", LangExt.TemplateHaskell) ------------------ @@ -352,7 +346,7 @@ -> (LHsExpr GhcTc -> TcRn res) -> (res -> SDoc) -- How to pretty-print res -- Usually just ppr, but not for [Decl] - -> HsSplice GhcRn -- Always untyped + -> HsUntypedSplice GhcRn -> TcRn (res, [ForeignRef (TH.Q ())]) runRnSplice flavour run_meta ppr_res splice = do { hooks <- hsc_hooks <$> getTopEnv @@ -361,10 +355,8 @@ Just h -> h splice ; let the_expr = case splice' of - HsUntypedSplice _ _ _ e -> e - HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str - HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) - HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) + HsUntypedSpliceExpr _ e -> e + HsQuasiQuote _ q str -> mkQuasiQuoteExpr flavour q str -- Typecheck the expression ; meta_exp_ty <- tcMetaTy meta_ty_name @@ -401,30 +393,28 @@ ------------------ makePending :: UntypedSpliceFlavour - -> HsSplice GhcRn + -> Name + -> HsUntypedSplice GhcRn -> PendingRnSplice -makePending flavour (HsUntypedSplice _ _ n e) +makePending flavour n (HsUntypedSpliceExpr _ e) = PendingRnSplice flavour n e -makePending flavour (HsQuasiQuote _ n quoter q_span quote) - = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote) -makePending _ splice@(HsTypedSplice {}) - = pprPanic "makePending" (ppr splice) -makePending _ splice@(HsSpliced {}) - = pprPanic "makePending" (ppr splice) +makePending flavour n (HsQuasiQuote _ quoter quote) + = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter quote) ------------------ -mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString +mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name + -> XRec GhcPs FastString -> LHsExpr GhcRn -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote -mkQuasiQuoteExpr flavour quoter q_span' 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))) quoterExpr) quoteExpr where - q_span = noAnnSrcSpan q_span' + 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 quote_selector = case flavour of @@ -434,66 +424,90 @@ UntypedDeclSplice -> quoteDecName --------------------- -rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) --- Not exported...used for all -rnSplice (HsTypedSplice x hasParen splice_name expr) - = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) splice_name) - ; (expr', fvs) <- rnLExpr expr - ; return (HsTypedSplice x hasParen n' expr', fvs) } - -rnSplice (HsUntypedSplice x hasParen splice_name expr) - = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) splice_name) - ; (expr', fvs) <- rnLExpr expr - ; return (HsUntypedSplice x hasParen n' expr', fvs) } +unqualSplice :: RdrName +-- The RdrName for a SplicePointName. See GHC.Hs.Expr +-- Note [Lifecycle of an untyped splice, and PendingRnSplice] +-- We use "spn" (which is arbitrary) because it is brief but grepable-for. +unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "spn")) -rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) - = do { loc <- getSrcSpanM - ; splice_name' <- newLocalBndrRn (L (noAnnSrcSpan loc) splice_name) +rnUntypedSplice :: HsUntypedSplice GhcPs -> RnM (HsUntypedSplice GhcRn, FreeVars) +-- Not exported...used for all +rnUntypedSplice (HsUntypedSpliceExpr annCo expr) + = do { (expr', fvs) <- rnLExpr expr + ; return (HsUntypedSpliceExpr annCo expr', fvs) } - -- Rename the quoter; akin to the HsVar case of rnExpr +rnUntypedSplice (HsQuasiQuote ext quoter quote) + = 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 x splice_name' quoter' q_loc quote - , unitFV quoter') } - -rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) + ; return (HsQuasiQuote ext quoter' quote, unitFV quoter') } --------------------- -rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) -rnSpliceExpr splice - = rnSpliceGen run_expr_splice pend_expr_splice splice - where - pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn) - pend_expr_splice rn_splice - = (makePending UntypedExpSplice rn_splice, HsSpliceE noAnn rn_splice) +rnTypedSplice :: LHsExpr 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 - run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars) - run_expr_splice rn_splice - | isTypedSplice rn_splice -- Run it later, in the type checker - = do { -- Ugh! See Note [Splices] above - traceRn "rnSpliceExpr: typed expression splice" empty - ; lcl_rdr <- getLocalRdrEnv - ; gbl_rdr <- getGlobalRdrEnv - ; let gbl_names = mkNameSet [greMangledName gre | gre <- globalRdrEnvElts gbl_rdr - , isLocalGRE gre] - lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) + Brack _ (RnPendingUntyped _) + -> failWithTc illegalTypedSplice - ; return (HsSpliceE noAnn rn_splice, lcl_names `plusFV` gbl_names) } + _ -> do { extEnabled <- xoptM LangExt.TemplateHaskell + ; unless extEnabled + (failWith $ mkTcRnUnknownMessage $ mkPlainError noHints $ + text "Top-level splices are not permitted without" + <+> ppr LangExt.TemplateHaskell) - | otherwise -- Run it here, see Note [Running splices in the Renamer] - = do { traceRn "rnSpliceExpr: untyped expression splice" empty + ; (result, fvs1) <- checkNoErrs $ setStage (Splice Typed) 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 + + -- Run typed splice later, in the type checker + -- Ugh! See Note [Free variables of typed splices] above + ; traceRn "rnTypedSplice: typed expression splice" empty + ; lcl_rdr <- getLocalRdrEnv + ; gbl_rdr <- getGlobalRdrEnv + ; let gbl_names = mkNameSet [greMangledName gre | gre <- globalRdrEnvElts gbl_rdr + , isLocalGRE gre] + lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) + fvs2 = lcl_names `plusFV` gbl_names + + ; return (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) } + +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) + + 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 = HsSpliceE noAnn - . HsSpliced noExtField (ThModFinalizers mod_finalizers) - . HsSplicedExpr + ; let e = flip HsUntypedSplice rn_splice + . HsUntypedSpliceTop (ThModFinalizers mod_finalizers) <$> lexpr3 ; return (gHsPar e, fvs) } @@ -649,32 +663,43 @@ -} ---------------------- -rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) +rnSpliceType :: HsUntypedSplice GhcPs -> RnM (HsType GhcRn, FreeVars) rnSpliceType splice - = rnSpliceGen run_type_splice pend_type_splice splice + = rnUntypedSpliceGen run_type_splice pend_type_splice splice where - pend_type_splice rn_splice - = ( makePending UntypedTypeSplice rn_splice - , HsSpliceTy noExtField rn_splice) + pend_type_splice name rn_splice + = ( makePending UntypedTypeSplice name rn_splice + , HsSpliceTy (HsUntypedSpliceNested name) rn_splice) + run_type_splice :: HsUntypedSplice GhcRn -> RnM (HsType GhcRn, FreeVars) run_type_splice rn_splice = do { traceRn "rnSpliceType: untyped type splice" empty ; (hs_ty2, mod_finalizers) <- runRnSplice UntypedTypeSplice runMetaT ppr rn_splice ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2 ; checkNoErrs $ rnLHsType doc hs_ty2 } - -- checkNoErrs: see Note [Renamer errors] + -- checkNoErrs: see Note [Renamer errors] + -- See Note [Delaying modFinalizers in untyped splices]. - ; return ( HsParTy noAnn - $ HsSpliceTy noExtField - . HsSpliced noExtField (ThModFinalizers mod_finalizers) - . HsSplicedTy <$> - hs_ty3 + ; return ( HsSpliceTy (HsUntypedSpliceTop (ThModFinalizers mod_finalizers) + (mb_paren hs_ty3)) + rn_splice , fvs ) } -- Wrap the result of the splice in parens so that we don't -- lose the outermost location set by runQuasiQuote (#7918) + -- Wrap a non-atomic result in HsParTy parens; + -- but not if it's atomic to avoid double parens for operators + -- This is to account for, say foo :: $(blah) -> Int + -- when we want $(blah) to expand to (this -> that), with parens. + -- Sadly, it's awkward add precisely the correct parens, because + -- that depends on the context. + 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 + {- Note [Partial Type Splices] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Partial Type Signatures are partially supported in TH type splices: only @@ -717,50 +742,43 @@ ---------------------- -- | Rename a splice pattern. See Note [rnSplicePat] -rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) - , FreeVars) +rnSplicePat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs)) + , FreeVars) rnSplicePat splice - = rnSpliceGen run_pat_splice pend_pat_splice splice + = rnUntypedSpliceGen run_pat_splice pend_pat_splice splice where - pend_pat_splice :: HsSplice GhcRn -> - (PendingRnSplice, Either b (Pat GhcRn)) - pend_pat_splice rn_splice - = (makePending UntypedPatSplice rn_splice - , Right (SplicePat noExtField rn_splice)) + pend_pat_splice name rn_splice + = (makePending UntypedPatSplice name rn_splice + , (rn_splice, HsUntypedSpliceNested name)) -- Pat splice is nested and thus simply renamed - run_pat_splice :: HsSplice GhcRn -> - RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars) run_pat_splice rn_splice = do { traceRn "rnSplicePat: untyped pattern splice" empty ; (pat, mod_finalizers) <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice -- See Note [Delaying modFinalizers in untyped splices]. - ; let p = SplicePat noExtField - . HsSpliced noExtField (ThModFinalizers mod_finalizers) - . HsSplicedPat - <$> pat - ; return (Left $ gParPat p, emptyFVs) } + ; let p = HsUntypedSpliceTop (ThModFinalizers mod_finalizers) pat + ; return ((rn_splice, p), 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) - = rnSpliceGen run_decl_splice pend_decl_splice splice + = rnUntypedSpliceGen run_decl_splice pend_decl_splice splice where - pend_decl_splice rn_splice - = ( makePending UntypedDeclSplice rn_splice + pend_decl_splice name rn_splice + = ( makePending UntypedDeclSplice name rn_splice , SpliceDecl noExtField (L loc rn_splice) flg) - run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) + run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (pprUntypedSplice True Nothing rn_splice) -rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) +rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) -- Declaration splice at the very top level of the module rnTopSpliceDecls splice = do { checkTopSpliceAllowed splice ; (rn_splice, fvs) <- checkNoErrs $ setStage (Splice Untyped) $ - rnSplice splice + rnUntypedSplice splice -- As always, be sure to checkNoErrs above lest we end up with -- holes making it to typechecking, hence #12584. -- @@ -803,33 +821,33 @@ management is effectively done by using continuation-passing style in GHC.Rename.Pat, through the CpsRn monad. We don't wish to be in that monad here (it would create import cycles and generally conflict with renaming other -splices), so we really want to return a (Pat RdrName) -- the result of +splices), so we really want to return a (Pat GhcPs) -- the result of running the splice -- which can then be further renamed in GHC.Rename.Pat, in the CpsRn monad. The problem is that if we're renaming a splice within a bracket, we *don't* want to run the splice now. We really do just want to rename -it to an HsSplice Name. Of course, then we can't know what variables +it to an HsUntypedSplice Name. Of course, then we can't know what variables are bound within the splice. So we accept any unbound variables and rename them again when the bracket is spliced in. If a variable is brought into scope by a pattern splice all is fine. If it is not then an error is reported. -In any case, when we're done in rnSplicePat, we'll either have a -Pat RdrName (the result of running a top-level splice) or a Pat Name -(the renamed nested splice). Thus, the awkward return type of -rnSplicePat. +In any case, when we're done in rnSplicePat, we'll have both the renamed +splice, and either a Pat RdrName and ThModFinalizers (the result of running a +top-level splice) or a splice point name. Thus, rnSplicePat returns both +HsUntypedSplice GhcRn, and HsUntypedSpliceResult (Pat GhcPs) -- which models +the existence of either the result of running the splice (HsUntypedSpliceTop), +or its splice point name if nested (HsUntypedSpliceNested) -} -spliceCtxt :: HsSplice GhcPs -> SDoc +spliceCtxt :: HsUntypedSplice GhcPs -> SDoc spliceCtxt splice - = hang (text "In the" <+> what) 2 (ppr splice) + = hang (text "In the" <+> what) 2 (pprUntypedSplice True Nothing splice) where what = case splice of - HsUntypedSplice {} -> text "untyped splice:" - HsTypedSplice {} -> text "typed splice:" - HsQuasiQuote {} -> text "quasi-quotation:" - HsSpliced {} -> text "spliced expression:" + HsUntypedSpliceExpr {} -> text "untyped splice:" + HsQuasiQuote {} -> text "quasi-quotation:" -- | The splice data to be logged data SpliceInfo @@ -878,11 +896,11 @@ , gen ] illegalTypedSplice :: TcRnMessage -illegalTypedSplice = TcRnUnknownMessage $ mkPlainError noHints $ +illegalTypedSplice = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Typed splices may not appear in untyped brackets" illegalUntypedSplice :: TcRnMessage -illegalUntypedSplice = TcRnUnknownMessage $ mkPlainError noHints $ +illegalUntypedSplice = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Untyped splices may not appear in typed brackets" checkThLocalName :: Name -> RnM () 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 @@ -1,14 +1,13 @@ module GHC.Rename.Splice where -import GHC.Prelude import GHC.Hs import GHC.Tc.Utils.Monad import GHC.Types.Name.Set -rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) -rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) - , FreeVars ) +rnSpliceType :: HsUntypedSplice GhcPs -> RnM (HsType GhcRn, FreeVars) +rnSplicePat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs)) + , FreeVars) rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) -rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) +rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) diff --git a/GHC/Rename/Unbound.hs b/GHC/Rename/Unbound.hs --- a/GHC/Rename/Unbound.hs +++ b/GHC/Rename/Unbound.hs @@ -57,6 +57,7 @@ import Data.List (sortBy, partition, nub) import Data.List.NonEmpty ( pattern (:|), NonEmpty ) import Data.Function ( on ) +import qualified Data.Semigroup as S {- ************************************************************************ @@ -303,10 +304,7 @@ pick = listToMaybe . sortBy cmp . filter select where select imv = case mod_name of Just name -> imv_name imv == name Nothing -> not (imv_qualified imv) - cmp a b = - (compare `on` imv_is_hiding) a b - `thenCmp` - (SrcLoc.leftmost_smallest `on` imv_span) a b + cmp = on compare imv_is_hiding S.<> on SrcLoc.leftmost_smallest imv_span -- Which of these would export a 'foo' -- (all of these are restricted imports, because if they were not, we @@ -330,8 +328,7 @@ | otherwise = True where hpt_uniques = map fst (udfmToList hpt) - is_last_loaded_mod _ [] = False - is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam + is_last_loaded_mod modnam uniqs = lastMaybe uniqs == Just (getUnique modnam) glob_mods = nub [ mod | gre <- globalRdrEnvElts global_env , (mod, _) <- qualsInScope gre diff --git a/GHC/Rename/Utils.hs b/GHC/Rename/Utils.hs --- a/GHC/Rename/Utils.hs +++ b/GHC/Rename/Utils.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- This module contains miscellaneous functions related to renaming. @@ -20,7 +20,9 @@ mkFieldEnv, badQualBndrErr, typeAppErr, badFieldConErr, wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType, - genHsIntegralLit, genHsTyLit, + genHsIntegralLit, genHsTyLit, genSimpleConPat, + genVarPat, genWildPat, + genSimpleFunBind, genFunBind, newLocalBndrRn, newLocalBndrsRn, @@ -35,13 +37,12 @@ where -import GHC.Prelude +import GHC.Prelude hiding (unzip) import GHC.Core.Type import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Errors.Types -import GHC.Tc.Errors.Ppr (withHsDocContext) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Types.Error @@ -55,7 +56,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Types.Basic ( TopLevelFlag(..) ) +import GHC.Types.Basic ( TopLevelFlag(..), Origin(Generated) ) import GHC.Data.List.SetOps ( removeDups ) import GHC.Data.Maybe ( whenIsJust ) import GHC.Driver.Session @@ -66,6 +67,7 @@ import qualified Data.List.NonEmpty as NE import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Bag +import qualified Data.List as List {- ********************************************************* @@ -201,7 +203,9 @@ let bndrs = sig_ty_bndrs ty in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of Nothing -> return () - Just _ -> addErr $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt msg) + Just _ -> addErr $ + TcRnWithHsDocContext ctxt $ + mkTcRnUnknownMessage $ mkPlainError noHints msg where sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs] sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs})) @@ -284,7 +288,7 @@ -- "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, SDoc) +noNestedForallsContextsErr :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, TcRnMessage) noNestedForallsContextsErr what lty = case ignoreParens lty of L l (HsForAllTy { hst_tele = tele }) @@ -293,9 +297,7 @@ -- types of terms, so we give a slightly more descriptive error -- message in the event that they contain visible dependent -- quantification (currently only allowed in kinds). - -> Just (locA l, vcat [ text "Illegal visible, dependent quantification" <+> - text "in the type of a term" - , text "(GHC does not yet support this)" ]) + -> Just (locA l, TcRnVDQInTermType Nothing) | HsForAllInvis{} <- tele -> Just (locA l, nested_foralls_contexts_err) L l (HsQualTy {}) @@ -303,6 +305,7 @@ _ -> Nothing where nested_foralls_contexts_err = + mkTcRnUnknownMessage $ mkPlainError noHints $ what <+> text "cannot contain nested" <+> quotes forAllLit <> text "s or contexts" @@ -310,7 +313,7 @@ addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM () addNoNestedForallsContextsErr ctxt what lty = whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) -> - addErrAt l $ TcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg) + addErrAt l $ TcRnWithHsDocContext ctxt err_msg {- ************************************************************************ @@ -325,11 +328,18 @@ addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside ; return (res, fvs1 `plusFV` fvs2) } -mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) -mapFvRn f xs = do stuff <- mapM f xs - case unzip stuff of - (ys, fvs_s) -> return (ys, plusFVs fvs_s) +mapFvRn :: Traversable f => (a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars) +mapFvRn f xs = do + stuff <- mapM f xs + case unzip stuff of + (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) } @@ -388,7 +398,7 @@ warnRedundantRecordWildcard :: RnM () warnRedundantRecordWildcard = whenWOptM Opt_WarnRedundantRecordWildcards $ - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnRedundantRecordWildcards) noHints redundantWildcardWarning @@ -487,7 +497,7 @@ addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () addUnusedWarning flag occ span msg = do - let diag = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $ + let diag = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $ sep [msg <> colon, nest 2 $ pprNonVarNameSpace (occNameSpace occ) <+> quotes (ppr occ)] @@ -495,7 +505,7 @@ unusedRecordWildcardWarning :: TcRnMessage unusedRecordWildcardWarning = - TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedRecordWildcards) noHints $ + mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedRecordWildcards) noHints $ wildcardDoc $ text "No variables bound in the record wildcard match are used" redundantWildcardWarning :: SDoc @@ -545,7 +555,7 @@ -- already, and we don't want an error cascade. = return () | otherwise - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name) , text "It could refer to" , nest 3 (vcat (msg1 : msgs)) ]) @@ -598,7 +608,7 @@ dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () dupNamesErr get_loc names - = addErrAt big_loc $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrAt big_loc $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)), locations] where @@ -608,19 +618,19 @@ badQualBndrErr :: RdrName -> TcRnMessage badQualBndrErr rdr_name - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Qualified name in binding position:" <+> ppr rdr_name typeAppErr :: String -> LHsType GhcPs -> TcRnMessage typeAppErr what (L _ k) - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Illegal visible" <+> text what <+> text "application" <+> quotes (char '@' <> ppr k)) 2 (text "Perhaps you intended to use TypeApplications") badFieldConErr :: Name -> FieldLabelString -> TcRnMessage badFieldConErr con field - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hsep [text "Constructor" <+> quotes (ppr con), text "does not have field", quotes (ppr field)] @@ -631,7 +641,7 @@ | tup_size <= mAX_TUPLE_SIZE = return () | otherwise - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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")] @@ -642,7 +652,7 @@ | tup_size <= mAX_CTUPLE_SIZE = return () | otherwise - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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") @@ -672,10 +682,40 @@ genHsVar nm = HsVar noExtField $ wrapGenSpan nm genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn -genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan +genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) noHsTok (mkEmptyWildCardBndrs (wrapGenSpan ty)) genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn) genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit) genHsTyLit :: FastString -> HsType GhcRn genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText + +genSimpleConPat :: Name -> [LPat GhcRn] -> LPat GhcRn +-- The pattern (C p1 .. pn) +genSimpleConPat con pats + = wrapGenSpan $ ConPat { pat_con_ext = noExtField + , pat_con = wrapGenSpan con + , pat_args = PrefixCon [] pats } + +genVarPat :: Name -> LPat GhcRn +genVarPat n = wrapGenSpan $ VarPat noExtField (wrapGenSpan n) + +genWildPat :: LPat GhcRn +genWildPat = wrapGenSpan $ WildPat noExtField + +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 + 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_ext = emptyNameSet + } diff --git a/GHC/Runtime/Context.hs b/GHC/Runtime/Context.hs --- a/GHC/Runtime/Context.hs +++ b/GHC/Runtime/Context.hs @@ -10,7 +10,7 @@ , icReaderEnv , icInteractiveModule , icInScopeTTs - , icPrintUnqual + , icNamePprCtx ) where @@ -198,7 +198,7 @@ It would be correct ot re-construct the env from scratch based on -`ic_tythings`, but that'd be quite expensive if there are many entires in +`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 @@ -285,7 +285,7 @@ ic_plugins :: !Plugins -- ^ Cache of loaded plugins. We store them here to avoid having to - -- load them everytime we switch to the interctive context. + -- load them every time we switch to the interactive context. } data InteractiveImport @@ -349,9 +349,10 @@ ] --- | Get the PrintUnqualified function based on the flags and this InteractiveContext -icPrintUnqual :: UnitEnv -> InteractiveContext -> PrintUnqualified -icPrintUnqual unit_env ictxt = mkPrintUnqualified unit_env (icReaderEnv ictxt) +-- | 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) + where ptc = initPromotionTickContext (ic_dflags ictxt) -- | extendInteractiveContext is called with new TyThings recently defined to update the -- InteractiveContext to include them. By putting new things first, unqualified @@ -441,7 +442,7 @@ _ -> False is_sub_bndr _ = False -substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext +substInteractiveContext :: InteractiveContext -> Subst -> InteractiveContext substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst | isEmptyTCvSubst subst = ictxt | otherwise = ictxt { ic_tythings = map subst_ty tts } diff --git a/GHC/Runtime/Debugger.hs b/GHC/Runtime/Debugger.hs --- a/GHC/Runtime/Debugger.hs +++ b/GHC/Runtime/Debugger.hs @@ -49,6 +49,7 @@ import Control.Monad import Control.Monad.Catch as MC import Data.List ( (\\), partition ) +import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.IORef @@ -57,7 +58,7 @@ ------------------------------------- pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m () pprintClosureCommand bindThings force str = do - tythings <- (catMaybes . concat) `liftM` + tythings <- (catMaybes . concatMap NE.toList) `liftM` mapM (\w -> GHC.parseName w >>= mapM GHC.lookupName) (words str) @@ -67,7 +68,7 @@ -- Obtain the terms and the recovered type information let ids = [id | AnId id <- pprintables] - (subst, terms) <- mapAccumLM go emptyTCvSubst ids + (subst, terms) <- mapAccumLM go emptySubst ids -- Apply the substitutions obtained after recovering the types modifySession $ \hsc_env -> @@ -97,11 +98,11 @@ printSDocs :: GhcMonad m => [SDoc] -> m () printSDocs sdocs = do logger <- getLogger - unqual <- GHC.getPrintUnqual - liftIO $ printOutputForUser logger unqual $ vcat sdocs + name_ppr_ctx <- GHC.getNamePprCtx + liftIO $ printOutputForUser logger name_ppr_ctx $ vcat sdocs -- Do the obtainTerm--bindSuspensions-computeSubstitution dance - go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term) + go :: GhcMonad m => Subst -> Id -> m (Subst, Term) go subst id = do let id' = updateIdTypeAndMult (substTy subst) id id_ty' = idType id' @@ -124,7 +125,7 @@ (fsep $ [text "RTTI Improvement for", ppr id, text "old substitution:" , ppr subst, text "new substitution:" , ppr subst']) - ; return (subst `unionTCvSubst` subst', term')} + ; return (subst `unionSubst` subst', term')} tidyTermTyVars :: GhcMonad m => Term -> m Term tidyTermTyVars t = @@ -161,7 +162,7 @@ return t' where --- Processing suspensions. Give names and recopilate info +-- Processing suspensions. Give names and collect info nameSuspensionsAndGetInfos :: HscEnv -> IORef [String] -> TermFold (IO (Term, [(Name,Type,ForeignHValue)])) nameSuspensionsAndGetInfos hsc_env freeNames = TermFold diff --git a/GHC/Runtime/Eval.hs b/GHC/Runtime/Eval.hs --- a/GHC/Runtime/Eval.hs +++ b/GHC/Runtime/Eval.hs @@ -62,17 +62,16 @@ import GHCi.RemoteTypes import GHC.ByteCode.Types -import GHC.Linker.Types import GHC.Linker.Loader as Loader import GHC.Hs import GHC.Core.Predicate import GHC.Core.InstEnv -import GHC.Core.FamInstEnv ( FamInst ) -import GHC.Core.FVs ( orphNamesOfFamInst ) +import GHC.Core.FamInstEnv ( FamInst, orphNamesOfFamInst ) 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 ) @@ -92,7 +91,6 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Logger -import GHC.Utils.Trace import GHC.Types.RepType import GHC.Types.Fixity.Env @@ -122,6 +120,7 @@ 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 @@ -629,10 +628,10 @@ = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id) ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) } - newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst + newTyVars :: UniqSupply -> [TcTyVar] -> Subst -- Similarly, clone the type variables mentioned in the types -- we have here, *and* make them all RuntimeUnk tyvars - newTyVars us tvs = foldl' new_tv emptyTCvSubst (tvs `zip` uniqsFromSupply us) + newTyVars us tvs = foldl' new_tv emptySubst (tvs `zip` uniqsFromSupply us) new_tv subst (tv,uniq) = extendTCvSubstWithClone subst tv new_tv where new_tv = mkRuntimeUnkTyVar (setNameUnique (tyVarName tv) uniq) @@ -678,9 +677,12 @@ Nothing -> return hsc_env Just new_ty -> do case improveRTTIType hsc_env old_ty new_ty of - Nothing -> return $ - warnPprTrace True (":print failed to calculate the " - ++ "improvement for a type") empty hsc_env + Nothing -> warnPprTrace True (":print failed to calculate the " + ++ "improvement for a type") + (vcat [ text "id" <+> ppr id + , text "old_ty" <+> debugPprType old_ty + , text "new_ty" <+> debugPprType new_ty ]) $ + return hsc_env Just subst -> do let logger = hsc_logger hsc_env putDumpFileMaybe logger Opt_D_dump_rtti "RTTI" @@ -713,7 +715,7 @@ There are 3 situations where items are removed from the Id list (or replaced with `Nothing`): 1.) If function `GHC.StgToByteCode.schemeER_wrk` (which creates - the Id list) doesn't find an Id in the ByteCode environement. + the Id list) doesn't find an Id in the ByteCode environment. 2.) If function `GHC.Runtime.Eval.bindLocalsAtBreakpoint` filters out unboxed elements from the Id list, because GHCi cannot yet handle them. @@ -857,7 +859,7 @@ _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 clases resp) +-- Filter the instances by the ones whose tycons (or classes resp) -- are in scope (qualified or otherwise). Otherwise we list a whole lot too many! -- The exact choice of which ones to show, and which to hide, is a judgement call. -- (see #1581) @@ -909,7 +911,7 @@ -- | Parses a string as an identifier, and returns the list of 'Name's that -- the identifier can refer to in the current interactive context. -parseName :: GhcMonad m => String -> m [Name] +parseName :: GhcMonad m => String -> m (NonEmpty Name) parseName str = withSession $ \hsc_env -> liftIO $ do { lrdr_name <- hscParseIdentifier hsc_env str ; hscTcRnLookupRdrName hsc_env lrdr_name } @@ -993,7 +995,7 @@ {- Note [Querying instances for a type] - + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is the implementation of GHC proposal 41. (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst) @@ -1058,7 +1060,7 @@ -- Get all the constraints required of a dictionary binding getDictionaryBindings :: PredType -> TcM CtEvidence getDictionaryBindings theta = do - dictName <- newName (mkDictOcc (mkVarOcc "magic")) + dictName <- newName (mkDictOcc (mkVarOccFS (fsLit "magic"))) let dict_var = mkVanillaGlobal dictName theta loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing @@ -1081,8 +1083,8 @@ k -> Constraint where k is the type of the queried type. -} try_cls ies cls - | Just (_, arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls) - , tcIsConstraintKind res_kind + | Just (_, _, arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls) + , isConstraintKind res_kind , Type.typeKind ty `eqType` arg_kind , (matches, _, _) <- lookupInstEnv True ies cls [ty] = matches @@ -1154,7 +1156,7 @@ Just (_, tys@(_:_)) -> all isTyVarTy tys _ -> isTyVarTy ty - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun clsInst))) + empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun clsInst))) {- Create a ClsInst with instantiated arguments and constraints. @@ -1250,17 +1252,18 @@ showModule :: GhcMonad m => ModSummary -> m String showModule mod_summary = withSession $ \hsc_env -> do - interpreted <- moduleIsBootOrNotObjectLinkable mod_summary 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)) moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env -> - case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of + case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of Nothing -> panic "missing linkable" - Just mod_info -> return $ case hm_linkable mod_info of - Nothing -> True - Just linkable -> not (isObjectLinkable linkable) + Just mod_info -> return . isNothing $ homeModInfoByteCode mod_info ---------------------------------------------------------------------------- -- RTTI primitives 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 @@ -23,7 +23,7 @@ constrClosToName -- exported to use in test T4891 ) where -import GHC.Prelude +import GHC.Prelude hiding (head, init, last, tail) import GHC.Platform import GHC.Runtime.Interpreter as GHCi @@ -36,7 +36,8 @@ import GHC.Types.RepType import GHC.Core.Multiplicity import qualified GHC.Core.Unify as U -import GHC.Types.Var +import GHC.Core.TyCon + import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType @@ -44,7 +45,7 @@ import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Env -import GHC.Core.TyCon +import GHC.Types.Var import GHC.Types.Name import GHC.Types.Name.Occurrence as OccName import GHC.Unit.Module @@ -67,6 +68,8 @@ import Control.Monad import Data.Maybe import Data.List ((\\)) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import GHC.Exts import qualified Data.Sequence as Seq import Data.Sequence (viewl, ViewL(..)) @@ -431,13 +434,14 @@ --Note pprinting of list terms is not lazy ppr_list :: Precedence -> Term -> m SDoc ppr_list p (Term{subTerms=[h,t]}) = do - let elems = h : getListTerms t - isConsLast = not (termType (last elems) `eqType` termType h) + let elems = h :| getListTerms t + elemList = toList elems + isConsLast = not (termType (NE.last elems) `eqType` termType h) is_string = all (isCharTy . ty) elems chars = [ chr (fromIntegral w) - | Term{subTerms=[Prim{valRaw=[w]}]} <- elems ] + | Term{subTerms=[Prim{valRaw=[w]}]} <- elemList ] - print_elems <- mapM (y cons_prec) elems + print_elems <- mapM (y cons_prec) elemList if is_string then return (Ppr.doubleQuotes (Ppr.text chars)) else if isConsLast @@ -637,7 +641,7 @@ -} -instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar]) +instTyVars :: [TyVar] -> TR (Subst, [TcTyVar]) -- Instantiate fresh mutable type variables from some TyVars -- This function preserves the print-name, which helps error messages instTyVars tvs @@ -672,7 +676,7 @@ where do_pair (tc_tv, rtti_tv) = do { tc_ty <- zonkTcTyVar tc_tv - ; case tcGetTyVar_maybe tc_ty of + ; case getTyVar_maybe tc_ty of Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv) _ -> return () } @@ -745,10 +749,13 @@ -- we have unsound types. Replace constructor types in -- subterms with tyvars zterm' <- mapTermTypeM - (\ty -> case tcSplitTyConApp_maybe ty of - Just (tc, _:_) | tc /= funTyCon - -> newOpenVar - _ -> return ty) + (\ty -> case splitTyConApp_maybe ty of + -- SPJ: I have no idea why we are + -- matching on (:) here, nor + -- what the isFunTy is for + Just (_tc, _ : _) | not (isFunTy ty) + -> newOpenVar + _ -> return ty) term zonkTerm zterm' traceTR (text "Term reconstruction completed." $$ @@ -781,7 +788,7 @@ EvalSuccess _ -> go (pred max_depth) my_ty old_ty a EvalException ex -> do -- Report the exception to the UI - traceTR $ text "Exception occured:" <+> text (show ex) + traceTR $ text "Exception occurred:" <+> text (show ex) liftIO $ throwIO $ fromSerializableException ex -- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. If -- the indirection is a TSO or BLOCKING_QUEUE, we return the BLACKHOLE itself as @@ -836,7 +843,7 @@ Nothing -> do -- This can happen for private constructors compiled -O0 -- where the .hi descriptor does not export them -- In such case, we return a best approximation: - -- ignore the unpointed args, and recover the pointeds + -- ignore the unpointed args, and recover the pointed ones -- This preserves laziness, and should be safe. traceTR (text "Not constructor" <+> ppr dcname) let dflags = hsc_dflags hsc_env @@ -1101,7 +1108,7 @@ -- improveType -- 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 TCvSubst +improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe Subst improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty getDataConArgTys :: DataCon -> Type -> TR [Type] @@ -1219,7 +1226,7 @@ ~~~~~~~~~~~ Consider a function obtainType that takes a value and a type and produces the Term representation and a substitution (the improvement). -Assume an auxiliar rtti' function which does the actual job if recovering +Assume an auxiliary rtti' function which does the actual job if recovering the type, but which may produce a false type. In pseudocode: @@ -1343,12 +1350,13 @@ ppr tv, equals, ppr ty_v] go ty_v r -- FunTy inductive case - | Just (w1,l1,l2) <- splitFunTy_maybe l - , Just (w2,r1,r2) <- splitFunTy_maybe r + | Just (af1,w1,l1,l2) <- splitFunTy_maybe l + , Just (af2,w2,r1,r2) <- splitFunTy_maybe r + , af1==af2 , w1 `eqType` w2 = do r2' <- go l2 r2 r1' <- go l1 r1 - return (mkVisFunTy w1 r1' r2') + return (mkFunTy af1 w1 r1' r2') -- TyconApp Inductive case; this is the interesting bit. | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs @@ -1413,7 +1421,7 @@ , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args , tyv `notElem` phantom_vars] = all isMonomorphicOnNonPhantomArgs concrete_args - | Just (_, ty1, ty2) <- splitFunTy_maybe ty + | Just (_, _, ty1, ty2) <- splitFunTy_maybe ty = all isMonomorphicOnNonPhantomArgs [ty1,ty2] | otherwise = isMonomorphic ty diff --git a/GHC/Runtime/Interpreter.hs b/GHC/Runtime/Interpreter.hs --- a/GHC/Runtime/Interpreter.hs +++ b/GHC/Runtime/Interpreter.hs @@ -113,6 +113,11 @@ #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 @@ -195,7 +200,7 @@ InternalInterp -> run msg -- Just run it directly #endif ExternalInterp c i -> withIServ_ c i $ \iserv -> - uninterruptibleMask_ $ -- Note [uninterruptibleMask_] + uninterruptibleMask_ $ -- Note [uninterruptibleMask_ and interpCmd] iservCall iserv msg @@ -606,7 +611,9 @@ foreign import ccall unsafe "io.h _get_osfhandle" _get_osfhandle :: CInt -> IO CInt -runWithPipes createProc prog opts = do +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 @@ -619,6 +626,27 @@ 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 @@ -724,7 +752,7 @@ getModBreaks :: HomeModInfo -> ModBreaks getModBreaks hmi - | Just linkable <- hm_linkable hmi, + | Just linkable <- homeModInfoByteCode hmi, [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked linkable = fromMaybe emptyModBreaks (bc_breaks cbc) | otherwise diff --git a/GHC/Runtime/Loader.hs b/GHC/Runtime/Loader.hs --- a/GHC/Runtime/Loader.hs +++ b/GHC/Runtime/Loader.hs @@ -2,7 +2,7 @@ -- | Dynamically lookup up values from modules and loading them. module GHC.Runtime.Loader ( - initializePlugins, + initializePlugins, initializeSessionPlugins, -- * Loading plugins loadFrontendPlugin, @@ -21,11 +21,13 @@ ) where import GHC.Prelude +import GHC.Data.FastString import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Hooks import GHC.Driver.Plugins +import GHC.Driver.Plugins.External import GHC.Linker.Loader ( loadModule, loadName ) import GHC.Runtime.Interpreter ( wormhole ) @@ -37,15 +39,16 @@ import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName ) import GHC.Driver.Env -import GHCi.RemoteTypes ( HValue ) -import GHC.Core.Type ( Type, eqType, mkTyConTy ) -import GHC.Core.TyCon ( TyCon ) +import GHCi.RemoteTypes ( HValue ) +import GHC.Core.Type ( Type, mkTyConTy ) +import GHC.Core.TyCo.Compare( eqType ) +import GHC.Core.TyCon ( TyCon ) import GHC.Types.SrcLoc ( noSrcSpan ) import GHC.Types.Name ( Name, nameModule_maybe ) import GHC.Types.Id ( idType ) import GHC.Types.TyThing -import GHC.Types.Name.Occurrence ( OccName, mkVarOcc ) +import GHC.Types.Name.Occurrence ( OccName, mkVarOccFS ) import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..) , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName , greMangledName, mkRdrQual ) @@ -68,29 +71,60 @@ import GHC.Linker.Types import GHC.Types.Unique.DFM import Data.List (unzip4) +import GHC.Driver.Monad +-- | Initialise plugins specified by the current DynFlags and update the session. +initializeSessionPlugins :: GhcMonad m => m () +initializeSessionPlugins = getSession >>= liftIO . initializePlugins >>= setSession + -- | Loads the plugins specified in the pluginModNames field of the dynamic -- flags. Should be called after command line arguments are parsed, but before -- actual compilation starts. Idempotent operation. Should be re-called if -- pluginModNames or pluginModNameOpts changes. initializePlugins :: HscEnv -> IO HscEnv initializePlugins hsc_env - -- plugins not changed + -- check that plugin specifications didn't change + + -- dynamic plugins | loaded_plugins <- loadedPlugins (hsc_plugins hsc_env) , map lpModuleName loaded_plugins == reverse (pluginModNames dflags) - -- arguments not changed , all same_args loaded_plugins - = return hsc_env -- no need to reload plugins FIXME: doesn't take static plugins into account + + -- external plugins + , external_plugins <- externalPlugins (hsc_plugins hsc_env) + , check_external_plugins external_plugins (externalPluginSpecs dflags) + + -- FIXME: we should check static plugins too + + = return hsc_env -- no change, no need to reload plugins + | otherwise = do (loaded_plugins, links, pkgs) <- loadPlugins hsc_env - let plugins' = (hsc_plugins hsc_env) { loadedPlugins = loaded_plugins, loadedPluginDeps = (links, pkgs) } + external_plugins <- loadExternalPlugins (externalPluginSpecs dflags) + let plugins' = (hsc_plugins hsc_env) { staticPlugins = staticPlugins (hsc_plugins hsc_env) + , externalPlugins = external_plugins + , loadedPlugins = loaded_plugins + , loadedPluginDeps = (links, pkgs) + } let hsc_env' = hsc_env { hsc_plugins = plugins' } withPlugins (hsc_plugins hsc_env') driverPlugin hsc_env' where + dflags = hsc_dflags hsc_env + -- dynamic plugins plugin_args = pluginModNameOpts dflags same_args p = paArguments (lpPlugin p) == argumentsForPlugin p plugin_args argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst) - dflags = hsc_dflags hsc_env + -- external plugins + check_external_plugin p spec = and + [ epUnit p == esp_unit_id spec + , epModule p == esp_module spec + , paArguments (epPlugin p) == esp_args spec + ] + check_external_plugins eps specs = case (eps,specs) of + ([] , []) -> True + (_ , []) -> False -- some external plugin removed + ([] , _ ) -> False -- some external plugin added + (p:ps,s:ss) -> check_external_plugin p s && check_external_plugins ps ss loadPlugins :: HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded) loadPlugins hsc_env @@ -109,14 +143,14 @@ where options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags , opt_mod_nm == mod_nm ] - loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env + loadPlugin = loadPlugin' (mkVarOccFS (fsLit "plugin")) pluginTyConName hsc_env loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded) loadFrontendPlugin hsc_env mod_name = do checkExternalInterpreter hsc_env (plugin, _iface, links, pkgs) - <- loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName + <- loadPlugin' (mkVarOccFS (fsLit "frontendPlugin")) frontendPluginTyConName hsc_env mod_name return (plugin, links, pkgs) diff --git a/GHC/Settings.hs b/GHC/Settings.hs --- a/GHC/Settings.hs +++ b/GHC/Settings.hs @@ -18,7 +18,6 @@ , sTopDir , sGlobalPackageDatabasePath , sLdSupportsCompactUnwind - , sLdSupportsBuildId , sLdSupportsFilelist , sLdIsGnuLd , sGccSupportsNoPie @@ -35,7 +34,6 @@ , sPgm_dll , sPgm_T , sPgm_windres - , sPgm_libtool , sPgm_ar , sPgm_otool , sPgm_install_name_tool @@ -88,7 +86,6 @@ -- platform-specific and platform-agnostic. data ToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind :: Bool - , toolSettings_ldSupportsBuildId :: Bool , toolSettings_ldSupportsFilelist :: Bool , toolSettings_ldIsGnuLd :: Bool , toolSettings_ccSupportsNoPie :: Bool @@ -110,7 +107,6 @@ , toolSettings_pgm_dll :: (String, [Option]) , toolSettings_pgm_T :: String , toolSettings_pgm_windres :: String - , toolSettings_pgm_libtool :: String , toolSettings_pgm_ar :: String , toolSettings_pgm_otool :: String , toolSettings_pgm_install_name_tool :: String @@ -171,7 +167,7 @@ dynLibSuffix (GhcNameVersion name ver) = '-':name ++ ver ----------------------------------------------------------------------------- --- Accessessors from 'Settings' +-- Accessors from 'Settings' sProgramName :: Settings -> String sProgramName = ghcNameVersion_programName . sGhcNameVersion @@ -191,8 +187,6 @@ sLdSupportsCompactUnwind :: Settings -> Bool sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings -sLdSupportsBuildId :: Settings -> Bool -sLdSupportsBuildId = toolSettings_ldSupportsBuildId . sToolSettings sLdSupportsFilelist :: Settings -> Bool sLdSupportsFilelist = toolSettings_ldSupportsFilelist . sToolSettings sLdIsGnuLd :: Settings -> Bool @@ -226,8 +220,6 @@ sPgm_T = toolSettings_pgm_T . sToolSettings sPgm_windres :: Settings -> String sPgm_windres = toolSettings_pgm_windres . sToolSettings -sPgm_libtool :: Settings -> String -sPgm_libtool = toolSettings_pgm_libtool . sToolSettings sPgm_ar :: Settings -> String sPgm_ar = toolSettings_pgm_ar . sToolSettings sPgm_otool :: Settings -> String diff --git a/GHC/Settings/Constants.hs b/GHC/Settings/Constants.hs --- a/GHC/Settings/Constants.hs +++ b/GHC/Settings/Constants.hs @@ -17,8 +17,8 @@ mAX_CTUPLE_SIZE :: Int -- Constraint tuples mAX_CTUPLE_SIZE = 64 -- Should match the number of decls in GHC.Classes -mAX_SUM_SIZE :: Int -mAX_SUM_SIZE = 64 +mAX_SUM_SIZE :: Int -- We use 6 bits to record sum size, +mAX_SUM_SIZE = 63 -- so max sum size is 63. Sadly inconsistent. -- | Default maximum depth for both class instance search and type family -- reduction. See also #5395. diff --git a/GHC/Settings/IO.hs b/GHC/Settings/IO.hs --- a/GHC/Settings/IO.hs +++ b/GHC/Settings/IO.hs @@ -94,7 +94,6 @@ cc_args = words cc_args_str ++ unreg_cc_args cxx_args = words cxx_args_str ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" - ldSupportsBuildId <- getBooleanSetting "ld supports build-id" ldSupportsFilelist <- getBooleanSetting "ld supports filelist" ldIsGnuLd <- getBooleanSetting "ld is GNU ld" arSupportsDashL <- getBooleanSetting "ar supports -L" @@ -108,7 +107,6 @@ unlit_path <- getToolSetting "unlit command" windres_path <- getToolSetting "windres command" - libtool_path <- getToolSetting "libtool command" ar_path <- getToolSetting "ar command" otool_path <- getToolSetting "otool command" install_name_tool_path <- getToolSetting "install_name_tool command" @@ -164,7 +162,6 @@ , sToolSettings = ToolSettings { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind - , toolSettings_ldSupportsBuildId = ldSupportsBuildId , toolSettings_ldSupportsFilelist = ldSupportsFilelist , toolSettings_ldIsGnuLd = ldIsGnuLd , toolSettings_ccSupportsNoPie = gccSupportsNoPie @@ -182,7 +179,6 @@ , toolSettings_pgm_dll = (mkdll_prog,mkdll_args) , toolSettings_pgm_T = touch_path , toolSettings_pgm_windres = windres_path - , toolSettings_pgm_libtool = libtool_path , toolSettings_pgm_ar = ar_path , toolSettings_pgm_otool = otool_path , toolSettings_pgm_install_name_tool = install_name_tool_path diff --git a/GHC/Stg/BcPrep.hs b/GHC/Stg/BcPrep.hs --- a/GHC/Stg/BcPrep.hs +++ b/GHC/Stg/BcPrep.hs @@ -144,7 +144,7 @@ newId :: Type -> BcPrepM Id newId ty = do uniq <- newUnique - return $ mkSysLocal prepFS uniq Many ty + return $ mkSysLocal prepFS uniq ManyTy ty prepFS :: FastString prepFS = fsLit "bcprep" diff --git a/GHC/Stg/CSE.hs b/GHC/Stg/CSE.hs --- a/GHC/Stg/CSE.hs +++ b/GHC/Stg/CSE.hs @@ -117,6 +117,11 @@ , sam_lit :: LiteralMap a } +-- TODO(22292): derive +instance Functor StgArgMap where + fmap f SAM { sam_var = varm, sam_lit = litm } = SAM + { sam_var = fmap f varm, sam_lit = fmap f litm } + instance TrieMap StgArgMap where type Key StgArgMap = StgArg emptyTM = SAM { sam_var = emptyTM @@ -126,13 +131,16 @@ alterTM (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f } alterTM (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f } foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m) - mapTM f (SAM {sam_var = varm, sam_lit = litm}) = - SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm } filterTM f (SAM {sam_var = varm, sam_lit = litm}) = SAM { sam_var = filterTM f varm, sam_lit = filterTM f litm } newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) } +-- TODO(22292): derive +instance Functor ConAppMap where + fmap f = CAM . fmap (fmap f) . un_cam + {-# INLINE fmap #-} + instance TrieMap ConAppMap where type Key ConAppMap = (DataCon, [StgArg]) emptyTM = CAM emptyTM @@ -140,8 +148,7 @@ alterTM (dataCon, args) f m = m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f } foldTM k = un_cam >.> foldTM (foldTM k) - mapTM f = un_cam >.> mapTM (mapTM f) >.> CAM - filterTM f = un_cam >.> mapTM (filterTM f) >.> CAM + filterTM f = un_cam >.> fmap (filterTM f) >.> CAM ----------------- -- The CSE Env -- diff --git a/GHC/Stg/Debug.hs b/GHC/Stg/Debug.hs --- a/GHC/Stg/Debug.hs +++ b/GHC/Stg/Debug.hs @@ -252,7 +252,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the old times, each usage of a data constructor used the same info table. -This made it impossible to distinguish which actual usuage of a data constructor was +This made it impossible to distinguish which actual usage of a data constructor was contributing primarily to the allocation in a program. Using the `-fdistinct-info-tables` flag you can cause code generation to generate a distinct info table for each usage of a constructor. Then, when inspecting the heap you can see precisely which usage of a constructor diff --git a/GHC/Stg/InferTags.hs b/GHC/Stg/InferTags.hs --- a/GHC/Stg/InferTags.hs +++ b/GHC/Stg/InferTags.hs @@ -183,7 +183,7 @@ 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 rigourous in dealing with functions. +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. @@ -212,7 +212,7 @@ 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. + 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 @@ -602,7 +602,7 @@ let f z = case z of z' -> (# c, x #) Here we will infer for f the Signature . -This information will be used if we scrutinze a saturated application of +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` diff --git a/GHC/Stg/InferTags/Rewrite.hs b/GHC/Stg/InferTags/Rewrite.hs --- a/GHC/Stg/InferTags/Rewrite.hs +++ b/GHC/Stg/InferTags/Rewrite.hs @@ -20,26 +20,29 @@ 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.Unit.Types (Module, isInteractiveModule) +import GHC.Types.Var.Set +import GHC.Unit.Types import GHC.Core.DataCon -import GHC.Core (AltCon(..) ) +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.Panic.Plain import GHC.Utils.Outputable import GHC.Utils.Monad.State.Strict @@ -48,10 +51,6 @@ import GHC.Stg.InferTags.Types import Control.Monad -import GHC.Types.Basic (CbvMark (NotMarkedCbv, MarkedCbv), isMarkedCbv, TopLevelFlag(..), isTopLevel) -import GHC.Types.Var.Set --- import GHC.Utils.Trace --- import GHC.Driver.Ppr newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) } deriving (Functor, Monad, Applicative) @@ -89,12 +88,12 @@ $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 *undersatured* in the wrapper. +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 enfore the invariant that +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. @@ -129,7 +128,7 @@ getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get) setMap :: (UniqFM Id TagSig) -> RM () -setMap m = RM $ do +setMap !m = RM $ do (_,us,mod,lcls) <- get put (m, us,mod,lcls) @@ -140,7 +139,7 @@ getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get) setFVs :: IdSet -> RM () -setFVs fvs = RM $ do +setFVs !fvs = RM $ do (tag_map,us,mod,_lcls) <- get put (tag_map, us,mod,fvs) @@ -196,9 +195,9 @@ withClosureLcls :: DIdSet -> RM a -> RM a withClosureLcls fvs act = do old_fvs <- getFVs - let fvs' = nonDetStrictFoldDVarSet (flip extendVarSet) old_fvs fvs + let !fvs' = nonDetStrictFoldDVarSet (flip extendVarSet) old_fvs fvs setFVs fvs' - r <- act + !r <- act setFVs old_fvs return r @@ -207,9 +206,9 @@ withLcl :: Id -> RM a -> RM a withLcl fv act = do old_fvs <- getFVs - let fvs' = extendVarSet old_fvs fv + let !fvs' = extendVarSet old_fvs fv setFVs fvs' - r <- act + !r <- act setFVs old_fvs return r @@ -217,7 +216,8 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 tag inference at the end. +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. @@ -257,7 +257,9 @@ (TagSig TagDunno) case nameIsLocalOrFrom this_mod (idName v) of True - | isUnliftedType (idType v) + | 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 @@ -270,10 +272,13 @@ TagTagged -> True TagTuple _ -> True -- Consider unboxed tuples tagged. False -- Imported + | Just con <- (isDataConWorkId_maybe v) + , isNullaryRepDataCon con + -> return True + | Just lf_info <- idLFInfo_maybe v -> return $! - -- Determine whether it is tagged from the LFInfo of the imported id. - -- See Note [The LFInfo of Imported Ids] - case mkLFImported v of + -- Can we treat the thing as tagged based on it's LFInfo? + case lf_info of -- Function, applied not entered. LFReEntrant {} -> True @@ -291,7 +296,10 @@ -- Shouldn't be possible. I don't think we can export letNoEscapes -> True + | otherwise + -> return False + isArgTagged :: StgArg -> RM Bool isArgTagged (StgLitArg _) = return True isArgTagged (StgVarArg v) = isTagged v @@ -366,14 +374,11 @@ 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) + return $! (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) rewriteRhs _binding (StgRhsClosure fvs ccs flag args body) = do withBinders NotTopLevel args $ withClosureLcls fvs $ - StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr False body + StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr body -- return (closure) fvArgs :: [StgArg] -> RM DVarSet @@ -382,24 +387,36 @@ -- 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] -type IsScrut = Bool +rewriteArgs :: [StgArg] -> RM [StgArg] +rewriteArgs = mapM rewriteArg +rewriteArg :: StgArg -> RM StgArg +rewriteArg (StgVarArg v) = StgVarArg <$!> rewriteId v +rewriteArg (lit@StgLitArg{}) = return lit -rewriteExpr :: IsScrut -> InferStgExpr -> RM TgStgExpr -rewriteExpr _ (e@StgCase {}) = rewriteCase e -rewriteExpr _ (e@StgLet {}) = rewriteLet e -rewriteExpr _ (e@StgLetNoEscape {}) = rewriteLetNoEscape e -rewriteExpr isScrut (StgTick t e) = StgTick t <$!> rewriteExpr isScrut e -rewriteExpr _ e@(StgConApp {}) = rewriteConApp e +rewriteId :: Id -> RM Id +rewriteId v = do + !is_tagged <- isTagged v + if is_tagged then return $! setIdTagSig v (TagSig TagProper) + else return v -rewriteExpr isScrut e@(StgApp {}) = rewriteApp isScrut e -rewriteExpr _ (StgLit lit) = return $! (StgLit lit) -rewriteExpr _ (StgOpApp op args res_ty) = return $! (StgOpApp op args res_ty) +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 True scrut <*> + rewriteExpr scrut <*> pure (fst bndr) <*> pure alt_type <*> mapM rewriteAlt alts @@ -409,7 +426,7 @@ rewriteAlt :: InferStgAlt -> RM TgStgAlt rewriteAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} = withBinders NotTopLevel bndrs $ do - !rhs' <- rewriteExpr False rhs + !rhs' <- rewriteExpr rhs return $! alt {alt_bndrs = map fst bndrs, alt_rhs = rhs'} rewriteLet :: InferStgExpr -> RM TgStgExpr @@ -417,7 +434,7 @@ (!bind') <- rewriteBinds NotTopLevel bind withBind NotTopLevel bind $ do -- pprTraceM "withBindLet" (ppr $ bindersOfX bind) - !expr' <- rewriteExpr False expr + !expr' <- rewriteExpr expr return $! (StgLet xt bind' expr') rewriteLet _ = panic "Impossible" @@ -425,7 +442,7 @@ rewriteLetNoEscape (StgLetNoEscape xt bind expr) = do (!bind') <- rewriteBinds NotTopLevel bind withBind NotTopLevel bind $ do - !expr' <- rewriteExpr False expr + !expr' <- rewriteExpr expr return $! (StgLetNoEscape xt bind' expr') rewriteLetNoEscape _ = panic "Impossible" @@ -445,24 +462,18 @@ rewriteConApp _ = panic "Impossible" --- Special case: Expressions like `case x of { ... }` -rewriteApp :: IsScrut -> InferStgExpr -> RM TgStgExpr -rewriteApp True (StgApp f []) = do - -- pprTraceM "rewriteAppScrut" (ppr f) - f_tagged <- isTagged f - -- isTagged looks at more than the result of our analysis. - -- So always update here if useful. - let f' = if f_tagged - then setIdTagSig f (TagSig TagProper) - else f +-- 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) +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 - = assert (length relevant_marks <= length args) + = assertPpr (length relevant_marks <= length args) (ppr f $$ ppr args $$ ppr relevant_marks) unliftArg relevant_marks where @@ -477,8 +488,8 @@ 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" +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 @@ -517,14 +528,20 @@ -- Out of all arguments passed at runtime only return these ending up in a -- strict field -getStrictConArgs :: DataCon -> [a] -> [a] +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 - (dataConRuntimeRepStrictness con)] + repStrictness] + where + repStrictness = (dataConRuntimeRepStrictness con) 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 @@ -326,7 +326,7 @@ rhsCard :: Id -> Card rhsCard bndr | is_thunk = oneifyCard n - | otherwise = fst (peelManyCalls (idArity bndr) cd) + | otherwise = n `multCard` (fst $ peelManyCalls (idArity bndr) cd) where is_thunk = idArity bndr == 0 -- Let's pray idDemandInfo is still OK after unarise... 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 @@ -276,13 +276,13 @@ withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a withLiftedBndr abs_ids bndr inner = do uniq <- getUniqueM - let str = "$l" ++ occNameString (getOccName bndr) + let str = fsLit "$l" `appendFS` occNameFS (getOccName bndr) let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr) let bndr' -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least -- for arity information. = transferPolyIdInfo bndr (dVarSetElems abs_ids) - . mkSysLocal (mkFastString str) uniq Many + . mkSysLocal str uniq ManyTy $ ty LiftM $ RWS.local (\e -> e diff --git a/GHC/Stg/Lint.hs b/GHC/Stg/Lint.hs --- a/GHC/Stg/Lint.hs +++ b/GHC/Stg/Lint.hs @@ -6,7 +6,7 @@ - Variables should be defined before used. - Let bindings should not have unboxed types (unboxed bindings should only - appear in case), except when they're join points (see Note [Core let/app + appear in case), except when they're join points (see Note [Core let-can-float invariant] and #14117). - If linting after unarisation, invariants listed in Note [Post-unarisation @@ -77,8 +77,8 @@ More precisely, if f :: ty1 -> ty2, then in the application (f e) where e :: ty1', we must have kind(ty1) = kind(ty1'). -So the STG type system does not distinguish beteen Int and Bool, -but it /does/ distinguish beteen Int and Int#, because they have +So the STG type system does not distinguish between Int and Bool, +but it /does/ distinguish between Int and Int#, because they have different kinds. Actually, since all terms have kind (TYPE rep), we might say that the STG language is well-runtime-rep'd. @@ -101,7 +101,6 @@ import GHC.Stg.Syntax import GHC.Stg.Utils -import GHC.Core.Lint ( interactiveInScope ) import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) import GHC.Core.Type @@ -121,11 +120,9 @@ import qualified GHC.Utils.Error as Err import GHC.Unit.Module ( Module ) -import GHC.Runtime.Context ( InteractiveContext ) import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) -import Control.Applicative ((<|>)) import Control.Monad import Data.Maybe import GHC.Utils.Misc @@ -139,14 +136,14 @@ -> Logger -> DiagOpts -> StgPprOpts - -> InteractiveContext + -> [Var] -- ^ extra vars in scope from GHCi -> Module -- ^ module being compiled -> Bool -- ^ have we run Unarise yet? -> String -- ^ who produced the STG? -> [GenStgTopBinding a] -> IO () -lintStgTopBindings platform logger diag_opts opts ictxt this_mod unarised whodunnit binds +lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised whodunit binds = {-# SCC "StgLint" #-} case initL platform diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of Nothing -> @@ -155,7 +152,7 @@ logMsg logger Err.MCDump noSrcSpan $ withPprStyle defaultDumpStyle (vcat [ text "*** Stg Lint ErrMsgs: in" <+> - text whodunnit <+> text "***", + text whodunit <+> text "***", msg, text "*** Offending Program ***", pprGenStgTopBindings opts binds, @@ -165,7 +162,7 @@ -- Bring all top-level binds into scope because CoreToStg does not generate -- bindings in dependency order (so we may see a use before its definition). top_level_binds = extendVarSetList (mkVarSet (bindersOfTopBinds binds)) - (interactiveInScope ictxt) + extra_vars lint_binds :: [GenStgTopBinding a] -> LintM () @@ -261,18 +258,21 @@ lintStgExpr e@(StgApp fun args) = do lintStgVar fun mapM_ lintStgArg args - lintAppCbvMarks e lintStgAppReps fun args + + lintStgExpr app@(StgConApp con _n args _arg_tys) = do -- unboxed sums should vanish during unarise lf <- getLintFlags - opts <- getStgPprOpts - when (lf_unarised lf && isUnboxedSumDataCon con) $ do + let !unarised = lf_unarised lf + when (unarised && isUnboxedSumDataCon con) $ do + opts <- getStgPprOpts addErrL (text "Unboxed sum after unarise:" $$ pprStgExpr opts app) + opts <- getStgPprOpts lintConApp con args (pprStgExpr opts app) mapM_ lintStgArg args @@ -524,15 +524,13 @@ -- Post-unarisation args and case alt binders should not have unboxed tuple, -- unboxed sum, or void types. Return what the binder is if it is one of these. checkPostUnariseId :: Id -> Maybe String -checkPostUnariseId id = - let - id_ty = idType id - is_sum, is_tuple, is_void :: Maybe String - is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum" - is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple" - is_void = guard (isZeroBitTy id_ty) >> return "void" - in - is_sum <|> is_tuple <|> is_void +checkPostUnariseId id + | isUnboxedSumType id_ty = Just "unboxed sum" + | isUnboxedTupleType id_ty = Just "unboxed tuple" + | isZeroBitTy id_ty = Just "void" + | otherwise = Nothing + where + id_ty = idType id addErrL :: SDoc -> LintM () addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc) @@ -542,7 +540,7 @@ = errs_so_far `snocBag` mk_msg locs where mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag) + in mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) l (hdr $$ msg) mk_msg [] = msg diff --git a/GHC/Stg/Pipeline.hs b/GHC/Stg/Pipeline.hs --- a/GHC/Stg/Pipeline.hs +++ b/GHC/Stg/Pipeline.hs @@ -18,6 +18,8 @@ import GHC.Prelude +import GHC.Driver.Flags + import GHC.Stg.Syntax import GHC.Stg.Lint ( lintStgTopBindings ) @@ -28,10 +30,9 @@ import GHC.Stg.CSE ( stgCse ) import GHC.Stg.Lift ( StgLiftConfig, stgLiftLams ) import GHC.Unit.Module ( Module ) -import GHC.Runtime.Context ( InteractiveContext ) -import GHC.Driver.Flags (DumpFlag(..)) import GHC.Utils.Error +import GHC.Types.Var import GHC.Types.Unique.Supply import GHC.Utils.Outputable import GHC.Utils.Logger @@ -70,12 +71,12 @@ runStgM mask (StgM m) = runReaderT m mask stg2stg :: Logger - -> InteractiveContext + -> [Var] -- ^ extra vars in scope from GHCi -> StgPipelineOpts - -> Module -- module being compiled - -> [StgTopBinding] -- input program + -> Module -- ^ module being compiled + -> [StgTopBinding] -- ^ input program -> IO ([CgStgTopBinding], StgCgInfos) -- output program -stg2stg logger ictxt opts this_mod binds +stg2stg logger extra_vars opts this_mod binds = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds ; showPass logger "Stg2Stg" -- Do the main business! @@ -103,9 +104,9 @@ = lintStgTopBindings (stgPlatform opts) logger diag_opts ppr_opts - ictxt this_mod unarised + extra_vars this_mod unarised | otherwise - = \ _whodunnit _binds -> return () + = \ _whodunit _binds -> return () ------------------------------------------- do_stg_pass :: Module -> [StgTopBinding] -> StgToDo -> StgM [StgTopBinding] diff --git a/GHC/Stg/Subst.hs b/GHC/Stg/Subst.hs --- a/GHC/Stg/Subst.hs +++ b/GHC/Stg/Subst.hs @@ -11,7 +11,13 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Utils.Trace + +-- TODO: This code might make folly of the work done in CorePrep where +-- we clone local ids in order to ensure *all* local binders are unique. +-- It's my understanding that here we use "the rapier"/uniqAway which makes up +-- uniques based on the ids in scope. Which can give the same unique to different +-- binders as long as they are in different scopes. A guarantee which isn't +-- strong enough for code generation in general. See Note [CorePrep Overview]. -- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not -- maintaining pairs of substitutions. Like 'GHC.Core.Subst.Subst', but diff --git a/GHC/Stg/Syntax.hs b/GHC/Stg/Syntax.hs --- a/GHC/Stg/Syntax.hs +++ b/GHC/Stg/Syntax.hs @@ -61,7 +61,7 @@ -- ppr StgPprOpts(..), panicStgPprOpts, shortStgPprOpts, - pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding, + pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding, pprStgAlt, pprGenStgTopBinding, pprStgTopBinding, pprGenStgTopBindings, pprStgTopBindings ) where @@ -236,7 +236,7 @@ -- which can't be let-bound | StgConApp DataCon ConstructorNumber - [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg]) + [StgArg] -- Saturated [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call @@ -882,7 +882,7 @@ 4 (pprStgExpr opts body) StgRhsCon cc con mid _ticks args - -> hcat [ ppr cc, space + -> hcat [ if stgSccEnabled opts then ppr cc <> space else empty , case mid of NoNumber -> empty Numbered n -> hcat [ppr n, space] diff --git a/GHC/Stg/Unarise.hs b/GHC/Stg/Unarise.hs --- a/GHC/Stg/Unarise.hs +++ b/GHC/Stg/Unarise.hs @@ -2,8 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The GRASP/AQUA Project, Glasgow University, 1992-2012 @@ -391,6 +389,7 @@ 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.Core.Type @@ -400,9 +399,9 @@ import GHC.Types.Unique import GHC.Utils.Misc import GHC.Types.Var.Env -import GHC.Types.RepType import Data.Bifunctor (second) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (mapMaybe) import qualified Data.IntMap as IM import GHC.Builtin.PrimOps @@ -440,7 +439,7 @@ initUnariseEnv = UnariseEnv data UnariseVal = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void). - | UnaryVal OutStgArg -- See NOTE [Renaming during unarisation]. + | UnaryVal OutStgArg -- See Note [Renaming during unarisation]. instance Outputable UnariseVal where ppr (MultiVal args) = text "MultiVal" <+> ppr args @@ -595,13 +594,13 @@ -- Doesn't return void args. unariseRubbish_maybe :: Literal -> Maybe [OutStgArg] -unariseRubbish_maybe (LitRubbish rep) +unariseRubbish_maybe (LitRubbish torc rep) | [prep] <- preps , not (isVoidRep prep) = Nothing -- Single, non-void PrimRep. Nothing to do! | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase - = Just [ StgLitArg (LitRubbish (primRepToType prep)) + = Just [ StgLitArg (LitRubbish torc (primRepToRuntimeRep prep)) | prep <- preps, not (isVoidRep prep) ] where preps = runtimeRepPrimRep (text "unariseRubbish_maybe") rep @@ -632,10 +631,9 @@ unariseExpr rho2 rhs' -elimCase rho args bndr (MultiValAlt _) alts +elimCase rho args@(tag_arg : real_args) bndr (MultiValAlt _) alts | isUnboxedSumBndr bndr - = do let (tag_arg : real_args) = args - tag_bndr <- mkId (mkFastString "tag") tagTy + = do tag_bndr <- mkId (mkFastString "tag") tagTy -- this won't be used but we need a binder anyway let rho1 = extendRho rho bndr (MultiVal args) scrut' = case tag_arg of @@ -848,7 +846,7 @@ -- Construct a case binder used when casting sums, of a given type and unique. mkCastVar :: Unique -> Type -> Id -mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq Many ty +mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq ManyTy ty mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr mkCast arg_in cast_op out_id out_ty in_rhs = @@ -879,7 +877,7 @@ ) mkUbxSum dc ty_args args0 us = let - (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args) + _ :| sum_slots = ubxSumRepType (map typePrimRep ty_args) -- drop tag slot field_slots = (mapMaybe (typeSlotTy . stgArgType) args0) tag = dataConTag dc @@ -946,20 +944,18 @@ -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in "GHC.Core.Make" -- ubxSumRubbishArg :: SlotTy -> StgArg -ubxSumRubbishArg PtrLiftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID -ubxSumRubbishArg PtrUnliftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID -ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0) -ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) -ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0) -ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0) -ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish vec_rep) +ubxSumRubbishArg PtrLiftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID +ubxSumRubbishArg PtrUnliftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID +ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0) +ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) +ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0) +ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0) +ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish TypeLike vec_rep) where vec_rep = primRepToRuntimeRep (VecRep n e) -------------------------------------------------------------------------------- {- -Note [Unarisation of Void binders and arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For arguments (StgArg) and binders (Id) we have two kind of unarisation: - When unarising function arg binders and arguments, we don't want to remove @@ -971,7 +967,7 @@ Here after unarise we should still get a function with arity 3. Similarly in the call site we shouldn't remove void arguments: - f (# (# #), (# #) #) voidId rw + f (# (# #), (# #) #) void# rw When unarising , we extend the environment with these binders: diff --git a/GHC/Stg/Utils.hs b/GHC/Stg/Utils.hs --- a/GHC/Stg/Utils.hs +++ b/GHC/Stg/Utils.hs @@ -35,7 +35,7 @@ mkUnarisedIds fs tys = mapM (mkUnarisedId fs) tys mkUnarisedId :: MonadUnique m => FastString -> UnaryType -> m Id -mkUnarisedId s t = mkSysLocalM s Many t +mkUnarisedId s t = mkSysLocalM s ManyTy t -- Checks if id is a top level error application. -- isErrorAp_maybe :: Id -> @@ -72,8 +72,7 @@ prim_reps = typePrimRep bndr_ty _is_poly_alt_tycon tc - = isFunTyCon tc - || isPrimTyCon tc -- "Any" is lifted but primitive + = isPrimTyCon tc -- "Any" is lifted but primitive || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict -- function application where argument has a -- type-family type diff --git a/GHC/StgToByteCode.hs b/GHC/StgToByteCode.hs --- a/GHC/StgToByteCode.hs +++ b/GHC/StgToByteCode.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fprof-auto-top #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- -- (c) The University of Glasgow 2002-2006 @@ -44,6 +43,7 @@ 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 @@ -319,7 +319,7 @@ -- 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]) + emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise @@ -480,13 +480,14 @@ 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)) + -- use RETURN_UBX for unary representations + [] -> return (unitOL $ RETURN_UNLIFTED V) + [rep] -> return (unitOL $ RETURN_UNLIFTED (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) + args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off)) args_offsets + tuple_bco <- emitBc (tupleBCO platform call_info args_ptrs) return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL` PUSH_BCO tuple_bco `consOL` unitOL RETURN_TUPLE @@ -526,7 +527,7 @@ :: 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) + | not (usePlainReturn (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 @@ -681,8 +682,8 @@ 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 +schemeT d s p (StgConApp con _cn args _tys) | isUnboxedTupleDataCon con || isUnboxedSumDataCon con = returnUnboxedTuple d s p args @@ -691,7 +692,7 @@ = 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) + mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN) -- Case 4: Tail call of function schemeT d s p (StgApp fn args) @@ -831,11 +832,14 @@ -- 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 + ubx_frame = not ubx_tuple_frame && not (usePlainReturn bndr_ty) + + non_void_arg_reps = non_void (typeArgReps platform bndr_ty) + profiling | Just interp <- hsc_interp hsc_env = interpreterProfiled interp @@ -844,8 +848,7 @@ -- 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. + -- on top of the itbl. ret_frame_size_b :: StackDepth ret_frame_size_b | ubx_tuple_frame = (if profiling then 5 else 4) * wordSize platform @@ -859,6 +862,7 @@ -- 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 + | ubx_frame = wordSize platform | otherwise = 0 (bndr_size, call_info, args_offsets) @@ -1046,14 +1050,24 @@ 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) + then do + let args_ptrs = + map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off)) + args_offsets + tuple_bco <- emitBc (tupleBCO platform call_info args_ptrs) + return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco + `consOL` scrut_code) + else let push_alts + | not ubx_frame + = PUSH_ALTS alt_bco' + | otherwise + = let unlifted_rep = + case non_void_arg_reps of + [] -> V + [rep] -> rep + _ -> panic "schemeE(StgCase).push_alts" + in PUSH_ALTS_UNLIFTED alt_bco' unlifted_rep + in return (push_alts `consOL` scrut_code) -- ----------------------------------------------------------------------------- @@ -1124,38 +1138,21 @@ (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. +{- + We use the plain return convention (ENTER/PUSH_ALTS) for + lifted types and unlifted algebraic types. -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. + Other types use PUSH_ALTS_UNLIFTED/PUSH_ALTS_TUPLE which expect + additional data on the stack. + -} +usePlainReturn :: Type -> Bool +usePlainReturn t + | isUnboxedTupleType t || isUnboxedSumType t = False + | otherwise = typePrimRep t == [LiftedRep] || + (typePrimRep t == [UnliftedRep] && isAlgType t) -Note [unboxed tuple bytecodes and tuple_BCO] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- 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. @@ -1250,10 +1247,11 @@ -} -tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name -tupleBCO platform args_info args = +tupleBCO :: Platform -> NativeCallInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name +tupleBCO platform info pointers = 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 @@ -1265,16 +1263,18 @@ -- 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 - + bitmap_size = trunc16W $ 1 + nativeCallSize info + bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) $ + map ((+1) . fromIntegral . bytesToWords platform . snd) + (filter fst pointers) 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 = +primCallBCO :: Platform -> NativeCallInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name +primCallBCO platform args_info pointers = 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 @@ -1284,52 +1284,20 @@ -} 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 - + -- the first three words in the frame are the BCO describing the + -- pointers in the frame, the call_info word and the pointer + -- to the Cmm function being called. None of these is a pointer that + -- should be followed by the garbage collector + bitmap_size = trunc16W $ 2 + nativeCallSize args_info + bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) $ + map ((+2) . fromIntegral . bytesToWords platform . snd) + (filter fst pointers) -- 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. @@ -1357,12 +1325,15 @@ (args_info, args_offsets) = layoutNativeCall profile NativePrimCall - 0 + d (primRepCmmType platform . argPrimRep) nv_args - prim_args_offsets = mapFst argPrimRep args_offsets - shifted_args_offsets = mapSnd (+ d) args_offsets + args_ptrs :: [(Bool, ByteOff)] + args_ptrs = + map (\(r, off) -> + (isFollowableArg (toArgRep platform . argPrimRep $ r), off)) + args_offsets push_target = PUSH_UBX (LitLabel target Nothing IsFunction) 1 push_info = PUSH_UBX (mkNativeCallInfoLit platform args_info) 1 @@ -1379,8 +1350,8 @@ 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) + push_args <- go d [] args_offsets + args_bco <- emitBc (primCallBCO platform args_info args_ptrs) return $ mconcat push_args `appOL` (push_target `consOL` push_info `consOL` @@ -1463,10 +1434,11 @@ push_args = concatOL pushs_arg !d_after_args = d0 + wordsToBytes platform a_reps_sizeW a_reps_pushed_RAW - | null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l)) - = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?" + | x:xs <- a_reps_pushed_r_to_l + , isVoidRep x + = reverse xs | otherwise - = reverse (tail a_reps_pushed_r_to_l) + = 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. @@ -1494,7 +1466,7 @@ Addr# address_of_C_fn (must be an unboxed type) - The interpreter then calls the marshall code mentioned + 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 @@ -1510,7 +1482,7 @@ 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 marshall_code ( StgWord* ptr_to_top_of_stack ) + void marshal_code ( StgWord* ptr_to_top_of_stack ) -} -- resolve static address maybe_static_target :: Maybe Literal @@ -1535,9 +1507,8 @@ -- 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 - | otherwise = if null a_reps_pushed_RAW - then panic "GHC.StgToByteCode.generateCCall: dyn with no args" - else tail 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) @@ -1591,7 +1562,7 @@ -- 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) + `snocOL` RETURN_UNLIFTED (toArgRep platform r_rep) --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ return ( push_args `appOL` @@ -1705,6 +1676,7 @@ The code we generate is this: push arg + push bogus-word TESTEQ_I 0 L1 PUSH_G @@ -1722,6 +1694,13 @@ L_exit: SLIDE 1 n ENTER + +The 'bogus-word' push is because TESTEQ_I expects the top of the stack +to have an info-table, and the next word to have the value to be +tested. This is very weird, but it's the way it is right now. See +Interpreter.c. We don't actually need an info-table here; we just +need to have the argument to be one-from-top on the stack, hence pushing +a 1-word null. See #8383. -} @@ -1747,10 +1726,14 @@ slide_ws = bytesToWords platform (d - s + arg_bytes) return (push_arg + `appOL` unitOL (PUSH_UBX LitNullAddr 1) + -- Push bogus word (see Note [Implementing tagToEnum#]) `appOL` concatOL steps `appOL` toOL [ LABEL label_fail, CASEFAIL, LABEL label_exit ] - `appOL` mkSlideW 1 slide_ws + `appOL` mkSlideW 1 (slide_ws + 1) + -- "+1" to account for bogus word + -- (see Note [Implementing tagToEnum#]) `appOL` unitOL ENTER) where mkStep l_exit (my_label, next_label, n, name_for_n) @@ -1875,7 +1858,9 @@ LitChar {} -> code WordRep LitNullAddr -> code AddrRep LitString {} -> code AddrRep - LitRubbish {} -> code WordRep + 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 @@ -2022,11 +2007,9 @@ testEQ NoDiscr _ = panic "mkMultiBranch NoDiscr" -- None of these will be needed if there are no non-default alts - (init_lo, init_hi) - | null notd_ways - = panic "mkMultiBranch: awesome foursome" - | otherwise - = case fst (head notd_ways) of + (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 ) diff --git a/GHC/StgToCmm.hs b/GHC/StgToCmm.hs --- a/GHC/StgToCmm.hs +++ b/GHC/StgToCmm.hs @@ -179,7 +179,8 @@ StgTopStringLit id str -> do let label = mkBytesLabel (idName id) -- emit either a CmmString literal or dump the string in a file and emit a - -- CmmFileEmbed literal. + -- CmmFileEmbed literal. If binary blobs aren't supported, + -- the threshold in `cfg` will be 0. -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr let asString = case stgToCmmBinBlobThresh cfg of Just bin_blob_threshold -> fromIntegral (BS.length str) <= bin_blob_threshold @@ -187,10 +188,10 @@ (lit,decl) = if asString then mkByteStringCLit label str - else mkFileEmbedLit label $ unsafePerformIO $ do + else unsafePerformIO $ do bFile <- newTempName logger tmpfs (stgToCmmTmpDir cfg) TFL_CurrentModule ".dat" BS.writeFile bFile str - return bFile + return $ mkFileEmbedLit label bFile (BS.length str) emitDecl decl addBindC (litIdInfo (stgToCmmPlatform cfg) id mkLFStringLit lit) diff --git a/GHC/StgToCmm/Bind.hs b/GHC/StgToCmm/Bind.hs --- a/GHC/StgToCmm/Bind.hs +++ b/GHC/StgToCmm/Bind.hs @@ -16,6 +16,7 @@ import GHC.Prelude hiding ((<*>)) import GHC.Core ( AltCon(..) ) +import GHC.Core.Opt.Arity( isOneShotBndr ) import GHC.Runtime.Heap.Layout import GHC.Unit.Module @@ -24,6 +25,8 @@ import GHC.Platform import GHC.Platform.Profile +import GHC.Builtin.Names (unpackCStringName, unpackCStringUtf8Name) + import GHC.StgToCmm.Config import GHC.StgToCmm.Expr import GHC.StgToCmm.Monad @@ -86,6 +89,9 @@ lf_info = mkClosureLFInfo platform id TopLevel [] upd_flag args in (cg_id_info, gen_code lf_info closure_label) where + + gen_code :: LambdaFormInfo -> CLabel -> FCode () + -- special case for a indirection (f = g). We create an IND_STATIC -- closure pointing directly to the indirectee. This is exactly -- what the CAF will eventually evaluate to anyway, we're just @@ -100,11 +106,44 @@ -- concurrent/should_run/4030 fails, for instance. -- gen_code _ closure_label - | StgApp f [] <- body, null args, isNonRec rec + | StgApp f [] <- body + , null args + , isNonRec rec = do cg_info <- getCgIdInfo f emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)] + -- Emit standard stg_unpack_cstring closures for top-level unpackCString# thunks. + -- + -- Note that we do not do this for thunks enclosured in code ticks (e.g. hpc + -- ticks) since we want to ensure that these ticks are not lost (e.g. + -- resulting in Strings being reported by hpc as uncovered). However, we + -- don't worry about standard profiling ticks since unpackCString tends not + -- be terribly interesting in profiles. See Note [unpack_cstring closures] in + -- 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 + gen_code lf_info _closure_label = do { profile <- getProfile ; let name = idName id @@ -220,7 +259,6 @@ {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} cgRhs id (StgRhsClosure fvs cc upd_flag args body) = do - checkFunctionArgTags (text "TagCheck Failed: Rhs of" <> ppr id) id args profile <- getProfile check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig use_std_ap_thunk <- stgToCmmTickyAP <$> getStgToCmmConfig @@ -489,6 +527,7 @@ lf_info = closureLFInfo cl_info info_tbl = mkCmmInfo cl_info bndr cc +-- Functions closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details = let nv_args = nonVoidIds args arity = length args @@ -530,7 +569,7 @@ -- Load free vars out of closure *after* -- heap check, to reduce live vars over check ; when node_points $ load_fvs node lf_info fv_bindings - ; checkFunctionArgTags (text "TagCheck failed - Argument to local function:" <> ppr bndr) bndr (map fromNonVoid nv_args) + ; checkFunctionArgTags (text "TagCheck failed - Argument to local function:" <> ppr bndr) bndr args ; void $ cgExpr body }}} @@ -664,8 +703,8 @@ whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) currentTSOExpr -- See Note [Heap memory barriers] in SMP.h. - emitPrimCall [] MO_WriteBarrier [] - emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo)) + let w = wordWidth platform + emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) [node, CmmReg (CmmGlobal EagerBlackholeInfo)] setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), @@ -782,5 +821,5 @@ -- Not called for StgRhsCon which have global info tables built in -- CgConTbls.hs with a description generated from the data constructor closureDescription mod_name name - = renderWithContext defaultSDocContext + = showSDocOneLine defaultSDocContext (char '<' <> pprFullName mod_name name <> char '>') diff --git a/GHC/StgToCmm/CgUtils.hs b/GHC/StgToCmm/CgUtils.hs --- a/GHC/StgToCmm/CgUtils.hs +++ b/GHC/StgToCmm/CgUtils.hs @@ -173,18 +173,15 @@ BaseReg -> baseAddr _other -> CmmLoad baseAddr (globalRegType platform reg) NaturallyAligned - CmmRegOff greg@(CmmGlobal reg) offset -> + CmmRegOff (CmmGlobal reg) offset -> -- RegOf leaves are just a shorthand form. If the reg maps -- to a real reg, we keep the shorthand, otherwise, we just -- expand it and defer to the above code. - -- NB: to ensure type correctness we need to ensure the Add - -- as well as the Int need to be of the same size as the - -- register. case reg `elem` activeStgRegs platform of True -> expr - False -> CmmMachOp (MO_Add (cmmRegWidth platform greg)) [ - fixExpr (CmmReg greg), + False -> CmmMachOp (MO_Add (wordWidth platform)) [ + fixExpr (CmmReg (CmmGlobal reg)), CmmLit (CmmInt (fromIntegral offset) - (cmmRegWidth platform greg))] + (wordWidth platform))] 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 @@ -76,7 +76,6 @@ import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.Utils -import GHC.Cmm.Ppr.Expr() -- For Outputable instances import GHC.StgToCmm.Types import GHC.StgToCmm.Sequel @@ -265,124 +264,22 @@ -- Use the LambdaFormInfo from the interface 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! - | 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 + -- Interface doesn't have a LambdaFormInfo, make a conservative one from + -- the type. + | Just con <- isDataConWorkId_maybe id + , isNullaryRepDataCon 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 + | arity > 0 + -> LFReEntrant TopLevel arity True ArgUnknown + | otherwise -> 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. - -In particular, the `lfInfo` field of the `IdInfo` field of an `Id` -* For Ids defined in this module: is `Nothing` -* For 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. - -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, albeit rarely used, are unambiguously functions --- which makes `LFReEntrant`, the LambdaFormInfo we give them, correct. -See also the discussion in #23158. - --} - ------------- mkLFStringLit :: LambdaFormInfo mkLFStringLit = LFUnlifted @@ -411,7 +308,8 @@ -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr -- -- The interpreter also needs to be updated if we change the --- tagging strategy; see tagConstr in rts/Interpreter.c. +-- tagging strategy. See Note [Data constructor dynamic tags] in +-- rts/Interpreter.c isSmallFamily :: Platform -> Int -> Bool isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform diff --git a/GHC/StgToCmm/Config.hs b/GHC/StgToCmm/Config.hs --- a/GHC/StgToCmm/Config.hs +++ b/GHC/StgToCmm/Config.hs @@ -22,8 +22,8 @@ -- Cmm/Parser.y which preloads it with a panic , stgToCmmTmpDir :: !TempDir -- ^ Temp Dir for files used in compilation , stgToCmmContext :: !SDocContext -- ^ Context for StgToCmm phase - , stgToCmmDebugLevel :: !Int -- ^ The verbosity of debug messages - , stgToCmmBinBlobThresh :: !(Maybe Word) -- ^ Threshold at which Binary literals (e.g. strings) + , stgToCmmEmitDebugInfo :: !Bool -- ^ Whether we wish to output debug information + , stgToCmmBinBlobThresh :: !(Maybe Word) -- ^ Threshold at which Binary literals (e.g. strings) -- are either dumped to a file and a CmmFileEmbed literal -- is emitted (over threshold), or become a CmmString -- Literal (under or at threshold). CmmFileEmbed is only supported @@ -66,7 +66,6 @@ , stgToCmmAllowQuotRem2 :: !Bool -- ^ Allowed to generate QuotRem , stgToCmmAllowExtendedAddSubInstrs :: !Bool -- ^ Allowed to generate AddWordC, SubWordC, Add2, etc. , stgToCmmAllowIntMul2Instr :: !Bool -- ^ Allowed to generate IntMul2 instruction - , stgToCmmAllowFabsInstrs :: !Bool -- ^ Allowed to generate Fabs instructions , stgToCmmTickyAP :: !Bool -- ^ Disable use of precomputed standard thunks. ------------------------------ SIMD flags ------------------------------------ -- Each of these flags checks vector compatibility with the backend requested diff --git a/GHC/StgToCmm/Env.hs b/GHC/StgToCmm/Env.hs --- a/GHC/StgToCmm/Env.hs +++ b/GHC/StgToCmm/Env.hs @@ -36,6 +36,7 @@ import GHC.Cmm.Graph import GHC.Types.Name import GHC.Core.Type +import GHC.Core.TyCo.Compare( eqType ) import GHC.Builtin.Types.Prim import GHC.Types.Unique.FM import GHC.Types.Var.Env @@ -82,8 +83,8 @@ mkRhsInit platform reg lf_info expr = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag platform lf_info)) --- | Returns a 'CmmExpr' for the *tagged* pointer idInfoToAmode :: CgIdInfo -> CmmExpr +-- Returns a CmmExpr for the *tagged* pointer idInfoToAmode CgIdInfo { cg_loc = CmmLoc e } = e idInfoToAmode cg_info = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc @@ -119,7 +120,7 @@ setBinds new_binds -- Inside GHC the average module creates 385 external references --- with noteable cgIdInfo (so not generated by mkLFArgument). +-- with notable cgIdInfo (so not generated by mkLFArgument). -- On average 200 of these are covered by True/False/[] -- and nullary constructors make up ~80. -- One would think it would be worthwhile to cache these. @@ -150,7 +151,7 @@ in return $ litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl) else - cgLookupPanic id -- Bug, id is neither in local binds nor is external + cgLookupPanic id -- Bug }}} -- | Retrieve cg info for a name if it already exists. diff --git a/GHC/StgToCmm/Expr.hs b/GHC/StgToCmm/Expr.hs --- a/GHC/StgToCmm/Expr.hs +++ b/GHC/StgToCmm/Expr.hs @@ -38,7 +38,6 @@ import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG ) -import GHC.Cmm.Ppr import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall @@ -77,6 +76,8 @@ -- 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 platform <- getPlatform emitComment (mkFastString "dataToTag#") @@ -93,15 +94,7 @@ -- 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]. - 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))) - - fast_path <- getCode $ do + (fast_path :: CmmAGraph) <- getCode $ do -- Return the constructor index from the pointer tag return_ptr_tag <- getCode $ do emitAssign (CmmLocal result_reg) @@ -114,8 +107,22 @@ $ getConstrTag profile align_check (cmmUntag platform amode) emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False) - - emit =<< mkCmmIfThenElse' is_tagged fast_path slow_path (Just True) + -- 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) emitReturn [CmmReg $ CmmLocal result_reg] @@ -386,7 +393,7 @@ * If f is recursive, and the hot loop wouldn't allocate, but the exit branch does then we do a redundant heap check. - * We use one more instruction to de-allocate the unused heap in the branch using less heap. (Neglible) + * We use one more instruction to de-allocate the unused heap in the branch using less heap. (Negligible) * A small risk of running gc slightly more often than needed especially if one branch allocates a lot. The upsides are: @@ -905,7 +912,7 @@ -- tag from the info table, and switch on that. The only technically -- tricky part is that the default case needs (logical) duplication. -- To do this we emit an extra label for it and branch to that from --- the second switch. This avoids duplicated codegen. See Trac #14373. +-- the second switch. This avoids duplicated codegen. See #14373. -- See Note [Double switching for big families] for the mechanics -- involved. -- @@ -1019,7 +1026,7 @@ assertTag = whenCheckTags $ do mod <- getModuleName emitTagAssertion (showPprUnsafe - (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pprExpr platform fun)) + (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun)) fun EnterIt -> assert (null args) $ -- Discarding arguments diff --git a/GHC/StgToCmm/Foreign.hs b/GHC/StgToCmm/Foreign.hs --- a/GHC/StgToCmm/Foreign.hs +++ b/GHC/StgToCmm/Foreign.hs @@ -8,9 +8,7 @@ module GHC.StgToCmm.Foreign ( cgForeignCall, - emitPrimCall, - emitCCall, - emitCCallNeverReturns, + emitPrimCall, emitCCall, emitForeignCall, emitSaveThreadState, saveThreadState, @@ -196,31 +194,17 @@ -} -emitCCall' :: CmmReturnInfo - -> [(CmmFormal,ForeignHint)] - -> CmmExpr - -> [(CmmActual,ForeignHint)] - -> FCode () -emitCCall' ret_info hinted_results fn hinted_args +emitCCall :: [(CmmFormal,ForeignHint)] + -> CmmExpr + -> [(CmmActual,ForeignHint)] + -> FCode () +emitCCall hinted_results fn hinted_args = void $ emitForeignCall PlayRisky results target args where (args, arg_hints) = unzip hinted_args (results, result_hints) = unzip hinted_results target = ForeignTarget fn fc - fc = ForeignConvention CCallConv arg_hints result_hints ret_info - -emitCCall :: [(CmmFormal,ForeignHint)] - -> CmmExpr - -> [(CmmActual,ForeignHint)] - -> FCode () -emitCCall = emitCCall' CmmMayReturn - -emitCCallNeverReturns - :: [(CmmFormal,ForeignHint)] - -> CmmExpr - -> [(CmmActual,ForeignHint)] - -> FCode () -emitCCallNeverReturns = emitCCall' CmmNeverReturns + fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () diff --git a/GHC/StgToCmm/Heap.hs b/GHC/StgToCmm/Heap.hs --- a/GHC/StgToCmm/Heap.hs +++ b/GHC/StgToCmm/Heap.hs @@ -6,8 +6,6 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - module GHC.StgToCmm.Heap ( getVirtHp, setVirtHp, setRealHp, getHpRelOffset, @@ -161,19 +159,20 @@ -- Layout of static closures ----------------------------------------------------------- --- Make a static closure, adding on any extra padding needed for CAFs, --- and adding a static link field if necessary. - +-- | Make a static closure, adding on any extra padding needed for CAFs, and +-- adding a static link field if necessary. mkStaticClosureFields :: Profile -> CmmInfoTable -> CostCentreStack -> CafInfo - -> [CmmLit] -- Payload + -> [CmmLit] -- ^ Payload + -> [CmmLit] -- ^ Extra non-pointers that go to the end of the closure. + -- See Note [unpack_cstring closures] in StgStdThunks.cmm. -> [CmmLit] -- The full closure -mkStaticClosureFields profile info_tbl ccs caf_refs payload +mkStaticClosureFields profile info_tbl ccs caf_refs payload extras = mkStaticClosure profile info_lbl ccs payload padding - static_link_field saved_info_field + static_link_field saved_info_field extras where platform = profilePlatform profile info_lbl = cit_lbl info_tbl @@ -218,14 +217,15 @@ -- in rts/sm/Storage.h mkStaticClosure :: Profile -> CLabel -> CostCentreStack -> [CmmLit] - -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field + -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] +mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field extras = [CmmLabel info_lbl] ++ staticProfHdr profile ccs ++ payload ++ padding ++ static_link_field ++ saved_info_field + ++ extras ----------------------------------------------------------- -- Heap overflow checking @@ -610,10 +610,6 @@ gc_id <- newBlockId let - Just alloc_lit = mb_alloc_lit - - bump_hp = cmmOffsetExprB platform hpExpr alloc_lit - -- Sp overflow if ((old + 0) - CmmHighStack < SpLim) -- At the beginning of a function old + 0 = Sp -- See Note [Single stack check] @@ -628,8 +624,6 @@ -- HpLim points to the LAST WORD of valid allocation space. hp_oflo = CmmMachOp (mo_wordUGt platform) [hpExpr, hpLimExpr] - alloc_n = mkAssign hpAllocReg alloc_lit - case mb_stk_hwm of Nothing -> return () Just stk_hwm -> tickyStackCheck @@ -644,12 +638,14 @@ | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id _otherwise -> return () - if isJust mb_alloc_lit - then do + case mb_alloc_lit of + Just alloc_lit -> do + let bump_hp = cmmOffsetExprB platform hpExpr alloc_lit + alloc_n = mkAssign hpAllocReg alloc_lit tickyHeapCheck emitAssign hpReg bump_hp emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False) - else + Nothing -> when (checkYield && not omit_yields) $ do -- Yielding if HpLim == 0 let yielding = CmmMachOp (mo_wordEq platform) diff --git a/GHC/StgToCmm/InfoTableProv.hs b/GHC/StgToCmm/InfoTableProv.hs --- a/GHC/StgToCmm/InfoTableProv.hs +++ b/GHC/StgToCmm/InfoTableProv.hs @@ -4,6 +4,8 @@ import GHC.Platform import GHC.Unit.Module import GHC.Utils.Outputable +import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile) +import GHC.Data.FastString (unpackFS) import GHC.Cmm.CLabel import GHC.Cmm.Expr @@ -16,7 +18,6 @@ import GHC.Data.ShortText (ShortText) import qualified GHC.Data.ShortText as ST -import Data.Bifunctor (first) import qualified Data.Map.Strict as M import Control.Monad.Trans.State.Strict import qualified Data.ByteString as BS @@ -45,7 +46,9 @@ , strtab_offset (ipeTypeDesc cg_ipe) , strtab_offset (ipeLabel cg_ipe) , strtab_offset (ipeModuleName cg_ipe) - , strtab_offset (ipeSrcLoc cg_ipe) + , strtab_offset (ipeSrcFile cg_ipe) + , strtab_offset (ipeSrcSpan cg_ipe) + , int32 0 ] int n = mkIntCLit platform n @@ -61,19 +64,28 @@ toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt toCgIPE platform ctx module_name ipe = do - table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform CStyle (infoTablePtr ipe)) + 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 (src_loc_str, label_str) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ipe) + let label_str = maybe "" snd (infoTableProv ipe) + let (src_loc_file, src_loc_span) = + case infoTableProv ipe of + Nothing -> ("", "") + Just (span, _) -> + let file = unpackFS $ srcSpanFile span + coords = renderWithContext ctx (pprUserRealSpan False span) + in (file, coords) label <- lookupStringTable $ ST.pack label_str - src_loc <- lookupStringTable $ ST.pack src_loc_str + src_file <- lookupStringTable $ ST.pack src_loc_file + src_span <- lookupStringTable $ ST.pack src_loc_span return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe , ipeTableName = table_name , ipeClosureDesc = closure_desc , ipeTypeDesc = type_desc , ipeLabel = label , ipeModuleName = module_name - , ipeSrcLoc = src_loc + , ipeSrcFile = src_file + , ipeSrcSpan = src_span } data CgInfoProvEnt = CgInfoProvEnt @@ -83,7 +95,8 @@ , ipeTypeDesc :: !StrTabOffset , ipeLabel :: !StrTabOffset , ipeModuleName :: !StrTabOffset - , ipeSrcLoc :: !StrTabOffset + , ipeSrcFile :: !StrTabOffset + , ipeSrcSpan :: !StrTabOffset } data StringTable = StringTable { stStrings :: DList ShortText diff --git a/GHC/StgToCmm/Layout.hs b/GHC/StgToCmm/Layout.hs --- a/GHC/StgToCmm/Layout.hs +++ b/GHC/StgToCmm/Layout.hs @@ -208,7 +208,7 @@ r <- direct_call "slow_call" NativeNodeCall (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps) emitComment $ mkFastString ("slow_call for " ++ - renderWithContext ctx (pdoc platform fun) ++ + showSDocOneLine ctx (pdoc platform fun) ++ " with pat " ++ unpackFS rts_fun) return r @@ -297,7 +297,7 @@ platform <- getPlatform pprPanic "direct_call" $ text caller <+> ppr arity <+> - pdoc platform lbl <+> ppr (length args) <+> + pprDebugCLabel platform lbl <+> ppr (length args) <+> pdoc platform (map snd args) <+> ppr (map fst args) | null rest_args -- Precisely the right number of arguments diff --git a/GHC/StgToCmm/Lit.hs b/GHC/StgToCmm/Lit.hs --- a/GHC/StgToCmm/Lit.hs +++ b/GHC/StgToCmm/Lit.hs @@ -50,9 +50,9 @@ cgLit (LitString s) = CmmLit <$> newByteStringCLit s -- not unpackFS; we want the UTF-8 byte stream. -cgLit (LitRubbish rep) = +cgLit (LitRubbish _ rep) = case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants] - VoidRep -> panic "cgLit:VoidRep" -- dito + VoidRep -> panic "cgLit:VoidRep" -- ditto LiftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId UnliftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId AddrRep -> cgLit LitNullAddr diff --git a/GHC/StgToCmm/Monad.hs b/GHC/StgToCmm/Monad.hs --- a/GHC/StgToCmm/Monad.hs +++ b/GHC/StgToCmm/Monad.hs @@ -188,11 +188,9 @@ data CgIdInfo = CgIdInfo - { cg_id :: Id - -- ^ Id that this is the info for + { cg_id :: Id -- Id that this is the info for , cg_lf :: LambdaFormInfo - , cg_loc :: CgLoc - -- ^ 'CmmExpr' for the *tagged* value + , cg_loc :: CgLoc -- CmmExpr for the *tagged* value } instance OutputableP Platform CgIdInfo where @@ -296,7 +294,7 @@ data FCodeState = MkFCodeState { fcs_upframeoffset :: UpdFrameOffset -- ^ Size of current update frame UpdFrameOffset must be kept lazy or -- else the RTS will deadlock _and_ also experience a severe - -- performance degredation + -- performance degradation , fcs_sequel :: !Sequel -- ^ What to do at end of basic block , fcs_selfloop :: Maybe SelfLoopInfo -- ^ Which tail calls can be compiled as local jumps? -- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr @@ -533,7 +531,7 @@ tickScope code = do cfg <- getStgToCmmConfig fstate <- getFCodeState - if stgToCmmDebugLevel cfg == 0 then code else do + if not $ stgToCmmEmitDebugInfo cfg then code else do u <- newUnique let scope' = SubScope u (fcs_tickscope fstate) withFCodeState code fstate{ fcs_tickscope = scope' } @@ -719,8 +717,8 @@ emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode () emitUnwind regs = do - debug_level <- stgToCmmDebugLevel <$> getStgToCmmConfig - when (debug_level > 0) $ + debug <- stgToCmmEmitDebugInfo <$> getStgToCmmConfig + when debug $ emitCgStmt $ CgStmt $ CmmUnwind regs emitAssign :: CmmReg -> CmmExpr -> FCode () diff --git a/GHC/StgToCmm/Prim.hs b/GHC/StgToCmm/Prim.hs --- a/GHC/StgToCmm/Prim.hs +++ b/GHC/StgToCmm/Prim.hs @@ -311,7 +311,7 @@ -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> - emitAssign (CmmLocal res) (byteArraySize platform profile arg) + emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes @@ -320,7 +320,7 @@ -- #define getSizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> - emitAssign (CmmLocal res) (byteArraySize platform profile arg) + emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) -- #define touchzh(o) /* nothing */ @@ -394,10 +394,15 @@ -- Getting the size of pointer arrays SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] -> - emitAssign (CmmLocal res) (ptrArraySize platform profile arg) + emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg + (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))) + (bWord platform)) SizeofMutableArrayOp -> emitPrimOp cfg SizeofArrayOp SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> - emitAssign (CmmLocal res) (smallPtrArraySize platform profile arg) + emit $ mkAssign (CmmLocal res) + (cmmLoadIndexW platform arg + (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))) + (bWord platform)) SizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp GetSizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp @@ -1099,6 +1104,7 @@ 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 @@ -1118,6 +1124,7 @@ 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 @@ -1521,16 +1528,6 @@ then Left (MO_S_Mul2 (wordWidth platform)) else Right genericIntMul2Op - FloatFabsOp -> \args -> opCallishHandledLater args $ - if allowFab - then Left MO_F32_Fabs - else Right $ genericFabsOp W32 - - DoubleFabsOp -> \args -> opCallishHandledLater args $ - if allowFab - then Left MO_F64_Fabs - else Right $ genericFabsOp W64 - -- 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 @@ -1567,11 +1564,17 @@ 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 @@ -1601,6 +1604,7 @@ LabelThreadOp -> alwaysExternal IsCurrentThreadBoundOp -> alwaysExternal NoDuplicateOp -> alwaysExternal + GetThreadLabelOp -> alwaysExternal ThreadStatusOp -> alwaysExternal MkWeakOp -> alwaysExternal MkWeakNoFinalizerOp -> alwaysExternal @@ -1628,6 +1632,7 @@ MkApUpd0_Op -> alwaysExternal NewBCOOp -> alwaysExternal UnpackClosureOp -> alwaysExternal + ListThreadsOp -> alwaysExternal ClosureSizeOp -> alwaysExternal WhereFromOp -> alwaysExternal GetApStackValOp -> alwaysExternal @@ -1730,7 +1735,6 @@ allowQuotRem2 = stgToCmmAllowQuotRem2 cfg allowExtAdd = stgToCmmAllowExtendedAddSubInstrs cfg allowInt2Mul = stgToCmmAllowIntMul2Instr cfg - allowFab = stgToCmmAllowFabsInstrs cfg data PrimopCmmEmit -- | Out of line fake primop that's actually just a foreign call to other @@ -2020,34 +2024,6 @@ ] genericIntMul2Op _ _ = panic "genericIntMul2Op" --- This replicates what we had in libraries/base/GHC/Float.hs: --- --- abs x | x == 0 = 0 -- handles (-0.0) --- | x > 0 = x --- | otherwise = negateFloat x -genericFabsOp :: Width -> GenericOp -genericFabsOp w [res_r] [aa] - = do platform <- getPlatform - let zero = CmmLit (CmmFloat 0 w) - - eq x y = CmmMachOp (MO_F_Eq w) [x, y] - gt x y = CmmMachOp (MO_F_Gt w) [x, y] - - neg x = CmmMachOp (MO_F_Neg w) [x] - - g1 = catAGraphs [mkAssign (CmmLocal res_r) zero] - g2 = catAGraphs [mkAssign (CmmLocal res_r) aa] - - res_t <- CmmLocal <$> newTemp (cmmExprType platform aa) - let g3 = catAGraphs [mkAssign res_t aa, - mkAssign (CmmLocal res_r) (neg (CmmReg res_t))] - - g4 <- mkCmmIfThenElse (gt aa zero) g2 g3 - - emit =<< mkCmmIfThenElse (eq aa zero) g1 g4 - -genericFabsOp _ _ _ = panic "genericFabsOp" - ------------------------------------------------------------------------------ -- Helpers for translating various minor variants of array indexing. @@ -2064,7 +2040,7 @@ -> [CmmExpr] -> FCode () doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx] - = mkBasicIndexedRead False NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx + = mkBasicIndexedRead NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx doIndexOffAddrOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp" @@ -2076,7 +2052,7 @@ -> 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 + in mkBasicIndexedRead alignment 0 maybe_post_read_cast rep res addr idx_rep idx doIndexOffAddrOpAs _ _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs" @@ -2088,7 +2064,7 @@ 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 + mkBasicIndexedRead NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx doIndexByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp" @@ -2102,7 +2078,7 @@ = 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 + mkBasicIndexedRead alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx doIndexByteArrayOpAs _ _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs" @@ -2114,15 +2090,15 @@ = do profile <- getProfile platform <- getPlatform doPtrArrayBoundsCheck idx addr - mkBasicIndexedRead True NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx + mkBasicIndexedRead 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 maybe_pre_write_cast idx_ty [] [addr,idx,val] + = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val doWriteOffAddrOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp" @@ -2131,12 +2107,11 @@ -> [LocalReg] -> [CmmExpr] -> FCode () -doWriteByteArrayOp castOp idx_ty [] [addr,idx, rawVal] +doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val] = 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 + mkBasicIndexedWrite (arrWordsHdrSize profile) maybe_pre_write_cast addr idx_ty idx val doWriteByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp" @@ -2158,7 +2133,8 @@ -- 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 + emitPrimCall [] MO_WriteBarrier [] + mkBasicIndexedWrite hdr_size Nothing addr ty idx val emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) -- the write barrier. We must write a byte into the mark table: @@ -2166,12 +2142,16 @@ emit $ mkStore ( cmmOffsetExpr platform (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size) - (ptrArraySize platform profile addr)) + (loadArrPtrsSize 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 +loadArrPtrsSize :: Profile -> CmmExpr -> CmmExpr +loadArrPtrsSize profile addr = cmmLoadBWord platform (cmmOffsetB platform addr off) + where off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (profileConstants profile) + platform = profilePlatform profile + +mkBasicIndexedRead :: AlignmentSpec -> ByteOff -- Initial offset in bytes -> Maybe MachOp -- Optional result cast -> CmmType -- Type of element we are accessing @@ -2180,40 +2160,27 @@ -> CmmType -- Type of element by which we are indexing -> CmmExpr -- Index -> FCode () -mkBasicIndexedRead barrier alignment off mb_cast ty res base idx_ty idx +mkBasicIndexedRead alignment off Nothing 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 + emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx) +mkBasicIndexedRead alignment off (Just cast) ty res base idx_ty idx + = do platform <- getPlatform + emitAssign (CmmLocal res) (CmmMachOp cast [ + cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx]) -mkBasicIndexedWrite :: Bool -- Should this imply a release barrier - -> ByteOff -- Initial offset in bytes +mkBasicIndexedWrite :: ByteOff -- Initial offset in bytes + -> Maybe MachOp -- Optional value cast -> 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 +mkBasicIndexedWrite off Nothing 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 + emitStore' alignment (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val +mkBasicIndexedWrite off (Just cast) base idx_ty idx val + = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val]) -- ---------------------------------------------------------------------------- -- Misc utils @@ -2241,30 +2208,6 @@ 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. @@ -2510,9 +2453,10 @@ profile <- getProfile platform <- getPlatform - whenCheckBounds $ ifNonZero n $ do - emitRangeBoundsCheck ba1_off n (byteArraySize platform profile ba1) - emitRangeBoundsCheck ba2_off n (byteArraySize platform profile ba2) + ifNonZero n $ do + let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1) + doByteArrayBoundsCheck (last_touched_idx ba1_off) ba1 b8 b8 + doByteArrayBoundsCheck (last_touched_idx ba2_off) ba2 b8 b8 ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off @@ -2575,7 +2519,7 @@ -- 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 + emitMemcpyCall dst_p src_p bytes align -- | Takes a source 'MutableByteArray#', an offset in the source -- array, a destination 'MutableByteArray#', an offset into the @@ -2604,9 +2548,10 @@ profile <- getProfile platform <- getPlatform - whenCheckBounds $ ifNonZero n $ do - emitRangeBoundsCheck src_off n (byteArraySize platform profile src) - emitRangeBoundsCheck dst_off n (byteArraySize platform profile dst) + ifNonZero n $ do + let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1) + doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8 + doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8 let byteArrayAlignment = wordAlignment platform srcOffAlignment = cmmExprAlignment src_off @@ -2624,10 +2569,11 @@ -- 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) + ifNonZero bytes $ do + let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1) + doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8 src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off - emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) + emitMemcpyCall 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 @@ -2644,20 +2590,18 @@ -- 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) + ifNonZero bytes $ do + let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1) + doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8 dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off - emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1) + emitMemcpyCall 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. - + emit =<< mkCmmIfThen' pred code (Just False) -- ---------------------------------------------------------------------------- -- Setting byte arrays @@ -2671,8 +2615,8 @@ profile <- getProfile platform <- getPlatform - whenCheckBounds $ ifNonZero len $ - emitRangeBoundsCheck off len (byteArraySize platform profile ba) + doByteArrayBoundsCheck off ba b8 b8 + doByteArrayBoundsCheck (cmmOffset platform (cmmAddWord platform off len) (-1)) ba b8 b8 let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap offsetAlignment = cmmExprAlignment off @@ -2743,7 +2687,7 @@ -- they're of different types) copy _src _dst dst_p src_p bytes = do platform <- getPlatform - emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) + emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) (wordAlignment platform) @@ -2785,11 +2729,8 @@ 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) + doPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src + doPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst -- Nonmoving collector write barrier emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n @@ -2808,7 +2749,7 @@ -- The base address of the destination card table dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p - (ptrArraySize platform profile dst) + (loadArrPtrsSize profile dst) emitSetCards dst_off dst_cards_p n @@ -2820,7 +2761,7 @@ -- they're of different types) copy _src _dst dst_p src_p bytes = do platform <- getPlatform - emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes) + emitMemcpyCall dst_p src_p (mkIntExpr platform bytes) (wordAlignment platform) @@ -2857,11 +2798,9 @@ 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) + when (n /= 0) $ do + doSmallPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src + doSmallPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst -- Nonmoving collector write barrier emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n @@ -2956,7 +2895,7 @@ emit $ mkAssign (CmmLocal res_r) (CmmReg arr) --- | Takes an offset in the destination array, the base address of +-- | Takes and 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. @@ -2989,7 +2928,7 @@ profile <- getProfile platform <- getPlatform doSmallPtrArrayBoundsCheck idx addr - mkBasicIndexedRead True NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr + mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteSmallPtrArrayOp :: CmmExpr @@ -3005,11 +2944,11 @@ -- Update remembered set for non-moving collector tmp <- newTemp ty - mkBasicIndexedRead False NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx + mkBasicIndexedRead 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 + emitPrimCall [] MO_WriteBarrier [] -- #12469 + mkBasicIndexedWrite (smallArrPtrsHdrSize profile) Nothing addr ty idx val emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) ------------------------------------------------------------------------------ @@ -3135,26 +3074,6 @@ (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 = @@ -3249,68 +3168,50 @@ -- 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) +doBoundsCheck :: CmmExpr -- ^ accessed index + -> CmmExpr -- ^ array size (in elements) + -> FCode () +doBoundsCheck idx sz = do + do_bounds_check <- stgToCmmDoBoundsCheck <$> getStgToCmmConfig + platform <- getPlatform + when do_bounds_check (doCheck platform) + where + doCheck platform = do + boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) [] + emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False) + where + uGE = cmmUGeWord platform + and = cmmAndWord platform + zero = zeroExpr platform + ne = cmmNeWord platform + isOutOfBounds = ((idx `uGE` sz) `and` (idx `ne` zero)) `ne` zero -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) +-- We want to make sure that the array size computation is pushed into the +-- Opt_DoBoundsChecking check to avoid regregressing compiler performance when +-- it's disabled. +{-# INLINE doBoundsCheck #-} doPtrArrayBoundsCheck :: CmmExpr -- ^ accessed index (in bytes) -> CmmExpr -- ^ pointer to @StgMutArrPtrs@ -> FCode () -doPtrArrayBoundsCheck idx arr = whenCheckBounds $ do +doPtrArrayBoundsCheck idx arr = do profile <- getProfile platform <- getPlatform - emitBoundsCheck idx (ptrArraySize platform profile arr) + let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off) + sz_off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform) + doBoundsCheck idx sz doSmallPtrArrayBoundsCheck :: CmmExpr -- ^ accessed index (in bytes) -> CmmExpr -- ^ pointer to @StgMutArrPtrs@ -> FCode () -doSmallPtrArrayBoundsCheck idx arr = whenCheckBounds $ do +doSmallPtrArrayBoundsCheck idx arr = do profile <- getProfile platform <- getPlatform - emitBoundsCheck idx (smallPtrArraySize platform profile arr) + let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off) + sz_off = fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform) + doBoundsCheck idx sz doByteArrayBoundsCheck :: CmmExpr -- ^ accessed index (in elements) @@ -3318,18 +3219,18 @@ -> CmmType -- ^ indexing type -> CmmType -- ^ element type -> FCode () -doByteArrayBoundsCheck idx arr idx_ty elem_ty = whenCheckBounds $ do +doByteArrayBoundsCheck idx arr idx_ty elem_ty = 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) + let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off) + sz_off = fixedHdrSize profile + pc_OFFSET_StgArrBytes_bytes (platformConstants platform) + elem_sz = widthInBytes $ typeWidth elem_ty + idx_sz = widthInBytes $ typeWidth idx_ty + -- Ensure that the last byte of the access is within the array + idx_bytes = cmmOffsetB platform + (cmmMulWord platform idx (mkIntExpr platform idx_sz)) + (elem_sz - 1) + doBoundsCheck idx_bytes sz --------------------------------------------------------------------------- -- 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 @@ -230,7 +230,7 @@ ; modl <- newByteStringCLit (bytesFS $ moduleNameFS $ moduleName $ cc_mod cc) - ; loc <- newByteStringCLit $ utf8EncodeString $ + ; loc <- newByteStringCLit $ utf8EncodeByteString $ renderWithContext ctx (ppr $! costCentreSrcSpan cc) ; let lits = [ zero platform, -- StgInt ccID, diff --git a/GHC/StgToCmm/Sequel.hs b/GHC/StgToCmm/Sequel.hs --- a/GHC/StgToCmm/Sequel.hs +++ b/GHC/StgToCmm/Sequel.hs @@ -17,7 +17,6 @@ import GHC.Cmm.BlockId import GHC.Cmm -import GHC.Cmm.Ppr() import GHC.Types.Id import GHC.Utils.Outputable diff --git a/GHC/StgToCmm/TagCheck.hs b/GHC/StgToCmm/TagCheck.hs --- a/GHC/StgToCmm/TagCheck.hs +++ b/GHC/StgToCmm/TagCheck.hs @@ -43,17 +43,16 @@ import qualified Data.Map as M --- | Check all arguments marked as already tagged for a function --- are tagged by inserting runtime checks. +-- | Check all arguments marked as cbv for the presence of a tag *at runtime*. checkFunctionArgTags :: SDoc -> Id -> [Id] -> FCode () checkFunctionArgTags msg f args = whenCheckTags $ do onJust (return ()) (idCbvMarks_maybe f) $ \marks -> do -- Only check args marked as strict, and only lifted ones. - let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args + let cbv_args = filter (isBoxedType . idType) $ filterByList (map isMarkedCbv marks) args -- Get their (cmm) address arg_infos <- mapM getCgIdInfo cbv_args let arg_cmms = map idInfoToAmode arg_infos - mapM_ (emitTagAssertion (showPprUnsafe msg)) (arg_cmms) + mapM_ (\(cmm,arg) -> emitTagAssertion (showPprUnsafe $ msg <+> ppr arg) cmm) (zip arg_cmms cbv_args) -- | Check all required-tagged arguments of a constructor are tagged *at compile time*. checkConArgsStatic :: SDoc -> DataCon -> [StgArg] -> FCode () @@ -74,7 +73,7 @@ when check_tags act -- | Call barf if we failed to predict a tag correctly. --- This is immensly useful when debugging issues in tag inference +-- This is immensely useful when debugging issues in tag inference -- as it will result in a program abort when we encounter an invalid -- call/heap object, rather than leaving it be and segfaulting arbitrary -- or producing invalid results. @@ -133,7 +132,7 @@ emitArgTagCheck :: SDoc -> [CbvMark] -> [Id] -> FCode () emitArgTagCheck info marks args = whenCheckTags $ do mod <- getModuleName - let cbv_args = filter (isLiftedRuntimeRep . idType) $ filterByList (map isMarkedCbv marks) args + 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) @@ -175,6 +174,6 @@ info <- getCgIdInfo v if taggedCgInfo info then return () - else pprPanic "Arg not tagged as expectd" (ppr msg <+> ppr arg) + 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 @@ -154,7 +154,6 @@ import qualified Data.Char import Control.Monad ( when, unless ) import GHC.Types.Id.Info -import GHC.Utils.Trace import GHC.StgToCmm.Env (getCgInfo_maybe) import Data.Coerce (coerce) import GHC.Utils.Json @@ -363,7 +362,7 @@ Just (CgIdInfo { cg_lf = cg_lf }) | isLFThunk cg_lf -> return $! CmmLabel $ mkClosureInfoTableLabel (profilePlatform profile) tickee cg_lf - _ -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> ppr (mkInfoTableLabel name NoCafRefs)) + _ -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> pprDebugCLabel (profilePlatform profile) (mkInfoTableLabel name NoCafRefs)) return $! zeroCLit platform TickyLNE {} -> return $! zeroCLit platform @@ -887,7 +886,7 @@ Just (tycon, _) -> let anyOf us = getUnique tycon `elem` us in case () of - _ | anyOf [funTyConKey] -> '>' + _ | anyOf [fUNTyConKey] -> '>' | anyOf [charTyConKey] -> 'C' | anyOf [charPrimTyConKey] -> 'c' | anyOf [doubleTyConKey] -> 'D' diff --git a/GHC/StgToCmm/Types.hs b/GHC/StgToCmm/Types.hs --- a/GHC/StgToCmm/Types.hs +++ b/GHC/StgToCmm/Types.hs @@ -70,52 +70,6 @@ * We don't absolutely guarantee to serialise the CgInfo: we won't if you have -fomit-interface-pragmas or -fno-code; and we won't read it in if you have -fignore-interface-pragmas. (We could revisit this decision.) - -Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -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 -references to them may be passed untagged to code that expects tagged -references. - -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: - - module B where - - type NP :: [UnliftedType] -> UnliftedType - data NP xs where - UNil :: NP '[] - - - module A where - import B - - fieldsSam :: NP xs -> NP xs -> Bool - fieldsSam UNil UNil = True - - x = fieldsSam UNil UNil - -Due to its GADT nature, `B.UNil` produces a trivial wrapper - - $WUNil :: NP '[] - $WUNil = UNil @'[] @~() - -which is referenced in the RHS of `A.x`. If we fail to give `$WUNil` the -correct `LFCon 0` `LambdaFormInfo` then we will end up passing an untagged -pointer to `fieldsSam`. This is problematic as `fieldsSam` may take advantage -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. - -See also Note [The LFInfo of Imported Ids] -} -- | Codegen-generated Id infos, to be passed to downstream via interfaces. @@ -164,7 +118,7 @@ !StandardFormInfo !Bool -- True <=> *might* be a function type - | LFCon -- A saturated data constructor application + | LFCon -- A saturated constructor application !DataCon -- The constructor | LFUnknown -- Used for function arguments and imported things. diff --git a/GHC/StgToCmm/Utils.hs b/GHC/StgToCmm/Utils.hs --- a/GHC/StgToCmm/Utils.hs +++ b/GHC/StgToCmm/Utils.hs @@ -46,7 +46,7 @@ convertInfoProvMap, cmmInfoTableToInfoProvEnt ) where -import GHC.Prelude +import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Platform import GHC.StgToCmm.Monad @@ -266,7 +266,7 @@ emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode () emitDataCon lbl itbl ccs payload = - emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload)) + emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload [])) ------------------------------------------------------------------------- -- @@ -448,8 +448,8 @@ -> [(Literal, CmmAGraphScoped)] -- Tagged branches -> CmmAGraphScoped -- Default branch (always) -> FCode () -- Emit the code -emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt -emitCmmLitSwitch scrut branches deflt = do +emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt +emitCmmLitSwitch scrut branches@(branch:_) deflt = do scrut' <- assignTemp' scrut join_lbl <- newBlockId deflt_lbl <- label_code join_lbl deflt @@ -460,7 +460,7 @@ rep = typeWidth cmm_ty -- We find the necessary type information in the literals in the branches - let (signed,range) = case head branches of + let (signed,range) = case branch of (LitNumber nt _, _) -> (signed,range) where signed = litNumIsSigned nt @@ -604,7 +604,7 @@ in InfoProvEnt cl cn "" this_mod Nothing -- | Convert source information collected about identifiers in 'GHC.STG.Debug' --- to entries suitable for placing into the info table provenenance table. +-- to entries suitable for placing into the info table provenance table. convertInfoProvMap :: [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt] convertInfoProvMap defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) = map (\cmit -> diff --git a/GHC/StgToJS.hs b/GHC/StgToJS.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS.hs @@ -0,0 +1,216 @@ +module GHC.StgToJS + ( stgToJS + ) +where + +import GHC.StgToJS.CodeGen + + +-- Note [StgToJS design] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- +-- StgToJS ("JS backend") is adapted from GHCJS [GHCJS2013]. +-- +-- Haskell to JavaScript +-- ~~~~~~~~~~~~~~~~~~~~~ +-- StgToJS converts STG into a JavaScript AST (in GHC.JS) that has been adapted +-- from JMacro [JMacro]. +-- +-- Tail calls: translated code is tail call optimized through a trampoline, +-- since JavaScript implementations don't always support tail calls. +-- +-- JavaScript ASTs are then optimized. A dataflow analysis is performed and then +-- dead code and redundant assignments are removed. +-- +-- Primitives +-- ~~~~~~~~~~ +-- Haskell primitives have to be represented as JavaScript values. This is done +-- as follows: +-- +-- - Int#/Int32# -> number in Int32 range +-- - Int16# -> number in Int16 range +-- - Int8# -> number in Int8 range +-- - Word#/Word32# -> number in Word32 range +-- - Word16# -> number in Word16 range +-- - Word8# -> number in Word8 range +-- +-- - Float#/Double# -> both represented as Javascript Double (no Float!) +-- +-- - Int64# -> represented with two fields: +-- high -> number in Int32 range +-- low -> number in Word32 range +-- - Word64# -> represented with two fields: high, low +-- high -> number in Word32 range +-- low -> number in Word32 range +-- +-- - Addr# -> represented with two fields: array (used as a namespace) and index +-- - StablePtr# -> similar to Addr# with array fixed to h$stablePtrBuf +-- +-- - JSVal# -> any Javascript object (used to pass JS objects via FFI) +-- +-- - TVar#, MVar#, etc. are represented with JS objects +-- +-- Foreign JavaScript imports +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- StgToJS supports inline JavaScript code. Example: +-- +-- > foreign import javascript unsafe +-- > "((x,y) => x + y)" +-- > plus :: Int -> Int -> Int +-- +-- Currently the JS backend only supports functions as JS imports. +-- +-- In comparison, GHCJS supports JavaScript snippets with $1, $2... variables +-- as placeholders for the arguments. It requires a JavaScript parser that the +-- JS backend lacks. In GHCJS, the parser is inherited from JMacro and supports +-- local variable declarations, loops, etc. Local variables are converted to +-- hygienic names to avoid capture. +-- +-- Primitives that are represented as multiple values (Int64#, Word64#, Addr#) +-- are passed to FFI functions with multiple arguments. +-- +-- Interruptible convention: FFI imports with the "interruptible" calling +-- convention are passed an extra argument (usually named "$c") that is a +-- continuation function. The FFI function must call this function to return to +-- Haskell code. +-- +-- Unboxed tuples: returning an unboxed tuple can be done with the predefined +-- macros RETURN_UBX_TUPn where n is the size of the tuples. Internally it uses +-- predefined "h$retN" global variables to pass additional values; the first +-- element of the tuple is returned normally. +-- +-- Memory management +-- ~~~~~~~~~~~~~~~~~ +-- Heap objects are represented as JavaScript values. +-- +-- Most heap objects are represented generically as JavaScript "objects" (hash +-- maps). However, some Haskell heap objects can use use a more memory efficient +-- JavaScript representation: number, string... An example of a consequence of +-- this is that both Int# and Int are represented the same as a JavaScript +-- number. JavaScript introspection (e.g. typeof) is used to differentiate +-- heap object representations when necessary. +-- +-- Generic representation: objects on the heap ("closures") are represented as +-- JavaScript objects with the following fields: +-- +-- { f -- (function) entry function + info table +-- , d1 -- two fields of payload +-- , d2 +-- , m -- GC mark +-- , cc -- optional cost-center +-- } +-- +-- Payload: payload only consists of two fields (d1, d2). When more than two +-- fields of payload are required, the second field is itself an object. +-- payload [] ==> { d1 = null, d2 = null } +-- payload [a] ==> { d1 = a , d2 = null } +-- payload [a,b] ==> { d1 = a , d2 = b } +-- payload [a,b,c] ==> { d1 = a , d2 = { d1 = b, d2 = c} } +-- payload [a,b,c...] ==> { d1 = a , d2 = { d1 = b, d2 = c, ...} } +-- +-- Entry function/ info tables: JavaScript functions are JavaScript objects. If +-- "f" is a function, we can: +-- - call it, e.g. "f(arg0,arg1...)" +-- - get/set its fields, e.g. "f.xyz = abc" +-- This is used to implement the equivalent of tables-next-to-code in +-- JavaScript: every heap object has an entry function "f" that also contains +-- some metadata (info table) about the Haskell object: +-- { t -- object type +-- , size -- number of fields in the payload (-1 if variable layout) +-- , i -- (array) fields layout (empty if variable layout) +-- , n -- (string) object name for easier dubugging +-- , a -- constructor tag / fun arity +-- , r -- ?? +-- , s -- static references? +-- , m -- GC mark? +-- } +-- +-- Payloads for each kind of heap object: +-- +-- THUNK = +-- { f = returns the object reduced to WHNF +-- , m = ? +-- , d1 = ? +-- , d2 = ? +-- } +-- +-- FUN = +-- { f = function itself +-- , m = ? +-- , d1 = free variable 1 +-- , d2 = free variable 2 +-- } +-- +-- There are two different kinds of partial application: +-- - pap_r : pre-generated PAP that contains r registers +-- - pap_gen : generic PAP, contains any number of registers +-- +-- PAP = +-- { f = ? +-- , m = ? +-- , d1 = function +-- , d2 = +-- { d1 & 0xff = number of args (PAP arity) +-- , d1 >> 8 = number of registers (r for h$pap_r) +-- , d2, d3... = args (r) +-- } +-- } +-- +-- CON = +-- { f = entry function of the datacon worker +-- , m = 0 +-- , d1 = first arg +-- , d2 = arity = 2: second arg +-- arity > 2: { d1, d2, ...} object with remaining args (starts with "d1 = x2"!) +-- } +-- +-- BLACKHOLE = +-- { f = h$blackhole +-- , m = ? +-- , d1 = owning TSO +-- , d2 = waiters array +-- } +-- +-- StackFrame closures are *not* represented as JS objects. Instead they are +-- "unpacked" in the stack, i.e. a stack frame occupies a few slots in the JS +-- array representing the stack ("h$stack"). +-- +-- When a shared thunk is entered, it is overriden with a black hole ("eager +-- blackholing") and an update frame is pushed on the stack. +-- +-- Stack: the Haskell stack is implemented with a dynamically growing JavaScript +-- array ("h$stack"). +-- TODO: does it shrink sometimes? +-- TODO: what are the elements of the stack? one JS object per stack frame? +-- +-- +-- Interaction with JavaScript's garbage collector +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Using JS objects to represent Haskell heap objects means that JS's GC does +-- most of the memory management work. +-- +-- However, GHC extends Haskell with features that rely on GC layer violation +-- (weak references, finalizers, etc.). To support these features, a heap scan +-- is can be performed (using TSOs, StablePtr, etc. as roots) to mark reachable +-- objects. Scanning the heap is an expensive operation, but fortunately it +-- doesn't need to happen too often and it can be disabled. +-- +-- TODO: importance of eager blackholing +-- +-- Concurrency +-- ~~~~~~~~~~~ +-- The scheduler is implemented in JS and runs in a single JavaScript thread +-- (similarly to the C RTS not using `-threaded`). +-- +-- The scheduler relies on callbacks/continuations to interact with other JS +-- codes (user interface, etc.). In particular, safe foreign import can use "$c" +-- as a continuation function to return to Haskell code. +-- +-- TODO: is this still true since 2013 or are we using more recent JS features now? +-- TODO: synchronous threads +-- +-- +-- REFERENCES +-- * [GHCJS2013] "Demo Proposal: GHCJS, Concurrent Haskell in the Browser", Luite Stegeman, +-- 2013 (https://www.haskell.org/haskell-symposium/2013/ghcjs.pdf) +-- * [JMacro] https://hackage.haskell.org/package/jmacro diff --git a/GHC/StgToJS/Apply.hs b/GHC/StgToJS/Apply.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Apply.hs @@ -0,0 +1,1152 @@ +{-# 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 +storeIdFields i dst = do + fields <- getIdFields i + pure (assignCoerce1 dst fields) diff --git a/GHC/StgToJS/Arg.hs b/GHC/StgToJS/Arg.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Arg.hs @@ -0,0 +1,285 @@ +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Args +-- 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 +-- +-- Code generation of application arguments +----------------------------------------------------------------------------- + +module GHC.StgToJS.Arg + ( genArg + , genIdArg + , genIdArgI + , genIdStackArgI + , allocConStatic + , allocUnboxedConStatic + , allocateStaticList + , jsStaticArg + , jsStaticArgs + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +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.Profiling +import GHC.StgToJS.Ids + +import GHC.Builtin.Types +import GHC.Stg.Syntax +import GHC.Core.DataCon + +import GHC.Types.CostCentre +import GHC.Types.Unique.FM +import GHC.Types.Id + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Control.Monad.Trans.State.Strict as State + +{- +Note [ Unboxable Literals Optimization ] +~~~~~~~~~~~~~~~~~~ + +Boxable types in the JS backend are represented as heap objects. See Note +[StgToJS design] in GHC.StgToJS.hs for more details. Some types, such as Int8 +do not benefit from not being wrapped in an object in the JS runtime. This optimization +detects such types and changes the code generator to generate a more efficient +representation. The change is minor and saves one level on indirection. Instead +of generating a wrapper object with a field for the value's payload, such as: + +// a JS object for an Int8 +var anInt8 = { d1 = + , f : entry function which would scrutinize the payload + } + +we instead generate: + +// notice, no wrapper object. This representation is essentially an Int8# in the JS backend +var anInt8 = + +This optimization fires when the follow invariants hold: + 1. The value in question has a Type which has a single data constructor + 2. The data constructor holds a single field that is monomorphic + 3. The value in question is distinguishable from a THUNK using the JavaScript typeof operator. + +From the haskell perspective this means that: + 1. An Int8# is always a JavaScript 'number', never a JavaScript object. + 2. An Int8 is either a JavaScript 'number' _or_ a JavaScript object depending on + its use case and this optimization. + +How is this sound? +~~~~~~~~~~~~~~~~~~ + +Normally this optimization would violate the guarantees of call-by-need, however +we are able to statically detect whether the type in question will be a THUNK or +not during code gen because the JS backend is consuming STG and we can check +during runtime with the typeof operator. Similarly we can check at runtime using +JavaScript's introspection operator `typeof`. Thus, when we know the value in +question will not be a THUNK we can safely elide the wrapping object, which +unboxes the value in the JS runtime. For example, an Int8 contains an Int8# +which has the JavaScript type 'number'. A THUNK of type Int8 would have a +JavaScript type 'object', so using 'typeof' allows us to check if we have +something that is definitely evaluated (i.e., a 'number') or something else. If +it is an 'object' then we may need to enter it to begin its evaluation. Consider +a type which has a 'ThreadId#' field; such as type would not be subject to this +optimization because it has to be represented as a JavaScript 'object' and thus +cannot be unboxed in this way. Another (edge) case is Int64#. Int64# is +similarly not unboxable in this way because Int64# does not fit in one +JavaScript variable and thus requires an 'object' for its representation in the +JavaScript runtime. + +-} + +-- | Generate JS code for static arguments +genStaticArg :: HasDebugCallStack => StgArg -> G [StaticArg] +genStaticArg a = case a of + StgLitArg l -> map StaticLitArg <$> genStaticLit l + StgVarArg i -> do + unFloat <- State.gets gsUnfloated + case lookupUFM unFloat i of + Nothing -> reg + Just expr -> unfloated expr + where + r = uTypeVt . stgArgType $ a + reg + | isVoid r = + return [] + | i == trueDataConId = + return [StaticLitArg (BoolLit True)] + | 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 + + 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) + | otherwise = do + as <- concat <$> mapM genStaticArg args + (TxtI e) <- 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 a = case a of + StgLitArg l -> genLit l + StgVarArg i -> do + unFloat <- State.gets gsUnfloated + case lookupUFM unFloat i of + Just expr -> unfloated expr + Nothing + | isVoid r -> return [] + | i == trueDataConId -> return [true_] + | i == falseDataConId -> return [false_] + | isMultiVar r -> mapM (varForIdN i) [1..varSize r] + | otherwise -> (:[]) <$> varForId i + + where + -- if our argument is a joinid, it can be an unboxed tuple + r :: HasDebugCallStack => VarType + r = uTypeVt . stgArgType $ a + + unfloated :: HasDebugCallStack => CgStgExpr -> G [JExpr] + unfloated = \case + StgLit l -> genLit l + StgConApp dc _n args _ + | isBoolDataCon dc || isUnboxableCon dc + -> (:[]) . allocUnboxedCon dc . concat <$> mapM genArg args + | null args -> (:[]) <$> varForId (dataConWorkId dc) + | otherwise -> do + as <- concat <$> mapM genArg args + e <- varForDataConWorker dc + inl_alloc <- csInlineAlloc <$> getSettings + 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] +genIdArg i = genArg (StgVarArg i) + +-- | Generate an Id as an Ident +genIdArgI :: HasDebugCallStack => Id -> G [Ident] +genIdArgI i + | isVoid r = return [] + | isMultiVar r = mapM (identForIdN i) [1..varSize r] + | otherwise = (:[]) <$> identForId i + where + r = uTypeVt . idType $ i + +-- | Generate IDs for stack arguments. See 'StgToJS.Expr.loadRetArgs' for use case +genIdStackArgI :: HasDebugCallStack => Id -> G [(Ident,StackSlot)] +genIdStackArgI i = zipWith f [1..] <$> genIdArgI i + where + f :: Int -> Ident -> (Ident,StackSlot) + f n ident = (ident, SlotId i n) + +-- | Allocate Static Constructors +allocConStatic :: HasDebugCallStack => Ident -> CostCentreStack -> DataCon -> [StgArg] -> G () +allocConStatic (TxtI to) cc con args = do + as <- mapM genStaticArg args + cc' <- costCentreStackLbl cc + allocConStatic' cc' (concat as) + where + -- see Note [ Unboxable Literals Optimization ] for the purpose of these + -- checks + allocConStatic' :: HasDebugCallStack => Maybe Ident -> [StaticArg] -> G () + allocConStatic' cc' [] + | isBoolDataCon con && dataConTag con == 1 = + emitStatic to (StaticUnboxed $ StaticUnboxedBool False) cc' + | isBoolDataCon con && dataConTag con == 2 = + emitStatic to (StaticUnboxed $ StaticUnboxedBool True) cc' + | otherwise = do + (TxtI e) <- identForDataConWorker con + emitStatic to (StaticData e []) cc' + allocConStatic' cc' [x] + | isUnboxableCon con = + case x of + StaticLitArg (IntLit i) -> + emitStatic to (StaticUnboxed $ StaticUnboxedInt i) cc' + StaticLitArg (BoolLit b) -> + emitStatic to (StaticUnboxed $ StaticUnboxedBool b) cc' + StaticLitArg (DoubleLit d) -> + emitStatic to (StaticUnboxed $ StaticUnboxedDouble d) cc' + _ -> + pprPanic "allocConStatic: invalid unboxed literal" (ppr x) + allocConStatic' cc' xs = + if con == consDataCon + then case args of + (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' + +-- | Allocate unboxed constructors +allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg +allocUnboxedConStatic con = \case + [] + | isBoolDataCon con && dataConTag con == 1 + -> StaticLitArg (BoolLit False) + | isBoolDataCon con && dataConTag con == 2 + -> StaticLitArg (BoolLit True) + [a@(StaticLitArg (IntLit _i))] -> a + [a@(StaticLitArg (DoubleLit _d))] -> a + _ -> pprPanic "allocUnboxedConStatic: not an unboxed constructor" (ppr con) + + +-- | Allocate Static list +allocateStaticList :: [StgArg] -> StgArg -> G StaticVal +allocateStaticList xs a@(StgVarArg i) + | isDataConId_maybe i == Just nilDataCon = listAlloc xs Nothing + | otherwise = do + unFloat <- State.gets gsUnfloated + case lookupUFM unFloat i of + Just (StgConApp dc _n [h,t] _) + | dc == consDataCon -> allocateStaticList (h:xs) t + _ -> listAlloc xs (Just a) + where + listAlloc :: [StgArg] -> Maybe StgArg -> G StaticVal + listAlloc xs Nothing = do + as <- concat . reverse <$> mapM genStaticArg xs + return (StaticList as Nothing) + listAlloc xs (Just r) = do + as <- concat . reverse <$> mapM genStaticArg xs + r' <- genStaticArg r + case r' of + [StaticObjArg ri] -> return (StaticList as (Just ri)) + _ -> + pprPanic "allocateStaticList: invalid argument (tail)" (ppr (xs, r)) +allocateStaticList _ _ = panic "allocateStaticList: unexpected literal in list" + +-- | Generate JS code corresponding to a static arg +jsStaticArg :: StaticArg -> JExpr +jsStaticArg = \case + StaticLitArg l -> toJExpr l + StaticObjArg t -> ValExpr (JVar (TxtI t)) + StaticConArg c args -> + allocDynamicE False (ValExpr . JVar . TxtI $ c) (map jsStaticArg args) Nothing + +-- | Generate JS code corresponding to a list of static args +jsStaticArgs :: [StaticArg] -> JExpr +jsStaticArgs = ValExpr . JList . map jsStaticArg + diff --git a/GHC/StgToJS/Closure.hs b/GHC/StgToJS/Closure.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Closure.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module GHC.StgToJS.Closure + ( closureInfoStat + , closure + , conClosure + , Closure (..) + , newClosure + , assignClosure + , CopyCC (..) + , copyClosure + ) +where + +import GHC.Prelude +import GHC.Data.FastString + +import GHC.StgToJS.Heap +import GHC.StgToJS.Types +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Regs (stack,sp) + +import GHC.JS.Make +import GHC.JS.Syntax + +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 + where + !ty = case ctype of + CIThunk -> Thunk + CIFun {} -> Fun + CICon {} -> Con + CIBlackhole -> Blackhole + CIPap -> Pap + CIStackFrame -> StackFrame + !tag = case ctype of + CIThunk -> 0 + CIFun arity nregs -> mkArityTag arity nregs + CICon con -> con + CIBlackhole -> 0 + CIPap -> 0 + CIStackFrame -> 0 + + +setObjInfoL :: Bool -- ^ debug: output symbol names + -> Ident -- ^ the object name + -> CIRegs -- ^ things in registers + -> CILayout -- ^ layout of the object + -> ClosureType -- ^ closure type + -> FastString -- ^ object name, for printing + -> Int -- ^ `a' argument, depends on type (arity, conid) + -> CIStatic -- ^ static refs + -> JStat +setObjInfoL debug obj rs layout t n a + = setObjInfo debug obj t n field_types a size rs + where + size = case layout of + CILayoutVariable -> (-1) + CILayoutUnknown sz -> sz + CILayoutFixed sz _ -> sz + field_types = case layout of + CILayoutVariable -> [] + CILayoutUnknown size -> toTypeList (replicate size ObjV) + CILayoutFixed _ fs -> toTypeList fs + +setObjInfo :: Bool -- ^ debug: output all symbol names + -> Ident -- ^ the thing to modify + -> ClosureType -- ^ closure type + -> FastString -- ^ object name, for printing + -> [Int] -- ^ list of item types in the object, if known (free variables, datacon fields) + -> Int -- ^ extra 'a' parameter, for constructor tag or arity + -> Int -- ^ object size, -1 (number of vars) for unknown + -> CIRegs -- ^ things in registers + -> CIStatic -- ^ static refs + -> JStat +setObjInfo debug obj t name fields a size regs static + | debug = appS "h$setObjInfo" [ toJExpr obj + , toJExpr t + , toJExpr name + , toJExpr fields + , toJExpr a + , toJExpr size + , toJExpr (regTag regs) + , toJExpr static + ] + | otherwise = appS "h$o" [ toJExpr obj + , toJExpr t + , toJExpr a + , toJExpr size + , toJExpr (regTag regs) + , toJExpr static + ] + where + regTag CIRegsUnknown = -1 + regTag (CIRegs skip types) = + let nregs = sum $ map 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 + +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)) + +-- | Used to pass arguments to newClosure with some safety +data Closure = Closure + { clEntry :: JExpr + , clField1 :: JExpr + , clField2 :: JExpr + , clMeta :: JExpr + , clCC :: Maybe JExpr + } + +newClosure :: Closure -> JExpr +newClosure Closure{..} = + let xs = [ (closureEntry_ , clEntry) + , (closureField1_, clField1) + , (closureField2_, clField2) + , (closureMeta_ , clMeta) + ] + in case clCC of + -- CC field is optional (probably to minimize code size as we could assign + -- null_, but we get the same effect implicitly) + Nothing -> ValExpr (jhFromList xs) + Just cc -> ValExpr (jhFromList $ (closureCC_,cc) : xs) + +assignClosure :: JExpr -> Closure -> JStat +assignClosure t Closure{..} = BlockStat + [ closureEntry t |= clEntry + , closureField1 t |= clField1 + , closureField2 t |= clField2 + , closureMeta t |= clMeta + ] <> case clCC of + Nothing -> mempty + Just cc -> closureCC t |= cc + +data CopyCC = CopyCC | DontCopyCC + +copyClosure :: CopyCC -> JExpr -> JExpr -> JStat +copyClosure copy_cc t s = BlockStat + [ closureEntry t |= closureEntry s + , closureField1 t |= closureField1 s + , closureField2 t |= closureField2 s + , closureMeta t |= closureMeta s + ] <> case copy_cc of + DontCopyCC -> mempty + CopyCC -> closureCC t |= closureCC s diff --git a/GHC/StgToJS/CodeGen.hs b/GHC/StgToJS/CodeGen.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/CodeGen.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +-- | JavaScript code generator +module GHC.StgToJS.CodeGen + ( stgToJS + ) +where + +import GHC.Prelude + +import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js)) + +import GHC.JS.Ppr +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Transform + +import GHC.StgToJS.Arg +import GHC.StgToJS.Sinker +import GHC.StgToJS.Types +import qualified GHC.StgToJS.Object as Object +import GHC.StgToJS.StgUtils +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Deps +import GHC.StgToJS.Expr +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Monad +import GHC.StgToJS.Profiling +import GHC.StgToJS.Regs +import GHC.StgToJS.StaticPtr +import GHC.StgToJS.Symbols +import GHC.StgToJS.Stack +import GHC.StgToJS.Ids + +import GHC.Stg.Syntax +import GHC.Core.DataCon +import GHC.Core.TyCo.Rep (scaledThing) + +import GHC.Unit.Module +import GHC.Linker.Types (SptEntry (..)) + +import GHC.Types.CostCentre +import GHC.Types.ForeignStubs (ForeignStubs (..), getCHeader, getCStub) +import GHC.Types.RepType +import GHC.Types.Id +import GHC.Types.Unique + +import GHC.Data.FastString +import GHC.Utils.Encoding +import GHC.Utils.Logger +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Binary +import qualified Control.Monad.Trans.State.Strict as State +import GHC.Utils.Outputable hiding ((<>)) + +import qualified Data.Set as S +import Data.Monoid +import Control.Monad +import System.Directory +import System.FilePath + +-- | Code generator for JavaScript +stgToJS + :: Logger + -> StgToJSConfig + -> [CgStgTopBinding] + -> Module + -> [SptEntry] + -> ForeignStubs + -> CollectedCCs + -> FilePath -- ^ Output file name + -> IO () +stgToJS logger config stg_binds0 this_mod spt_entries foreign_stubs cccs output_fn = do + + let (unfloated_binds, stg_binds) = sinkPgm this_mod stg_binds0 + -- 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 + + (deps,lus) <- runG config this_mod unfloated_binds $ do + ifProfilingM $ initCostCentres cccs + lus <- genUnits this_mod stg_binds spt_entries foreign_stubs + deps <- genDependencyData this_mod lus + pure (deps,lus) + + -- 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) + + -- Write the object file + bh <- openBinMem (4 * 1024 * 1000) -- a bit less than 4kB + Object.putObject bh (moduleName this_mod) deps (map luObjUnit lus) + + createDirectoryIfMissing True (takeDirectory output_fn) + writeBinMem bh output_fn + + + +-- | Generate the ingredients for the linkable units for this module +genUnits :: HasDebugCallStack + => Module + -> [CgStgTopBinding] + -> [SptEntry] + -> ForeignStubs + -> G [LinkableUnit] -- ^ the linkable units +genUnits m ss spt_entries foreign_stubs = do + gbl <- generateGlobalBlock + exports <- generateExportsBlock + others <- go 2 ss + pure (gbl:exports:others) + where + go :: HasDebugCallStack + => Int -- the block we're generating (block 0 is the global unit for the module) + -> [CgStgTopBinding] + -> G [LinkableUnit] + go !n = \case + [] -> pure [] + (x:xs) -> do + mlu <- generateBlock x n + lus <- go (n+1) xs + return (maybe lus (:lus) mlu) + + -- Generate the global unit that all other blocks in the module depend on + -- used for cost centres and static initializers + -- the global unit has no dependencies, exports the moduleGlobalSymbol + generateGlobalBlock :: HasDebugCallStack => G LinkableUnit + generateGlobalBlock = do + glbl <- State.gets gsGlobal + staticInit <- + initStaticPtrs spt_entries + let stat = ( -- O.optimize . + jsSaturate (Just $ modulePrefix m 1) + $ mconcat (reverse glbl) <> staticInit) + let syms = [moduleGlobalSymbol m] + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = [] + , oiStat = stat + , oiRaw = mempty + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = [] + , luOtherExports = syms + , luIdDeps = [] + , luPseudoIdDeps = [] + , luOtherDeps = [] + , luRequired = False + , luForeignRefs = [] + } + pure lu + + generateExportsBlock :: HasDebugCallStack => G LinkableUnit + generateExportsBlock = do + let (f_hdr, f_c) = case foreign_stubs of + NoStubs -> (empty, empty) + ForeignStubs hdr c -> (getCHeader hdr, getCStub c) + unique_deps = map mkUniqueDep (lines $ renderWithContext defaultSDocContext f_hdr) + mkUniqueDep (tag:xs) = mkUnique tag (read xs) + mkUniqueDep [] = panic "mkUniqueDep" + + let syms = [moduleExportsSymbol m] + let raw = utf8EncodeByteString $ renderWithContext defaultSDocContext f_c + let oi = ObjUnit + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = [] + , oiStat = mempty + , oiRaw = raw + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = [] + , luOtherExports = syms + , luIdDeps = [] + , luPseudoIdDeps = unique_deps + , luOtherDeps = [] + , luRequired = True + , luForeignRefs = [] + } + pure lu + + -- Generate the linkable unit for one binding or group of + -- mutually recursive bindings + generateBlock :: HasDebugCallStack + => CgStgTopBinding + -> Int + -> G (Maybe LinkableUnit) + 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) + 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 + { oiSymbols = syms + , oiClInfo = [] + , oiStatic = si + , oiStat = stat + , oiRaw = "" + , oiFExports = [] + , oiFImports = [] + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = ids + , luOtherExports = [] + , luIdDeps = [] + , luPseudoIdDeps = [] + , luOtherDeps = [] + , luRequired = False + , luForeignRefs = [] + } + pure (Just lu) + _ -> panic "generateBlock: invalid size" + + StgTopLifted decl -> do + tl <- genToplevel decl + extraTl <- State.gets (ggsToplevelStats . gsGroup) + ci <- State.gets (ggsClosureInfo . gsGroup) + si <- State.gets (ggsStatic . gsGroup) + unf <- State.gets gsUnfloated + extraDeps <- State.gets (ggsExtraDeps . gsGroup) + fRefs <- State.gets (ggsForeignRefs . gsGroup) + resetGroup + 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 + { oiSymbols = syms + , oiClInfo = ci + , oiStatic = si + , oiStat = stat + , oiRaw = "" + , oiFExports = [] + , oiFImports = fRefs + } + let lu = LinkableUnit + { luObjUnit = oi + , luIdExports = topDeps + , luOtherExports = [] + , luIdDeps = allDeps + , luPseudoIdDeps = [] + , luOtherDeps = S.toList extraDeps + , luRequired = required + , luForeignRefs = fRefs + } + 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 (StgNonRec bndr rhs) = genToplevelDecl bndr rhs +genToplevel (StgRec bs) = + mconcat <$> mapM (\(bndr, rhs) -> genToplevelDecl bndr rhs) bs + +genToplevelDecl :: Id -> CgStgRhs -> G JStat +genToplevelDecl i rhs = do + s1 <- resetSlots (genToplevelConEntry i rhs) + s2 <- resetSlots (genToplevelRhs i rhs) + return (s1 <> s2) + +genToplevelConEntry :: Id -> CgStgRhs -> G JStat +genToplevelConEntry i rhs = case rhs of + StgRhsCon _cc con _mu _ts _args + | isDataConWorkId i + -> genSetConInfo i con (stgRhsLive rhs) -- NoSRT + StgRhsClosure _ _cc _upd_flag _args _body + | Just dc <- isDataConWorkId_maybe i + -> genSetConInfo i dc (stgRhsLive rhs) -- srt + _ -> pure mempty + +genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat +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) + (dataConRepArgTys d) + -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d) + +mkDataEntry :: JExpr +mkDataEntry = ValExpr $ JFunc [] returnStack + +genToplevelRhs :: Id -> CgStgRhs -> G JStat +-- general cases: +genToplevelRhs i rhs = case rhs of + StgRhsCon cc con _mu _tys args -> do + ii <- identForId i + allocConStatic ii cc con args + return mempty + StgRhsClosure _ext cc _upd_flag {- srt -} args body -> do + {- + algorithm: + - collect all Id refs that are in the global id cache + - count usage in body for each ref + - 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 + 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) <- + 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) + setcc <- ifProfiling $ + if et == CIThunk + then enterCostCentreThunk + else enterCostCentreFun cc + emitClosureInfo (ClosureInfo eid + regs + idt + (fixedLayout $ map (uTypeVt . idType) lids) + et + sr) + ccId <- costCentreStackLbl cc + emitStatic idt static ccId + return $ (eid ||= toJExpr (JFunc [] (ll <> upd <> setcc <> body))) diff --git a/GHC/StgToJS/CoreUtils.hs b/GHC/StgToJS/CoreUtils.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/CoreUtils.hs @@ -0,0 +1,282 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/DataCon.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.DataCon +-- 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 +-- +-- Code generation of data constructors +----------------------------------------------------------------------------- + +module GHC.StgToJS.DataCon + ( genCon + , allocCon + , allocUnboxedCon + , allocDynamicE + , allocDynamic + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +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 + +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 ctx con args + | isUnboxedTupleDataCon con + = return $ assignToExprCtx ctx args + + | [ValExpr (JVar 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)) + +-- | Allocate a data constructor. Allocate in this context means bind the data +-- constructor to 'to' +allocCon :: Ident -> DataCon -> CostCentreStack -> [JExpr] -> G JStat +allocCon to con cc xs + | isBoolDataCon con || isUnboxableCon con = + return (toJExpr to |= allocUnboxedCon con xs) +{- | null xs = do + i <- varForId (dataConWorkId con) + return (assignj to i) -} + | otherwise = do + e <- varForDataConWorker con + cs <- getSettings + prof <- profiling + ccsJ <- if prof then ccsVarJ cc else return Nothing + return $ allocDynamic cs False to e xs ccsJ + +-- | 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 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)) + +-- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout. +allocDynamicE :: Bool -- ^ csInlineAlloc from StgToJSConfig + -> JExpr + -> [JExpr] + -> Maybe JExpr + -> JExpr +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) + 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 s need_decl to entry free cc + | need_decl = DeclStat to (Just value) + | otherwise = toJExpr to |= value + where + value = allocDynamicE (csInlineAlloc s) entry free cc diff --git a/GHC/StgToJS/Deps.hs b/GHC/StgToJS/Deps.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Deps.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Deps +-- 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 to calculate the transitive dependencies of a module +----------------------------------------------------------------------------- + +module GHC.StgToJS.Deps + ( genDependencyData + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Object as Object +import GHC.StgToJS.Types +import GHC.StgToJS.Ids + +import GHC.JS.Syntax + +import GHC.Types.Id +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Name + +import GHC.Unit.Module + +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.FastString + +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.IntMap as IM +import Data.IntMap (IntMap) +import Data.Array +import Data.Either +import Control.Monad + +import Control.Monad.Trans.Class +import Control.Monad.Trans.State + +data DependencyDataCache = DDC + { ddcModule :: !(IntMap Unit) -- ^ Unique Module -> Unit + , ddcId :: !(IntMap Object.ExportedFun) -- ^ Unique Id -> Object.ExportedFun (only to other modules) + , ddcOther :: !(Map OtherSymb Object.ExportedFun) + } + +-- | Generate module dependency data +-- +-- Generate the object's dependency data, taking care that package and module names +-- are only stored once +genDependencyData + :: HasDebugCallStack + => Module + -> [LinkableUnit] + -> G Object.Deps +genDependencyData mod units = do + -- [(blockindex, blockdeps, required, exported)] + ds <- evalStateT (mapM (uncurry oneDep) blocks) + (DDC IM.empty IM.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) + } + where + -- Id -> Block + unitIdExports :: UniqFM Id Int + unitIdExports = listToUFM $ + concatMap (\(u,n) -> map (,n) (luIdExports u)) blocks + + -- OtherSymb -> Block + unitOtherExports :: Map OtherSymb Int + unitOtherExports = M.fromList $ + concatMap (\(u,n) -> map (,n) + (map (OtherSymb mod) + (luOtherExports u))) + blocks + + blocks :: [(LinkableUnit, Int)] + blocks = zip units [0..] + + -- generate the list of exports and set of dependencies for one unit + oneDep :: LinkableUnit + -> Int + -> StateT DependencyDataCache G (Int, Object.BlockDeps, Bool, [Object.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 + 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) + return (n, bdeps, req, expi++expo) + + idModule :: Id -> Maybe Module + idModule i = nameModule_maybe (getName i) >>= \m -> + guard (m /= mod) >> return m + + lookupPseudoIdFun :: Int -> Unique + -> StateT DependencyDataCache G (Either Object.ExportedFun Int) + lookupPseudoIdFun _n u = + case lookupUFM_Directly unitIdExports u of + Just k -> return (Right k) + _ -> panic "lookupPseudoIdFun" + + -- get the function for an Id from the cache, add it if necessary + -- result: Left Object.ExportedFun if function refers to another module + -- Right blockNumber if function refers to current module + -- + -- 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) + 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 = do + (TxtI idTxt) <- lift (identForId i) + lookupExternalFun (Just k) (OtherSymb m idTxt) + in if m == mod + then pprPanic "local id not found" (ppr m) + else Left <$> do + mr <- gets (IM.lookup k . ddcId) + maybe addEntry return mr + + -- get the function for an OtherSymb from the cache, add it if necessary + lookupOtherFun :: OtherSymb + -> StateT DependencyDataCache G (Either Object.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 -> Left <$> (maybe (lookupExternalFun Nothing od) return =<< + gets (M.lookup od . ddcOther)) + + lookupExportedId :: Id -> StateT DependencyDataCache G Object.ExportedFun + lookupExportedId i = do + (TxtI idTxt) <- lift (identForId i) + lookupExternalFun (Just . getKey . getUnique $ i) (OtherSymb mod idTxt) + + lookupExportedOther :: FastString -> StateT DependencyDataCache G Object.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 Int + -> OtherSymb -> StateT DependencyDataCache G Object.ExportedFun + lookupExternalFun mbIdKey od@(OtherSymb m idTxt) = do + let mk = getKey . getUnique $ m + mpk = moduleUnit m + exp_fun = Object.ExportedFun m (LexicalFastString idTxt) + addCache = do + ms <- gets ddcModule + let !cache' = IM.insert mk mpk ms + modify (\s -> s { ddcModule = cache'}) + pure exp_fun + f <- do + mbm <- gets (IM.member mk . ddcModule) + case mbm of + False -> addCache + True -> pure exp_fun + + case mbIdKey of + Nothing -> modify (\s -> s { ddcOther = M.insert od f (ddcOther s) }) + Just k -> modify (\s -> s { ddcId = IM.insert k f (ddcId s) }) + + return f diff --git a/GHC/StgToJS/Expr.hs b/GHC/StgToJS/Expr.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Expr.hs @@ -0,0 +1,1045 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.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 +-- +-- Code generation of Expressions +----------------------------------------------------------------------------- + +module GHC.StgToJS.Expr + ( genExpr + , genEntryType + , loadLiveFun + , genStaticRefsRhs + , genStaticRefs + , genBody + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Apply +import GHC.StgToJS.Arg +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.Literal +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.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.Stg.Syntax +import GHC.Stg.Utils + +import GHC.Builtin.PrimOps + +import GHC.Core +import GHC.Core.TyCon +import GHC.Core.DataCon +import GHC.Core.Opt.Arity (isOneShotBndr) +import GHC.Core.Type hiding (typeSize) + +import GHC.Utils.Misc +import GHC.Utils.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.Data.List.SetOps as ListSetOps + +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 +import Control.Monad +import Control.Arrow ((&&&)) + +-- | Evaluate an expression in the given expression context (continuation) +genExpr :: HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, 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) + StgConApp con _n args _ -> do + as <- concatMapM genArg args + c <- genCon ctx con as + return (c, ExprInline (Just as)) + StgOpApp (StgFCallOp f _) args t + -> genForeignCall ctx f t (concatMap typex_expr $ ctxTarget ctx) args + StgOpApp (StgPrimOp op) args t + -> genPrimOp ctx op args t + StgOpApp (StgPrimCallOp c) args t + -> genPrimCall ctx c args t + StgCase e b at alts + -> genCase ctx b e at alts (liveVars $ stgExprLive False stg) + StgLet _ b e -> do + (b',ctx') <- genBind ctx b + (s,r) <- genExpr ctx' e + return (b' <> s, r) + StgLetNoEscape _ b e -> do + (b', ctx') <- genBindLne ctx b + (s, r) <- genExpr ctx' e + return (b' <> s, r) + StgTick (ProfNote cc count scope) e -> do + setSCCstats <- ifProfilingM $ setCC cc count scope + (stats, result) <- genExpr ctx e + return (setSCCstats <> stats, result) + StgTick (SourceNote span _sname) e + -> genExpr (ctxSetSrcSpan span ctx) e + StgTick _m e + -> genExpr ctx e + +-- | regular let binding: allocate heap object +genBind :: HasDebugCallStack + => ExprCtx + -> CgStgBinding + -> G (JStat, 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)]) + 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) + where + ctx' = ctxClearLneFrame ctx + + assign :: Id -> CgStgRhs -> G (Maybe JStat) + assign b (StgRhsClosure _ _ccs {-[the_fv]-} _upd [] expr) + | let strip = snd . stripStgTicksTop (not . tickishIsCode) + , StgCase (StgApp scrutinee []) _ (AlgAlt _) [GenStgAlt (DataAlt _) params sel_expr] <- strip expr + , StgApp selectee [] <- strip sel_expr + , let params_w_offsets = zip params (L.scanl' (+) 1 $ map (typeSize . idType) params) + , let total_size = sum (map (typeSize . idType) params) + -- , the_fv == scrutinee -- fixme check + , Just the_offset <- ListSetOps.assocMaybe params_w_offsets selectee + , the_offset <= 16 -- fixme make this some configurable constant + = do + let the_fv = scrutinee -- error "the_fv" -- fixme + let sel_tag | the_offset == 2 = if total_size == 2 then "2a" + else "2b" + | otherwise = show the_offset + tgts <- identsForId b + 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]) + _ -> panic "genBind.assign: invalid size" + assign b (StgRhsClosure _ext _ccs _upd [] expr) + | snd (isInlineExpr (ctxEvaluatedIds ctx) expr) = do + d <- declVarsForId b + tgt <- varsForId b + let ctx' = ctx { ctxTarget = assocIdExprs b tgt } + (j, _) <- genExpr ctx' expr + return (Just (d <> j)) + 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) +genBindLne ctx bndr = do + -- compute live variables and the offsets where they will be stored in the + -- stack + vis <- map (\(x,y,_) -> (x,y)) <$> + optimizeFree oldFrameSize (newLvs++map fst updBinds) + -- initialize updatable bindings to null_ + declUpds <- mconcat <$> mapM (fmap (||= null_) . identForId . fst) updBinds + -- update expression context to include the updated LNE frame + let ctx' = ctxUpdateLneFrame vis bound ctx + mapM_ (uncurry $ genEntryLne ctx') binds + return (declUpds, ctx') + where + oldFrameSize = ctxLneFrameSize ctx + isOldLv i = ctxIsLneBinding ctx i || + ctxIsLneLiveVar ctx i + live = liveVars $ mkDVarSet $ stgLneLive' bndr + newLvs = filter (not . isOldLv) (dVarSetElems live) + binds = case bndr of + StgNonRec b e -> [(b,e)] + StgRec bs -> bs + bound = map fst binds + (updBinds, _nonUpdBinds) = L.partition (isUpdatableRhs . snd) binds + +-- | Generate let-no-escape entry +-- +-- Let-no-escape entries live on the stack. There is no heap object associated with them. +-- +-- A let-no-escape entry is called like a normal stack frame, although as an optimization, +-- `Stack`[`Sp`] is not set when making the call. This is done later if the +-- thread needs to be suspended. +-- +-- Updatable let-no-escape binders have one 'private' slot in the stack frame. This slot +-- 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) = + resetSlots $ do + let payloadSize = ctxLneFrameSize ctx + vars = ctxLneFrameVars ctx + myOffset = + 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 + 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 payloadSize = ctxLneFrameSize ctx + ei@(TxtI _eii) <- 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]))) + +-- | 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 + ll <- loadLiveFun live + llv <- verifyRuntimeReps live + upd <- genUpdFrame upd_flag i + body <- genBody entryCtx i R2 args body + ei@(TxtI eii) <- identForEntryId i + et <- genEntryType args + setcc <- ifProfiling $ + if et == CIThunk + then enterCostCentreThunk + else enterCostCentreFun cc + sr <- genStaticRefsRhs rhs + emitClosureInfo $ ClosureInfo ei + (CIRegs 0 $ PtrV : concatMap idVt args) + (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i))) + (fixedLayout $ map (uTypeVt . idType) live) + et + sr + emitToplevel (ei ||= toJExpr (JFunc [] (mconcat [ll, llv, upd, setcc, body]))) + where + entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx) + +-- | Generate the entry function types for identifiers. Note that this only +-- returns either 'CIThunk' or 'CIFun'. Everything else (PAP Blackhole etc.) is +-- filtered as not a RuntimeRepKinded type. +genEntryType :: HasDebugCallStack => [Id] -> G CIType +genEntryType [] = return CIThunk +genEntryType args0 = 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 + -- load arguments into local variables + la <- do + args' <- concatMapM genIdArgI args + return (declAssignAll args' (fmap toJExpr [startReg..])) + + -- assert that arguments have valid runtime reps + lav <- verifyRuntimeReps args + + -- compute PrimReps and their number of slots required to return the result of + -- i applied to args. + let res_vars = resultSize args i + + -- compute typed expressions for each slot and assign registers + let go_var regs = \case + [] -> [] + ((rep,size):rs) -> + let !(regs0,regs1) = splitAt size regs + !ts = go_var regs1 rs + in TypedExpr rep regs0 : ts + + let tgt = go_var jsRegsFromR1 res_vars + let !ctx' = ctx { ctxTarget = tgt } + + -- generate code for the expression + (e, _r) <- genExpr ctx' e + + return $ la <> lav <> e <> returnStack + +-- | Find the result type after applying the function to the arguments +-- +-- It's trickier than it looks because: +-- +-- 1. we don't have the Arity of the Id. The following functions return +-- different values in some cases: +-- - idArity +-- - typeArity . idType +-- - idFunRepArity +-- - typeArity . unwrapType . idType +-- Moreover the number of args may be different than all of these arities +-- +-- 2. sometimes the type is Any, perhaps after some unwrapping. For example +-- HappyAbsSyn is a newtype around HappyAny which is Any or (forall a. a). +-- +-- 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 +-- 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 + 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] + +-- | 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 xs = do + runtime_assert <- csRuntimeAssert <$> getSettings + if not runtime_assert + then pure mempty + else mconcat <$> mapM verifyRuntimeRep xs + where + verifyRuntimeRep i = do + i' <- varsForId i + pure $ go i' (idVt 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 + go (j:js) (v:vs) = ver j v <> go js vs + go [] [] = mempty + 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 + +-- | 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 l = do + l' <- concat <$> mapM identsForId l + case l' of + [] -> return mempty + -- set the ident to d1 field of register 1 + [v] -> return (v ||= r1 .^ closureField1_) + -- set the idents to d1 and d2 fields of register 1 + [v1,v2] -> return $ mconcat + [ v1 ||= r1 .^ closureField1_ + , v2 ||= r1 .^ closureField2_ + ] + -- and so on + (v:vs) -> do + d <- freshIdent + let l'' = mconcat . zipWith (loadLiveVar $ toJExpr d) [(1::Int)..] $ vs + return $ mconcat + [ v ||= r1 .^ closureField1_ + , d ||= r1 .^ closureField2_ + , l'' + ] + where + loadLiveVar d n v = let ident = TxtI (dataFieldName n) + in v ||= SelExpr d ident + +-- | Pop a let-no-escape frame off the stack +popLneFrame :: Bool -> Int -> ExprCtx -> G JStat +popLneFrame inEntry size ctx = do + -- calculate the new stack size + let ctx' = ctxLneShrinkStack ctx size + + let gen_id_slot (i,n) = do + ids <- identsForId i + let !id_n = ids !! (n-1) + pure (id_n, SlotId i n) + + is <- mapM gen_id_slot (ctxLneFrameVars ctx') + + let skip = if inEntry then 1 else 0 -- pop the frame header + popSkipI skip is + +-- | Generate an updated given an 'Id' +genUpdFrame :: UpdateFlag -> Id -> G JStat +genUpdFrame u i + | isReEntrant u = pure mempty + | isOneShotBndr i = maybeBh + | isUpdatable u = updateThunk + | otherwise = maybeBh + where + isReEntrant ReEntrant = True + isReEntrant _ = False + maybeBh = do + settings <- getSettings + assertRtsStat (return $ bhSingleEntry settings) + +-- | Blackhole single entry +-- +-- Overwrite a single entry object with a special thunk that behaves like a +-- black hole (throws a JS exception when entered) but pretends to be a thunk. +-- Useful for making sure that the object is not accidentally entered multiple +-- times +-- +bhSingleEntry :: StgToJSConfig -> JStat +bhSingleEntry _settings = mconcat + [ r1 .^ closureEntry_ |= var "h$blackholeTrap" + , r1 .^ closureField1_ |= undefined_ + , r1 .^ closureField2_ |= undefined_ + ] + +genStaticRefsRhs :: CgStgRhs -> G CIStatic +genStaticRefsRhs lv = genStaticRefs (stgRhsLive lv) + +-- fixme, update to new way to compute static refs dynamically +genStaticRefs :: LiveVars -> G CIStatic +genStaticRefs lv + | isEmptyDVarSet sv = return (CIStaticRefs []) + | otherwise = do + unfloated <- State.gets gsUnfloated + let xs = filter (\x -> not (elemUFM x unfloated || + typeLevity_maybe (idType x) == Just Unlifted)) + (dVarSetElems sv) + CIStaticRefs . catMaybes <$> mapM getStaticRef xs + where + sv = liveStatic lv + + getStaticRef :: Id -> G (Maybe FastString) + getStaticRef = fmap (fmap itxt . 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 +optimizeFree + :: HasDebugCallStack + => Int + -> [Id] + -> G [(Id,Int,Bool)] -- ^ A list of stack slots. + -- -- Id: stored on the slot + -- -- Int: the part of the value that is stored + -- -- 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 + idSize :: Id -> Int + idSize i = sum $ map varSize (typeVt . idType $ i) + ids' = concatMap (\i -> map (i,) [1..idSize i]) ids + -- 1..varSize] . uTypeVt . idType $ i]) (typeVt 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' + 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 + allSlots = L.sortBy (compare `on` \(_,_,x,_) -> x) (fixed ++ remaining') + return $ map (\(i,n,_,b) -> (i,n,b)) allSlots + +-- | Allocate local closures +allocCls :: Maybe JStat -> [(Id, CgStgRhs)] -> G JStat +allocCls dynMiddle xs = do + (stat, dyn) <- partitionEithers <$> mapM toCl xs + ac <- allocDynAll True dynMiddle dyn + pure (mconcat stat <> ac) + where + -- left = static, right = dynamic + toCl :: (Id, CgStgRhs) + -> G (Either JStat (Ident,JExpr,[JExpr],CostCentreStack)) + -- statics + {- making zero-arg constructors static is problematic, see #646 + proper candidates for this optimization should have been floated + already + 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 + ii <- identForId i + ac <- allocCon ii con cc =<< genArg a + pure (Left (decl ii <> ac)) + + -- dynamics + toCl (i, StgRhsCon cc con _mu _ticks ar) = + -- 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)) = + let live = stgLneLiveExpr cl + in Right <$> ((,,,) <$> identForId i + <*> varForEntryId i + <*> concatMapM varsForId live + <*> pure cc) + +-- fixme CgCase has a reps_compatible check here +-- | Consume Stg case statement and generate a case statement. See also +-- 'genAlts' +genCase :: HasDebugCallStack + => ExprCtx + -> Id + -> CgStgExpr + -> AltType + -> [CgStgAlt] + -> LiveVars + -> G (JStat, ExprResult) +genCase ctx bnd e at alts l + | snd (isInlineExpr (ctxEvaluatedIds ctx) 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) + + (aj, ar) <- genAlts (ctxAssertEvaluated bnd ctx) bnd at d alts + (saveCCS,restoreCCS) <- ifProfilingM $ do + ccsVar <- freshIdent + pure ( ccsVar ||= toJExpr jCurrentCCS + , toJExpr jCurrentCCS |= toJExpr ccsVar + ) + return ( mconcat + [ mconcat (map decl bndi) + , saveCCS + , ej + , restoreCCS + , aj + ] + , ar + ) + | otherwise = do + rj <- genRet (ctxAssertEvaluated bnd ctx) bnd at alts l + let ctx' = ctxSetTop bnd + $ ctxSetTarget (assocIdExprs bnd (map toJExpr [R1 ..])) + $ ctx + (ej, _r) <- genExpr ctx' e + return (rj <> ej, ExprCont) + +genRet :: HasDebugCallStack + => ExprCtx + -> Id + -> AltType + -> [CgStgAlt] + -> LiveVars + -> G JStat +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) + 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 + pushLne <- pushLneFrame lneLive ctx + saveCCS <- ifProfilingM $ push [jCurrentCCS] + free <- optimizeFree 0 nonLne + pushRet <- pushRetArgs free (toJExpr r) + fun' <- fun free + sr <- genStaticRefs l -- srt + prof <- profiling + emitClosureInfo $ + ClosureInfo r + (CIRegs 0 altRegs) + ri + (fixedLayout . reverse $ + map (stackSlotType . fst3) free + ++ if prof then [ObjV] else map stackSlotType lneVars) + CIStackFrame + sr + emitToplevel $ r ||= toJExpr (JFunc [] fun') + return (pushLne <> saveCCS <> pushRet) + fst3 ~(x,_,_) = x + + altRegs :: HasDebugCallStack => [VarType] + altRegs = case at of + PrimAlt ptc -> [primRepVt ptc] + MultiValAlt _n -> idVt e + _ -> [PtrV] + + -- special case for popping CCS but preserving stack size + pop_handle_CCS :: [(JExpr, StackSlot)] -> G JStat + pop_handle_CCS [] = return mempty + pop_handle_CCS xs = do + -- grab the slots from 'xs' and push + addSlots (map snd xs) + -- move the stack pointer into the stack by ''length xs + n' + a <- adjSpN (length xs) + -- now load from the top of the stack + return (loadSkip 0 (map fst xs) <> a) + + fun free = resetSlots $ do + decs <- declVarsForId e + load <- flip assignAll (map toJExpr [R1 ..]) . map toJExpr <$> identsForId e + loadv <- verifyRuntimeReps [e] + ras <- loadRetArgs free + rasv <- verifyRuntimeReps (map (\(x,_,_)->x) free) + restoreCCS <- ifProfilingM . pop_handle_CCS $ pure (jCurrentCCS, SlotUnknown) + rlne <- popLneFrame False lneLive ctx' + rlnev <- verifyRuntimeReps lneVars + (alts, _altr) <- genAlts ctx' e at Nothing as + return $ decs <> load <> loadv <> ras <> rasv <> restoreCCS <> rlne <> rlnev <> alts <> + returnStack + +-- | Consume an Stg case alternative and generate the corresponding alternative +-- in JS land. If one alternative is a continuation then we must normalize the +-- other alternatives. See 'Branch' and 'normalizeBranches'. +genAlts :: HasDebugCallStack + => 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 + (st, er) <- case at of + + PolyAlt -> case alts of + [alt] -> (branch_stat &&& branch_result) <$> mkAlgBranch ctx e alt + _ -> panic "genAlts: multiple polyalt" + + PrimAlt _tc + | [GenStgAlt _ bs expr] <- alts + -> do + ie <- varsForId e + dids <- mconcat <$> mapM declVarsForId bs + bss <- concatMapM varsForId bs + (ej, er) <- genExpr ctx expr + return (dids <> assignAll bss ie <> ej, er) + + PrimAlt tc + -> do + ie <- varsForId e + (r, bss) <- normalizeBranches ctx <$> + mapM (isolateSlots . mkPrimIfBranch ctx [primRepVt tc]) alts + setSlots [] + return (mkSw ie bss, r) + + MultiValAlt n + | [GenStgAlt _ bs expr] <- alts + -> do + eids <- varsForId e + l <- loadUbxTup eids bs n + (ej, er) <- genExpr ctx expr + return (l <> ej, er) + + AlgAlt tc + | [_alt] <- alts + , isUnboxedTupleTyCon tc + -> 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 + return (s, r) + + AlgAlt _tc + | [alt,_] <- alts + , DataAlt dc <- alt_con alt + , isBoolDataCon dc + -> do + i <- varForId e + nbs <- normalizeBranches ctx <$> + mapM (isolateSlots . mkAlgBranch ctx e) alts + case nbs of + (r, [Branch _ s1 _, Branch _ s2 _]) -> do + let s = if dataConTag dc == 2 + then IfStat i s1 s2 + else IfStat i s2 s1 + setSlots [] + return (s, r) + _ -> error "genAlts: invalid branches for Bool" + + AlgAlt _tc -> do + ei <- varForId e + (r, brs) <- normalizeBranches ctx <$> + mapM (isolateSlots . mkAlgBranch ctx e) alts + setSlots [] + return (mkSwitch (ei .^ "f" .^ "a") brs, r) + + _ -> pprPanic "genAlts: unhandled case variant" (ppr (at, length alts)) + + ver <- verifyMatchRep e at + pure (ver <> st, er) + +-- | 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 x alt = do + runtime_assert <- csRuntimeAssert <$> getSettings + if not runtime_assert + then pure mempty + 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 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_result :: ExprResult + } + deriving (Eq,Functor) + +-- | If one branch ends in a continuation but another is inline, we need to +-- adjust the inline branch to use the continuation convention +normalizeBranches :: ExprCtx + -> [Branch a] + -> (ExprResult, [Branch a]) +normalizeBranches ctx brs + | all (==ExprCont) (fmap branch_result brs) = + (ExprCont, brs) + | branchResult (fmap branch_result brs) == ExprCont = + (ExprCont, map mkCont brs) + | otherwise = + (ExprInline Nothing, 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 + } + _ -> 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 es bs _n = do + bs' <- concatMapM identsForId bs + return $ declAssignAll bs' es + +mkSw :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat +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 e cases + | [Branch (Just c1) s1 _] <- n + , [Branch _ s2 _] <- d + = IfStat (InfixExpr StrictEqOp e c1) s1 s2 + + | [Branch (Just c1) s1 _, Branch _ s2 _] <- n + , null d + = IfStat (InfixExpr StrictEqOp e c1) s1 s2 + + | null d + = SwitchStat e (map addBreak (init n)) (branch_stat (last n)) + + | [Branch _ d0 _] <- d + = SwitchStat e (map addBreak n) d0 + + | otherwise = panic "mkSwitch: multiple default cases" + where + addBreak (Branch (Just c) s _) = (c, mconcat [s, BreakStat Nothing]) + addBreak _ = panic "mkSwitch: addBreak" + (n,d) = L.partition (isJust . branch_expr) cases + +-- | 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 e s = go (L.reverse s) + where + go = \case + [Branch _ s _] -> s -- only one 'nothing' allowed + (Branch (Just e0) s _ : xs) -> IfStat (mkEq e e0) s (go xs) + [] -> panic "mkIfElse: empty expression list" + _ -> panic "mkIfElse: multiple DEFAULT cases" + +-- | Wrapper to contruct sequences of (===), e.g., +-- +-- > mkEq [l0,l1,l2] [r0,r1,r2] = (l0 === r0) && (l1 === r1) && (l2 === r2) +-- +mkEq :: [JExpr] -> [JExpr] -> JExpr +mkEq es1 es2 + | length es1 == length es2 = 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)) +mkAlgBranch top d alt + | DataAlt dc <- alt_con alt + , isUnboxableCon dc + , [b] <- alt_bndrs alt + = do + idd <- varForId d + fldx <- identsForId b + case fldx of + [fld] -> do + (ej, er) <- genExpr top (alt_rhs alt) + return (Branch Nothing (mconcat [fld ||= idd, ej]) er) + _ -> panic "mkAlgBranch: invalid size" + + | otherwise + = do + cc <- caseCond (alt_con alt) + idd <- varForId d + b <- loadParams idd (alt_bndrs alt) + (ej, er) <- genExpr top (alt_rhs alt) + return (Branch cc (b <> ej) er) + +-- | Generate a primitive If-expression +mkPrimIfBranch :: ExprCtx + -> [VarType] + -> CgStgAlt + -> G (Branch (Maybe [JExpr])) +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 = \case + DataAlt da -> return $ Just [toJExpr (dataConTag da)] + LitAlt l -> Just <$> genLit l + DEFAULT -> return Nothing + +caseCond :: AltCon -> G (Maybe JExpr) +caseCond = \case + 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) + +-- fixme use single tmp var for all branches +-- | Load parameters from constructor +loadParams :: JExpr -> [Id] -> G JStat +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 + [ 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 + ]) + ] + 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 + +-- | Determine if a branch will end in a continuation or not. If not the inline +-- branch must be normalized. See 'normalizeBranches' +-- NB. not a Monoid +branchResult :: HasDebugCallStack => [ExprResult] -> ExprResult +branchResult = \case + [] -> panic "branchResult: empty list" + [e] -> e + (ExprCont:_) -> ExprCont + (_:es) + | elem ExprCont es -> ExprCont + | otherwise -> ExprInline Nothing + +-- | 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 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 free = do + ids <- mapM (\(i,n,_b) -> (!! (n-1)) <$> genIdStackArgI i) free + popSkipI 1 ids + +-- | 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 haveDecl middle [(to,entry,free,cc)] + | isNothing middle && to `notElem` (free ^.. template) = do + ccs <- ccsVarJ cc + return $ allocDynamic s haveDecl to entry free ccs -} +allocDynAll haveDecl middle cls = do + settings <- getSettings + let + middle' = fromMaybe mempty middle + + decl_maybe i e + | haveDecl = toJExpr i |= e + | otherwise = i ||= e + + makeObjs :: G JStat + 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) + , (closureField1_, null_) + , (closureField2_, null_) + , (closureMeta_ , zero_) + ] + ++ fmap (\cid -> ("cc", ValExpr (JVar cid))) ccs) + else ApplExpr (var "h$c") (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 + ] + + fillFun [] = null_ + fillFun es = ApplExpr (allocData (length es)) es + + checkObjs | csAssertRts settings = mconcat $ + map (\(i,_,_,_) -> ApplStat (ValExpr (JVar (TxtI "h$checkObj"))) [toJExpr i]) cls + | otherwise = mempty + + objs <- makeObjs + pure $ mconcat [objs, middle', fillObjs, 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 ctx op args t = do + as <- concatMapM genArg args + prof <- csProf <$> getSettings + bound <- csBoundsCheck <$> getSettings + -- 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) + PRPrimCall s -> (s, ExprCont) diff --git a/GHC/StgToJS/ExprCtx.hs b/GHC/StgToJS/ExprCtx.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/ExprCtx.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.ExprCtx +-- 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 +-- +-- TODO: Write my description! +----------------------------------------------------------------------------- + +module GHC.StgToJS.ExprCtx + ( ExprCtx + , initExprCtx + , ctxAssertEvaluated + , ctxIsEvaluated + , ctxSetSrcSpan + , ctxSrcSpan + , ctxSetTop + , ctxTarget + , ctxSetTarget + , ctxEvaluatedIds + -- * Let-no-escape + , ctxClearLneFrame + , ctxUpdateLneFrame + , ctxLneFrameVars + , ctxLneFrameSize + , ctxIsLneBinding + , ctxIsLneLiveVar + , ctxLneBindingStackSize + , ctxLneShrinkStack + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Types + +import GHC.Types.Unique.FM +import GHC.Types.Unique.Set +import GHC.Types.Var +import GHC.Types.SrcLoc + +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import Data.Maybe + + +-- | Context into which an expression is evaluated +data ExprCtx = ExprCtx + { ctxTop :: Id + -- ^ Top-level binding Id + + , 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 + + ---------------------------- + -- Handling of let-no-escape + + , ctxLneFrameBs :: UniqFM Id Int + -- ^ LNE bindings with their expected stack size. + -- + -- The Int is the size of the stack when the LNE binding was defined. + -- We need to shrink the stack back to this size when we enter one of the + -- associated binder rhs: it expects its free variables at certain offsets + -- in the stack. + + , ctxLneFrameVars :: [(Id,Int)] + -- ^ Contents of current LNE frame + -- + -- Variables and their index on the stack + + , ctxLneFrameSize :: {-# UNPACK #-} !Int + -- ^ Cache the length of `ctxLneFrameVars` + + } + +-- | 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 + , ctxSrcSpan = Nothing + } + +-- | Set target +ctxSetTarget :: [TypedExpr] -> ExprCtx -> ExprCtx +ctxSetTarget t ctx = ctx { ctxTarget = t } + +-- | Set top-level binding Id +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 } + +-- | Update let-no-escape frame +ctxUpdateLneFrame :: [(Id,Int)] -> [Id] -> ExprCtx -> ExprCtx +ctxUpdateLneFrame new_spilled_vars new_lne_ids ctx = + let old_frame_size = ctxLneFrameSize ctx + new_frame_size = old_frame_size + length new_spilled_vars + in ctx + { ctxLneFrameBs = addListToUFM (ctxLneFrameBs ctx) (map (,new_frame_size) new_lne_ids) + , ctxLneFrameSize = new_frame_size + , ctxLneFrameVars = ctxLneFrameVars ctx ++ new_spilled_vars + } + +-- | Remove information about the current LNE frame +ctxClearLneFrame :: ExprCtx -> ExprCtx +ctxClearLneFrame ctx = + ctx + { ctxLneFrameBs = emptyUFM + , ctxLneFrameVars = [] + , ctxLneFrameSize = 0 + } + +-- | Predicate: do we know for sure that the given Id is evaluated? +ctxIsEvaluated :: ExprCtx -> Id -> Bool +ctxIsEvaluated ctx i = i `elementOfUniqSet` ctxEvaluatedIds ctx + +-- | Does the given Id correspond to a LNE binding +ctxIsLneBinding :: ExprCtx -> Id -> Bool +ctxIsLneBinding ctx i = isJust (ctxLneBindingStackSize ctx i) + +-- | Does the given Id correspond to a LNE live var on the stack +ctxIsLneLiveVar :: ExprCtx -> Id -> Bool +ctxIsLneLiveVar ctx i = i `elem` map fst (ctxLneFrameVars ctx) + +-- | Return the LNE stack size associated to the given Id. +-- Return Nothing when the Id doesn't correspond to a LNE binding. +ctxLneBindingStackSize :: ExprCtx -> Id -> Maybe Int +ctxLneBindingStackSize ctx i = lookupUFM (ctxLneFrameBs ctx) i + +-- | Shrink the LNE stack to the given size +ctxLneShrinkStack :: ExprCtx -> Int -> ExprCtx +ctxLneShrinkStack ctx n = + let l = ctxLneFrameSize ctx + in assertPpr + (l >= n) + (vcat [ text "ctxLneShrinkStack: let-no-escape stack too short:" + , ppr l + , text " < " + , ppr n + ]) + (ctx { ctxLneFrameVars = take n (ctxLneFrameVars ctx) + , ctxLneFrameSize = n + } + ) diff --git a/GHC/StgToJS/FFI.hs b/GHC/StgToJS/FFI.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/FFI.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.FFI + ( genPrimCall + , genForeignCall + , saturateFFI + ) +where + +import GHC.Prelude + +import GHC.JS.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.Literal +import GHC.StgToJS.Regs +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Ids + +import GHC.Types.RepType +import GHC.Types.ForeignCall +import GHC.Types.Unique.Map +import GHC.Types.Unique.FM + +import GHC.Stg.Syntax + +import GHC.Builtin.PrimOps +import GHC.Builtin.Types.Prim + +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.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 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) + +-- | generate the actual call +{- + parse FFI patterns: + "&value -> value + 1. "function" -> ret = function(...) + 2. "$r = $1.f($2) -> r1 = a1.f(a2) + + arguments, $1, $2, $3 unary arguments + $1_1, $1_2, for a binary argument + + return type examples + 1. $r unary return + 2. $r1, $r2 binary return + 3. $r1, $r2, $r3_1, $r3_2 unboxed tuple return + -} +parseFFIPattern :: Bool -- ^ catch exception and convert them to haskell exceptions + -> Bool -- ^ async (only valid with javascript calling conv) + -> Bool -- ^ using javascript calling convention + -> String + -> Type + -> [JExpr] + -> [StgArg] + -> G JStat +parseFFIPattern catchExcep async jscc pat t es as + | catchExcep = do + c <- parseFFIPatternA async jscc pat t es as + -- Generate: + -- try { + -- `c`; + -- } catch(except) { + -- return h$throwJSException(except); + -- } + let ex = TxtI "except" + return (TryStat c ex (ReturnStat (ApplExpr (var "h$throwJSException") [toJExpr ex])) mempty) + | otherwise = parseFFIPatternA async jscc pat t es as + +parseFFIPatternA :: Bool -- ^ async + -> Bool -- ^ using JavaScript calling conv + -> String + -> Type + -> [JExpr] + -> [StgArg] + -> G JStat +-- async calls get an extra callback argument +-- call it with the result +parseFFIPatternA True True pat t es as = do + cb <- freshIdent + x <- freshIdent + 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] + , stat + , IfStat (InfixExpr StrictEqOp (toJExpr x .^ "mv") null_) + (mconcat + [ toJExpr x .^ "mv" |= UOpExpr NewOp (ApplExpr (var "h$MVar") []) + , sp |= Add sp one_ + , (IdxExpr stack sp) |= var "h$unboxFFIResult" + , ReturnStat $ ApplExpr (var "h$takeMVar") [toJExpr x .^ "mv"] + ]) + (mconcat + [ d ||= toJExpr x .^ "mv" + , copyResult (toJExpr d) + ]) + ] + where nrst = typeSize t + copyResult d = assignAllEqual es (map (IdxExpr d . toJExpr) [0..nrst-1]) +parseFFIPatternA _async javascriptCc pat t es as = + parseFFIPattern' Nothing javascriptCc pat t es as + +-- 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' 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? + where + async = isJust callback + tgt = take (typeSize t) ret + -- automatic apply, build call and result copy + mkApply f + | Just cb <- callback = do + (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args + cs <- getSettings + return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as++[cb]) + | {-ts@-} + (t:ts') <- tgt = do + (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args + cs <- getSettings + return $ traceCall cs as + <> mconcat stats + <> (t |= ApplExpr f' (concat as) ) + <> copyResult ts' + -- _ -> error "mkApply: empty list" + | otherwise = do + (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) + 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] + | 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 +-- before the call +genFFIArg :: Bool -> StgArg -> G (JStat, [JExpr]) +genFFIArg _isJavaScriptCc (StgLitArg l) = (mempty,) <$> genLit l +genFFIArg isJavaScriptCc a@(StgVarArg i) + | not isJavaScriptCc && + (tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon) = + (\x -> (mempty,[x, zero_])) <$> varForId i + | isVoid r = return (mempty, []) +-- | Just x <- marshalFFIArg a = x + | isMultiVar r = (mempty,) <$> mapM (varForIdN i) [1..varSize r] + | otherwise = (\x -> (mempty,[x])) <$> varForId i + 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) + +genForeignCall :: HasDebugCallStack + => ExprCtx + -> ForeignCall + -> Type + -> [JExpr] + -> [StgArg] + -> G (JStat, ExprResult) +genForeignCall _ctx + (CCall (CCallSpec (StaticTarget _ tgt Nothing True) + JavaScriptCallConv + PlayRisky)) + _t + [obj] + args + | tgt == fsLit "h$buildObject" + , 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 + ) + +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 + where + isJsCc = cconv == JavaScriptCallConv + + lbl | (StaticTarget _ clbl _mpkg _isFunPtr) <- ccTarget + = let clbl' = unpackFS clbl + in if | isJsCc -> clbl' + | wrapperPrefix `L.isPrefixOf` clbl' -> + ("h$" ++ (drop 2 $ dropWhile isDigit $ drop (length wrapperPrefix) clbl')) + | otherwise -> "h$" ++ clbl' + | otherwise = "h$callDynamic" + + exprResult | async = ExprCont + | otherwise = ExprInline Nothing + + catchExcep = (cconv == JavaScriptCallConv) && + playSafe safety || playInterruptible safety + + async | isJsCc = playInterruptible safety + | otherwise = playInterruptible safety || playSafe safety + + tgt' | async = take (length tgt) jsRegsFromR1 + | otherwise = tgt + + wrapperPrefix = "ghczuwrapperZC" + +getObjectKeyValuePairs :: [StgArg] -> Maybe [(FastString, StgArg)] +getObjectKeyValuePairs [] = Just [] +getObjectKeyValuePairs (k:v:xs) + | Just t <- argJSStringLitUnfolding k = + fmap ((t,v):) (getObjectKeyValuePairs xs) +getObjectKeyValuePairs _ = Nothing + +argJSStringLitUnfolding :: StgArg -> Maybe FastString +argJSStringLitUnfolding (StgVarArg _v) = Nothing -- fixme +argJSStringLitUnfolding _ = Nothing + +showArgType :: StgArg -> FastString +showArgType a = showType (stgArgType a) + +showType :: Type -> FastString +showType t + | Just tc <- tyConAppTyCon_maybe (unwrapType t) = + mkFastString (renderWithContext defaultSDocContext (ppr tc)) + | otherwise = "" diff --git a/GHC/StgToJS/Heap.hs b/GHC/StgToJS/Heap.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Heap.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.StgToJS.Heap + ( closureType + , entryClosureType + , isObject + , isThunk + , isThunk' + , isBlackhole + , isFun + , isFun' + , isPap + , isPap' + , isCon + , isCon' + , conTag + , conTag' + , closureEntry + , closureMeta + , closureField1 + , closureField2 + , closureCC + , funArity + , funArity' + , papArity + , funOrPapArity + -- * Field names + , closureEntry_ + , closureMeta_ + , closureCC_ + , closureField1_ + , closureField2_ + -- * Javascript Type literals + , jTyObject + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.StgToJS.Types +import GHC.Data.FastString + +closureEntry_ :: FastString +closureEntry_ = "f" + +closureField1_ :: FastString +closureField1_ = "d1" + +closureField2_ :: FastString +closureField2_ = "d2" + +closureMeta_ :: FastString +closureMeta_ = "m" + +closureCC_ :: FastString +closureCC_ = "cc" + +entryClosureType_ :: FastString +entryClosureType_ = "t" + +entryConTag_ :: FastString +entryConTag_ = "a" + +entryFunArity_ :: FastString +entryFunArity_ = "a" + +jTyObject :: JExpr +jTyObject = jString "object" + +closureType :: JExpr -> JExpr +closureType = entryClosureType . closureEntry + +entryClosureType :: JExpr -> JExpr +entryClosureType f = f .^ entryClosureType_ + +isObject :: JExpr -> JExpr +isObject c = typeof c .===. String "object" + +isThunk :: JExpr -> JExpr +isThunk c = closureType c .===. toJExpr Thunk + +isThunk' :: JExpr -> JExpr +isThunk' f = entryClosureType f .===. toJExpr Thunk + +isBlackhole :: JExpr -> JExpr +isBlackhole c = closureType c .===. toJExpr Blackhole + +isFun :: JExpr -> JExpr +isFun c = closureType c .===. toJExpr Fun + +isFun' :: JExpr -> JExpr +isFun' f = entryClosureType f .===. toJExpr Fun + +isPap :: JExpr -> JExpr +isPap c = closureType c .===. toJExpr Pap + +isPap' :: JExpr -> JExpr +isPap' f = entryClosureType f .===. toJExpr Pap + +isCon :: JExpr -> JExpr +isCon c = closureType c .===. toJExpr Con + +isCon' :: JExpr -> JExpr +isCon' f = entryClosureType f .===. toJExpr Con + +conTag :: JExpr -> JExpr +conTag = conTag' . closureEntry + +conTag' :: JExpr -> JExpr +conTag' f = f .^ entryConTag_ + +-- | Get closure entry function +closureEntry :: JExpr -> JExpr +closureEntry p = p .^ closureEntry_ + +-- | Get closure metadata +closureMeta :: JExpr -> JExpr +closureMeta p = p .^ closureMeta_ + +-- | Get closure cost-center +closureCC :: JExpr -> JExpr +closureCC p = p .^ closureCC_ + +-- | Get closure extra field 1 +closureField1 :: JExpr -> JExpr +closureField1 p = p .^ closureField1_ + +-- | Get closure extra field 2 +closureField2 :: JExpr -> JExpr +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_ + +-- arity of a partial application +papArity :: JExpr -> JExpr +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) +funOrPapArity c = \case + Nothing -> ((IfExpr (toJExpr (isFun c))) (toJExpr (funArity c))) + (toJExpr (papArity c)) + Just f -> ((IfExpr (toJExpr (isFun' f))) (toJExpr (funArity' f))) + (toJExpr (papArity c)) diff --git a/GHC/StgToJS/Ids.hs b/GHC/StgToJS/Ids.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Ids.hs @@ -0,0 +1,238 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Ids +-- 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 to deal with JS identifiers +----------------------------------------------------------------------------- + +module GHC.StgToJS.Ids + ( freshUnique + , freshIdent + , makeIdentForId + , cachedIdentForId + -- * Helpers for Idents + , identForId + , identForIdN + , identsForId + , identForEntryId + , identForDataConEntryId + , identForDataConWorker + -- * Helpers for variables + , varForId + , varForIdN + , varsForId + , varForEntryId + , varForDataConEntryId + , varForDataConWorker + , declVarsForId + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.CoreUtils +import GHC.StgToJS.Symbols + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.Core.DataCon +import GHC.Types.Id +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Name +import GHC.Unit.Module +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import Control.Monad +import Control.Monad.IO.Class +import qualified Control.Monad.Trans.State.Strict as State +import qualified Data.Map as M +import Data.Maybe +import qualified Data.ByteString.Char8 as BSC + +-- | Get fresh unique number +freshUnique :: G Int +freshUnique = do + id_gen <- State.gets gsId + liftIO $ do + -- no need for atomicFetchAdd as we don't use threads in G + v <- readFastMutInt id_gen + writeFastMutInt id_gen (v+1) + pure v + +-- | Get fresh 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) + + +-- | Generate unique Ident for the given ID (uncached!) +-- +-- The ident has the following forms: +-- +-- global Id: h$unit:module.name[_num][_type_suffix] +-- local Id: h$$unit:module.name[_num][_type_suffix]_uniq +-- +-- Note that the string is z-encoded except for "_" delimiters. +-- +-- Optional "_type_suffix" can be: +-- - "_e" for IdEntry +-- - "_con_e" for IdConEntry +-- +-- Optional "_num" is passed as an argument to this function. It is used for +-- Haskell Ids that require several JS variables: e.g. 64-bit numbers (Word64#, +-- Int64#), Addr#, StablePtr#, unboxed tuples, etc. +-- +makeIdentForId :: Id -> Maybe Int -> IdType -> Module -> Ident +makeIdentForId i num id_type current_module = TxtI ident + where + exported = isExportedId i + name = getName i + mod + | exported + , Just m <- nameModule_maybe name + = m + | otherwise + = current_module + + !ident = mkFastStringByteString $ mconcat + [ mkJsSymbolBS exported mod (occNameFS (nameOccName name)) + + ------------- + -- suffixes + + -- suffix for Ids represented with more than one JS var ("_0", "_1", etc.) + , case num of + Nothing -> mempty + Just v -> mconcat [BSC.pack "_", intBS v] + + -- suffix for entry and constructor entry + , case id_type of + IdPlain -> mempty + IdEntry -> BSC.pack "_e" + IdConEntry -> BSC.pack "_con_e" + + -- unique suffix for non-exported Ids + , if exported + then mempty + else let (c,u) = unpkUnique (getUnique i) + in mconcat [BSC.pack ['_',c,'_'], intBS u] + ] + +-- | Retrieve the cached Ident for the given Id if there is one. Otherwise make +-- a new one with 'makeIdentForId' and cache it. +cachedIdentForId :: Id -> Maybe Int -> IdType -> G Ident +cachedIdentForId i mi id_type = do + + -- compute key + let !key = IdKey (getKey . getUnique $ i) (fromMaybe 0 mi) id_type + + -- lookup Ident in the Ident cache + IdCache cache <- State.gets gsIdents + ident <- case M.lookup key cache of + Just ident -> pure ident + Nothing -> do + mod <- State.gets gsModule + let !ident = makeIdentForId i mi id_type mod + let !cache' = IdCache (M.insert key ident cache) + State.modify (\s -> s { gsIdents = cache' }) + pure ident + + -- Now update the GlobalId cache, if required + + let update_global_cache = isGlobalId i && isNothing mi && id_type == IdPlain + -- fixme also allow caching entries for lifting? + + when (update_global_cache) $ do + GlobalIdCache gidc <- getGlobalIdCache + case elemUFM ident gidc of + False -> setGlobalIdCache $ GlobalIdCache (addToUFM gidc ident (key, i)) + True -> pure () + + pure ident + +-- | Retrieve default Ident for the given Id +identForId :: Id -> G Ident +identForId i = cachedIdentForId i Nothing IdPlain + +-- | Retrieve default Ident for the given Id with sub index +-- +-- Some types, Word64, Addr#, unboxed tuple have more than one corresponding JS +-- var, hence we use the sub index to identify each subpart / JS variable. +identForIdN :: Id -> Int -> G Ident +identForIdN i n = cachedIdentForId i (Just n) IdPlain + +-- | Retrieve all the idents for the given Id. +identsForId :: Id -> G [Ident] +identsForId i = case typeSize (idType i) of + 0 -> pure mempty + 1 -> (:[]) <$> identForId i + s -> mapM (identForIdN i) [1..s] + + +-- | Retrieve entry Ident for the given Id +identForEntryId :: Id -> G Ident +identForEntryId i = cachedIdentForId i Nothing IdEntry + +-- | Retrieve datacon entry Ident for the given Id +-- +-- Different name than the datacon wrapper. +identForDataConEntryId :: Id -> G Ident +identForDataConEntryId i = cachedIdentForId i Nothing IdConEntry + + +-- | Retrieve default variable name for the given Id +varForId :: Id -> G JExpr +varForId i = toJExpr <$> identForId i + +-- | Retrieve default variable name for the given Id with sub index +varForIdN :: Id -> Int -> G JExpr +varForIdN i n = toJExpr <$> identForIdN i n + +-- | Retrieve all the JS vars for the given Id +varsForId :: Id -> G [JExpr] +varsForId i = case typeSize (idType i) of + 0 -> pure mempty + 1 -> (:[]) <$> varForId i + s -> mapM (varForIdN i) [1..s] + + +-- | Retrieve entry variable name for the given Id +varForEntryId :: Id -> G JExpr +varForEntryId i = toJExpr <$> identForEntryId i + +-- | Retrieve datacon entry variable name for the given Id +varForDataConEntryId :: Id -> G JExpr +varForDataConEntryId i = ValExpr . JVar <$> identForDataConEntryId i + + +-- | Retrieve datacon worker entry variable name for the given datacon +identForDataConWorker :: DataCon -> G Ident +identForDataConWorker d = identForDataConEntryId (dataConWorkId d) + +-- | Retrieve datacon worker entry variable name for the given datacon +varForDataConWorker :: DataCon -> G JExpr +varForDataConWorker d = varForDataConEntryId (dataConWorkId d) + +-- | Declare all js vars for the id +declVarsForId :: Id -> G JStat +declVarsForId i = case typeSize (idType i) of + 0 -> return mempty + 1 -> decl <$> identForId i + s -> mconcat <$> mapM (\n -> decl <$> identForIdN i n) [1..s] + diff --git a/GHC/StgToJS/Linker/Linker.hs b/GHC/StgToJS/Linker/Linker.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Linker/Linker.hs @@ -0,0 +1,945 @@ +{-# 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 diff --git a/GHC/StgToJS/Linker/Types.hs b/GHC/StgToJS/Linker/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Linker/Types.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-orphans #-} -- for Ident's Binary instance + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Types +-- 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 GHC.StgToJS.Linker.Types + ( GhcjsEnv (..) + , newGhcjsEnv + , JSLinkConfig (..) + , defaultJSLinkConfig + , generateAllJs + , LinkedObj (..) + , LinkableUnit + ) +where + +import GHC.StgToJS.Object + +import GHC.Unit.Types +import GHC.Utils.Outputable (hsep,Outputable(..),text,ppr) + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Set (Set) + +import Control.Concurrent.MVar + +import System.IO + +import Prelude + +-------------------------------------------------------------------------------- +-- Linker Config +-------------------------------------------------------------------------------- + +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 + } + +-------------------------------------------------------------------------------- +-- Linker Environment +-------------------------------------------------------------------------------- + +-- | A @LinkableUnit@ is a pair of a module and the index of the block in the +-- object file +type LinkableUnit = (Module, Int) + +-- | An object file that's either already in memory (with name) or on disk +data LinkedObj + = ObjFile FilePath -- ^ load from this file + | ObjLoaded String Object -- ^ already loaded: description and payload + +instance Outputable LinkedObj where + ppr = \case + ObjFile fp -> hsep [text "ObjFile", text fp] + ObjLoaded s o -> hsep [text "ObjLoaded", text s, ppr (objModuleName o)] + +data GhcjsEnv = GhcjsEnv + { linkerArchiveDeps :: MVar (Map (Set FilePath) + (Map Module (Deps, DepsLocation) + , [LinkableUnit] + ) + ) + } + +-- | return a fresh @GhcjsEnv@ +newGhcjsEnv :: IO GhcjsEnv +newGhcjsEnv = GhcjsEnv <$> newMVar M.empty diff --git a/GHC/StgToJS/Linker/Utils.hs b/GHC/StgToJS/Linker/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Linker/Utils.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Linker.Utils +-- 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 +-- +-- Various utilies used in the JS Linker +-- +----------------------------------------------------------------------------- + +module GHC.StgToJS.Linker.Utils + ( getOptionsFromJsFile + , JSOption(..) + , jsExeFileName + , getInstalledPackageLibDirs + , getInstalledPackageHsLibs + , commonCppDefs + ) +where + +import System.FilePath +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as Char8 +import Data.ByteString (ByteString) + +import GHC.Driver.Session + +import GHC.Data.ShortText +import GHC.Unit.State +import GHC.Unit.Types + +import GHC.StgToJS.Types + +import Prelude +import GHC.Platform +import Data.List (isPrefixOf) +import System.IO +import Data.Char (isSpace) +import qualified Control.Exception as Exception + +-- | Retrieve library directories provided by the @UnitId@ in @UnitState@ +getInstalledPackageLibDirs :: UnitState -> UnitId -> [ShortText] +getInstalledPackageLibDirs us = maybe mempty unitLibraryDirs . lookupUnitId us + +-- | Retrieve the names of the libraries provided by @UnitId@ +getInstalledPackageHsLibs :: UnitState -> UnitId -> [ShortText] +getInstalledPackageHsLibs us = maybe mempty unitLibraries . lookupUnitId us + +-- | A constant holding the JavaScript executable Filename extension +jsexeExtension :: String +jsexeExtension = "jsexe" + +-- | CPP definitions that are inserted into every .pp file +commonCppDefs :: Bool -> ByteString +commonCppDefs profiling = case profiling of + True -> commonCppDefs_profiled + False -> commonCppDefs_vanilla + +-- | CPP definitions for normal operation and profiling. Use CAFs for +-- commonCppDefs_* so that they are shared for every CPP file +commonCppDefs_vanilla, commonCppDefs_profiled :: ByteString +commonCppDefs_vanilla = genCommonCppDefs False +commonCppDefs_profiled = genCommonCppDefs True + +-- | Generate CPP Definitions depending on a profiled or normal build. This +-- occurs at link time. +genCommonCppDefs :: Bool -> ByteString +genCommonCppDefs profiling = mconcat + [ + -- constants + let mk_int_def n v = "#define " <> Char8.pack n <> " (" <> Char8.pack (show v) <> ")\n" + -- generate "#define CLOSURE_TYPE_xyz (num)" defines + mk_closure_def t = mk_int_def (ctJsName t) (ctNum t) + closure_defs = map mk_closure_def [minBound..maxBound] + -- generate "#define THREAD_xyz_xyz (num)" defines + mk_thread_def t = mk_int_def (threadStatusJsName t) (threadStatusNum t) + thread_defs = map mk_thread_def [minBound..maxBound] + 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" + ] + + , "#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$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM)\n" + else "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_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" + + -- Exception dictionary for JSException + , "#define HS_JSEXCEPTION_EXCEPTION h$baseZCGHCziJSziPrimzizdfExceptionJSException\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" + + -- 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" + + -- 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 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" + + -- 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 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" + ] + 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" + ] + + -- Data.Text + , "#define DATA_TEXT_ARRAY(x) ((x).d1)\n" + , "#define DATA_TEXT_OFFSET(x) ((x).d2.d1)\n" + , "#define DATA_TEXT_LENGTH(x) ((x).d2.d2)\n" + + -- Data.Text.Lazy + , "#define LAZY_TEXT_IS_CHUNK(x) ((x).f.a === 2)\n" + , "#define LAZY_TEXT_IS_NIL(x) ((x).f.a === 1)\n" + , "#define LAZY_TEXT_CHUNK_HEAD(x) ((x))\n" + , "#define LAZY_TEXT_CHUNK_TAIL(x) ((x).d2.d3)\n" + + -- black holes + -- can we skip the indirection for black holes? + , "#define IS_BLACKHOLE(x) (typeof (x) === 'object' && (x) && (x).f && (x).f.t === CLOSURE_TYPE_BLACKHOLE)\n" + , "#define BLACKHOLE_TID(bh) ((bh).d1)\n" + , "#define SET_BLACKHOLE_TID(bh,tid) ((bh).d1 = (tid))\n" + , "#define BLACKHOLE_QUEUE(bh) ((bh).d2)\n" + , "#define SET_BLACKHOLE_QUEUE(bh,val) ((bh).d2 = (val))\n" + + -- resumable thunks + , "#define MAKE_RESUMABLE(closure,stack) { (closure).f = h$resume_e; (closure).d1 = (stack), (closure).d2 = null; }\n" + + -- general deconstruction + , "#define IS_THUNK(x) ((x).f.t === CLOSURE_TYPE_THUNK)\n" + , "#define CONSTR_TAG(x) ((x).f.a)\n" + + -- retrieve a numeric value that's possibly stored as an indirection + , "#define IS_WRAPPED_NUMBER(val) ((typeof(val)==='object')&&(val).f === h$unbox_e)\n" + , "#define UNWRAP_NUMBER(val) ((typeof(val) === 'number')?(val):(val).d1)\n" + + -- generic lazy values + , if profiling + then mconcat + [ "#define MK_LAZY(fun) (h$c1(h$lazy_e, (fun), h$CCS_SYSTEM))\n" + , "#define MK_LAZY_CC(fun,cc) (h$c1(h$lazy_e, (fun), (cc)))\n" + ] + else mconcat + [ "#define MK_LAZY(fun) (h$c1(h$lazy_e, (fun)))\n" + , "#define MK_LAZY_CC(fun,cc) (h$c1(h$lazy_e, (fun)))\n" + ] + + -- generic data constructors and selectors + , if profiling + then mconcat + [ "#define MK_DATA1_1(val) (h$c1(h$data1_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_DATA1_2(val1,val2) (h$c2(h$data1_e, (val1), (val2), h$CCS_SYSTEM))\n" + , "#define MK_DATA2_1(val) (h$c1(h$data2_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_DATA2_2(val1,val2) (h$c2(h$data1_e, (val1), (val2), h$CCS_SYSTEM))\n" + , "#define MK_SELECT1(val) (h$c1(h$select1_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_SELECT2(val) (h$c1(h$select2_e, (val), h$CCS_SYSTEM))\n" + , "#define MK_AP1(fun,val) (h$c2(h$ap1_e, (fun), (val), h$CCS_SYSTEM))\n" + , "#define MK_AP2(fun,val1,val2) (h$c3(h$ap2_e, (fun), (val1), (val2), h$CCS_SYSTEM))\n" + , "#define MK_AP3(fun,val1,val2,val3) (h$c4(h$ap3_e, (fun), (val1), (val2), (val3), h$CCS_SYSTEM))\n" + ] + else mconcat + [ "#define MK_DATA1_1(val) (h$c1(h$data1_e, (val)))\n" + , "#define MK_DATA1_2(val1,val2) (h$c2(h$data1_e, (val1), (val2)))\n" + , "#define MK_DATA2_1(val) (h$c1(h$data2_e, (val)))\n" + , "#define MK_DATA2_2(val1,val2) (h$c2(h$data2_e, (val1), (val2)))\n" + , "#define MK_SELECT1(val) (h$c1(h$select1_e, (val)))\n" + , "#define MK_SELECT2(val) (h$c1(h$select2_e, (val)))\n" + , "#define MK_AP1(fun,val) (h$c2(h$ap1_e,(fun),(val)))\n" + , "#define MK_AP2(fun,val1,val2) (h$c3(h$ap2_e,(fun),(val1),(val2)))\n" + , "#define MK_AP3(fun,val1,val2,val3) (h$c4(h$ap3_e, (fun), (val1), (val2), (val3)))\n" + ] + + -- unboxed tuple returns + -- , "#define RETURN_UBX_TUP1(x) return x;\n" + , "#define RETURN_UBX_TUP2(x1,x2) { h$ret1 = (x2); return (x1); }\n" + , "#define RETURN_UBX_TUP3(x1,x2,x3) { h$ret1 = (x2); h$ret2 = (x3); return (x1); }\n" + , "#define RETURN_UBX_TUP4(x1,x2,x3,x4) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); return (x1); }\n" + , "#define RETURN_UBX_TUP5(x1,x2,x3,x4,x5) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); return (x1); }\n" + , "#define RETURN_UBX_TUP6(x1,x2,x3,x4,x5,x6) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); return (x1); }\n" + , "#define RETURN_UBX_TUP7(x1,x2,x3,x4,x5,x6,x7) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); return (x1); }\n" + , "#define RETURN_UBX_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); return (x1); }\n" + , "#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 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" + , "#define CALL_UBX_TUP5(r1,r2,r3,r4,r5,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; }\n" + , "#define CALL_UBX_TUP6(r1,r2,r3,r4,r5,r6,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; }\n" + , "#define CALL_UBX_TUP7(r1,r2,r3,r4,r5,r6,r7,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; }\n" + , "#define CALL_UBX_TUP8(r1,r2,r3,r4,r5,r6,r7,r8,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; }\n" + , "#define CALL_UBX_TUP9(r1,r2,r3,r4,r5,r6,r7,r8,r9,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; (r9) = h$ret8; }\n" + , "#define CALL_UBX_TUP10(r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; (r9) = h$ret8; (r10) = h$ret9; }\n" + ] + +-- | Construct the Filename for the "binary" of Haskell code compiled to +-- JavaScript. +jsExeFileName :: DynFlags -> FilePath +jsExeFileName dflags + | Just s <- outputFile_ dflags = + -- unmunge the extension + let s' = dropPrefix "js_" (drop 1 $ takeExtension s) + in if Prelude.null s' + then dropExtension s <.> jsexeExtension + else dropExtension s <.> s' + | otherwise = + if platformOS (targetPlatform dflags) == OSMinGW32 + then "main.jsexe" + else "a.jsexe" + where + dropPrefix prefix xs + | 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' diff --git a/GHC/StgToJS/Literal.hs b/GHC/StgToJS/Literal.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Literal.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Literal + ( genLit + , genStaticLit + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.Ids +import GHC.StgToJS.Symbols + +import GHC.Data.FastString +import GHC.Types.Literal +import GHC.Types.Basic +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable +import GHC.Float + +import Data.Bits as Bits +import Data.Char (ord) + +-- | Generate JS expressions for a Literal +-- +-- Literals represented with 2 values: +-- * 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 = \case + LitChar c -> return [ toJExpr (ord c) ] + LitString str -> + freshIdent >>= \strLit@(TxtI strLitT) -> + freshIdent >>= \strOff@(TxtI strOffT) -> do + emitStatic strLitT (StaticUnboxed (StaticUnboxedString str)) Nothing + emitStatic strOffT (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing + return [ ValExpr (JVar strLit), ValExpr (JVar strOff) ] + LitNullAddr -> return [ null_, ValExpr (JInt 0) ] + LitNumber nt v -> case nt of + LitNumInt -> return [ toJExpr v ] + LitNumInt8 -> return [ toJExpr v ] + LitNumInt16 -> return [ toJExpr v ] + LitNumInt32 -> return [ toJExpr v ] + LitNumInt64 -> return [ toJExpr (Bits.shiftR v 32), toU32Expr v ] + LitNumWord -> return [ toU32Expr v ] + LitNumWord8 -> return [ toU32Expr v ] + LitNumWord16 -> return [ toU32Expr v ] + LitNumWord32 -> return [ toU32Expr v ] + LitNumWord64 -> return [ toU32Expr (Bits.shiftR v 32), toU32Expr v ] + 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)] + , ValExpr (JInt 0) + ] + | otherwise -> return [ toJExpr (TxtI (mkRawSymbol True name)) + , ValExpr (JInt 0) + ] + LitRubbish {} -> return [ null_ ] + +-- | 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] + LitNullAddr -> return [ NullLit, IntLit 0 ] + LitNumber nt v -> case nt of + LitNumInt -> return [ IntLit v ] + LitNumInt8 -> return [ IntLit v ] + LitNumInt16 -> return [ IntLit v ] + LitNumInt32 -> return [ IntLit v ] + LitNumInt64 -> return [ IntLit (v `Bits.shiftR` 32), toU32Lit v ] + LitNumWord -> return [ toU32Lit v ] + LitNumWord8 -> return [ toU32Lit v ] + LitNumWord16 -> return [ toU32Lit v ] + LitNumWord32 -> return [ toU32Lit v ] + LitNumWord64 -> return [ toU32Lit (v `Bits.shiftR` 32), toU32Lit v ] + 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) + , IntLit 0 ] + l -> pprPanic "genStaticLit" (ppr l) + +-- make an unsigned 32 bit number from this unsigned one, lower 32 bits +toU32Expr :: Integer -> JExpr +toU32Expr i = Int (i Bits..&. 0xFFFFFFFF) .>>>. 0 + +-- make an unsigned 32 bit number from this unsigned one, lower 32 bits +toU32Lit :: Integer -> StaticLit +toU32Lit i = IntLit (i Bits..&. 0xFFFFFFFF) + +r2d :: Rational -> Double +r2d = realToFrac + +r2f :: Rational -> Double +r2f = float2Double . realToFrac diff --git a/GHC/StgToJS/Monad.hs b/GHC/StgToJS/Monad.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Monad.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +-- | JS codegen state monad +module GHC.StgToJS.Monad + ( runG + , emitGlobal + , addDependency + , emitToplevel + , emitStatic + , emitClosureInfo + , emitForeign + , assertRtsStat + , getSettings + , globalOccs + , setGlobalIdCache + , getGlobalIdCache + , GlobalOcc(..) + -- * Group + , modifyGroup + , resetGroup + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Transform + +import GHC.StgToJS.Types + +import GHC.Unit.Module +import GHC.Stg.Syntax + +import GHC.Types.SrcLoc +import GHC.Types.Id +import GHC.Types.Unique.FM +import GHC.Types.ForeignCall + +import qualified Control.Monad.Trans.State.Strict as State +import GHC.Data.FastString +import GHC.Data.FastMutInt + +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 + +initState :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> IO GenState +initState config m unfloat = do + id_gen <- newFastMutInt 1 + pure $ GenState + { gsSettings = config + , gsModule = m + , gsId = id_gen + , gsIdents = emptyIdCache + , gsUnfloated = unfloat + , gsGroup = defaultGenGroupState + , gsGlobal = [] + } + + +modifyGroup :: (GenGroupState -> GenGroupState) -> G () +modifyGroup f = State.modify mod_state + where + mod_state s = s { gsGroup = f (gsGroup s) } + +-- | emit a global (for the current module) toplevel statement +emitGlobal :: JStat -> G () +emitGlobal stat = State.modify (\s -> s { gsGlobal = stat : gsGlobal s }) + +-- | add a dependency on a particular symbol to the current group +addDependency :: OtherSymb -> G () +addDependency symbol = modifyGroup mod_group + where + mod_group g = g { ggsExtraDeps = S.insert symbol (ggsExtraDeps g) } + +-- | emit a top-level statement for the current binding group +emitToplevel :: JStat -> G () +emitToplevel s = modifyGroup mod_group + where + mod_group g = g { ggsToplevelStats = s : ggsToplevelStats g} + +-- | emit static data for the binding group +emitStatic :: FastString -> StaticVal -> Maybe Ident -> G () +emitStatic ident val cc = modifyGroup mod_group + where + mod_group g = g { ggsStatic = mod_static (ggsStatic g) } + mod_static s = StaticInfo ident val cc : s + +-- | add closure info in our binding group. all heap objects must have closure info +emitClosureInfo :: ClosureInfo -> G () +emitClosureInfo ci = modifyGroup mod_group + where + mod_group g = g { ggsClosureInfo = ci : ggsClosureInfo g} + +emitForeign :: Maybe RealSrcSpan + -> FastString + -> Safety + -> CCallConv + -> [FastString] + -> FastString + -> G () +emitForeign mbSpan pat safety cconv arg_tys res_ty = modifyGroup mod_group + where + mod_group g = g { ggsForeignRefs = new_ref : ggsForeignRefs g } + new_ref = ForeignJSRef spanTxt pat safety cconv arg_tys res_ty + spanTxt = case mbSpan of + -- TODO: Is there a better way to concatenate FastStrings? + Just sp -> mkFastString $ + unpackFS (srcSpanFile sp) ++ + " " ++ + show (srcSpanStartLine sp, srcSpanStartCol sp) ++ + "-" ++ + show (srcSpanEndLine sp, srcSpanEndCol sp) + Nothing -> "" + + + + + + +-- | start with a new binding group +resetGroup :: G () +resetGroup = State.modify (\s -> s { gsGroup = defaultGenGroupState }) + +defaultGenGroupState :: GenGroupState +defaultGenGroupState = GenGroupState [] [] [] [] 0 S.empty emptyGlobalIdCache [] + +emptyGlobalIdCache :: GlobalIdCache +emptyGlobalIdCache = GlobalIdCache emptyUFM + +emptyIdCache :: IdCache +emptyIdCache = IdCache M.empty + + + +assertRtsStat :: G JStat -> G JStat +assertRtsStat stat = do + s <- State.gets gsSettings + if csAssertRts s then stat else pure mempty + +getSettings :: G StgToJSConfig +getSettings = State.gets gsSettings + +getGlobalIdCache :: G GlobalIdCache +getGlobalIdCache = State.gets (ggsGlobalIdCache . gsGroup) + +setGlobalIdCache :: GlobalIdCache -> G () +setGlobalIdCache v = State.modify (\s -> s { gsGroup = (gsGroup s) { ggsGlobalIdCache = v}}) + + +data GlobalOcc = GlobalOcc + { global_ident :: !Ident + , global_id :: !Id + , global_count :: !Word + } + +-- | Return number of occurrences of every global id used in the given JStat. +-- Sort by increasing occurrence count. +globalOccs :: JStat -> G [GlobalOcc] +globalOccs jst = do + GlobalIdCache gidc <- getGlobalIdCache + -- build a map form Ident Unique to (Ident, Id, Count) + 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 gids = \case + [] -> -- return global Ids used locally sorted by increased use + L.sortBy cmp_cnt $ nonDetEltsUFM gids + (i:is) -> + -- check if the Id is global + case lookupUFM gidc i of + Nothing -> go gids is + 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 + + pure $ go emptyUFM (identsS jst) diff --git a/GHC/StgToJS/Object.hs b/GHC/StgToJS/Object.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Object.hs @@ -0,0 +1,622 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- only for DB.Binary instances on Module +{-# OPTIONS_GHC -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Object +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Sylvain Henry +-- Jeffrey Young +-- Luite Stegeman +-- Josh Meredith +-- 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 + , getObjectHeader + , getObjectBody + , getObject + , readObject + , getObjectUnits + , readObjectUnits + , readObjectDeps + , isGlobalUnit + , isJsObjectFile + , Object(..) + , IndexEntry(..) + , Deps (..), BlockDeps (..), DepsLocation (..) + , ExportedFun (..) + ) +where + +import GHC.Prelude + +import Control.Monad + +import Data.Array +import Data.Int +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS +import Data.List (sortOn) +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 GHC.Settings.Constants (hiVersion) + +import GHC.JS.Syntax +import GHC.StgToJS.Types + +import GHC.Unit.Module + +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) + +-- | An 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) + -- ^ Offset of the payload (units) + , objDeps :: !Deps + -- ^ Dependencies + , objIndex :: !Index + -- ^ The Index, serialed unit indices and their linkable units + } + +type BlockId = Int +type BlockIds = IntSet + +-- | dependencies for a single module +data Deps = Deps + { depsModule :: !Module + -- ^ module + , depsRequired :: !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) + -- ^ exported Haskell functions -> block + , depsBlocks :: !(Array BlockId BlockDeps) + -- ^ info about each block + } + +instance Outputable Deps where + ppr d = vcat + [ hcat [ text "module: ", pprModule (depsModule d) ] + , hcat [ text "exports: ", ppr (M.keys (depsHaskellExported d)) ] + ] + +-- | Where are the dependencies +data DepsLocation + = 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 + 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)] + +data BlockDeps = BlockDeps + { blockBlockDeps :: [Int] -- ^ 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 + +-- | Exported Functions +data ExportedFun = ExportedFun + { funModule :: !Module -- ^ The module containing the function + , funSymbol :: !LexicalFastString -- ^ The function + } deriving (Eq, Ord) + +instance Outputable ExportedFun where + ppr (ExportedFun m f) = vcat + [ hcat [ text "module: ", pprModule m ] + , hcat [ text "symbol: ", ppr f ] + ] + +-- | Write an ObjUnit, 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 + lazyPut bh d + put_ bh e + put_ bh f + put_ bh g + +-- | Read an ObjUnit 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 + d <- lazyGet bh + e <- get bh + f <- get bh + g <- get bh + pure $ ObjUnit + { oiSymbols = syms + , oiClInfo = b + , oiStatic = c + , oiStat = d + , oiRaw = e + , oiFExports = f + , oiFImports = g + } + + +-- | 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) +type Index = [IndexEntry] +data IndexEntry = IndexEntry + { idxSymbols :: ![FastString] -- ^ Symbols exported by a unit + , idxOffset :: !(Bin ObjUnit) -- ^ Offset of the unit in the object file + } + + +-------------------------------------------------------------------------------- +-- Essential oeprations 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 + -> ModuleName -- ^ module + -> Deps -- ^ dependencies + -> [ObjUnit] -- ^ linkable units and their symbols + -> IO () +putObject bh mod_name deps os = do + forM_ magic (putByte bh . fromIntegral . ord) + put_ bh (show hiVersion) + + -- we store the module name as a String because we don't want to have to + -- decode the FastString table just to decode it when we're looking for an + -- object in an archive. + put_ bh (moduleNameString mod_name) + + (bh_fs, _bin_dict, put_dict) <- initFSTable bh + + forwardPut_ bh (const put_dict) $ 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 + -- write units without their symbols + putObjUnit 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 bh = do + is_magic <- getCheckMagic bh + case is_magic of + False -> pure (Left "invalid magic header") + True -> do + is_correct_version <- ((== hiVersion) . read) <$> get bh + case is_correct_version of + False -> pure (Left "invalid header version") + True -> do + mod_name <- get bh + pure (Right (mkModuleName (mod_name))) + + +-- | Parse object body. Must be called after a sucessful getObjectHeader +getObjectBody :: BinHandle -> 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 } + + deps <- get bh + idx <- forwardGet bh (get bh) + payload_pos <- tellBin bh + + pure $ Object + { objModuleName = mod_name + , objHandle = bh + , objPayloadOffset = payload_pos + , objDeps = deps + , objIndex = idx + } + +-- | Parse object +getObject :: BinHandle -> IO (Maybe Object) +getObject bh = do + getObjectHeader bh >>= \case + Left _err -> pure Nothing + Right mod_name -> Just <$> getObjectBody bh mod_name + +-- | Read object from file +-- +-- The object is still in memory after this (see objHandle). +readObject :: FilePath -> IO (Maybe Object) +readObject file = do + bh <- readBinMem file + getObject bh + +-- | Reads only the part necessary to get the dependencies +readObjectDeps :: FilePath -> IO (Maybe Deps) +readObjectDeps file = do + bh <- readBinMem file + getObject bh >>= \case + Just obj -> pure $! Just $! objDeps 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..]) + where + bh = objHandle obj + read_entry (e@(IndexEntry syms offset),i) + | pred i e = do + seekBin bh offset + Just <$> getObjUnit 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 + readObject file >>= \case + Nothing -> pure [] + Just obj -> getObjectUnits obj pred + + +-------------------------------------------------------------------------------- +-- Helper functions +-------------------------------------------------------------------------------- + +putEnum :: Enum a => BinHandle -> 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 bh = toEnum . fromIntegral <$> (get bh :: IO Word16) + +-- | Helper to convert Int to Int32 +toI32 :: Int -> Int32 +toI32 = fromIntegral + +-- | Helper to convert Int32 to Int +fromI32 :: Int32 -> Int +fromI32 = fromIntegral + + +-------------------------------------------------------------------------------- +-- Binary Instances +-------------------------------------------------------------------------------- + +instance Binary IndexEntry where + 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 + 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 + <*> (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) + +instance Binary BlockDeps where + put_ bh (BlockDeps bbd bfd) = put_ bh bbd >> put_ bh bfd + get bh = BlockDeps <$> get bh <*> get bh + +instance Binary ForeignJSRef where + put_ bh (ForeignJSRef span pat safety cconv arg_tys res_ty) = + put_ bh span >> put_ bh pat >> putEnum bh safety >> putEnum bh cconv >> put_ bh arg_tys >> put_ bh res_ty + get bh = ForeignJSRef <$> get bh <*> get bh <*> getEnum bh <*> getEnum bh <*> get bh <*> get bh + +instance Binary ExpFun where + 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 + 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 + 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" + 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) + +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) + 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) + +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 + get bh = ClosureInfo <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh + +instance Binary JSFFIType where + put_ bh = putEnum bh + get bh = getEnum bh + +instance Binary VarType where + put_ bh = putEnum bh + get bh = getEnum bh + +instance Binary CIRegs where + put_ bh CIRegsUnknown = putByte bh 1 + put_ bh (CIRegs skip types) = putByte bh 2 >> put_ bh skip >> put_ bh types + get bh = getByte bh >>= \case + 1 -> pure CIRegsUnknown + 2 -> CIRegs <$> get bh <*> get bh + n -> error ("Binary get bh CIRegs: invalid tag: " ++ show n) + +instance Binary JOp where + put_ bh = putEnum bh + get bh = getEnum bh + +instance Binary JUOp 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 + put_ bh (CILayoutUnknown size) = putByte bh 2 >> put_ bh size + put_ bh (CILayoutFixed size types) = putByte bh 3 >> put_ bh size >> put_ bh types + get bh = getByte bh >>= \case + 1 -> pure CILayoutVariable + 2 -> CILayoutUnknown <$> get bh + 3 -> CILayoutFixed <$> get bh <*> get bh + n -> error ("Binary get bh CILayout: invalid tag: " ++ show n) + +instance Binary CIStatic where + put_ bh (CIStaticRefs refs) = putByte bh 1 >> put_ bh refs + get bh = getByte bh >>= \case + 1 -> CIStaticRefs <$> get bh + n -> error ("Binary get bh CIStatic: invalid tag: " ++ show n) + +instance Binary CIType where + put_ bh (CIFun arity regs) = putByte bh 1 >> put_ bh arity >> put_ bh regs + put_ bh CIThunk = putByte bh 2 + put_ bh (CICon conTag) = putByte bh 3 >> put_ bh conTag + put_ bh CIPap = putByte bh 4 + put_ bh CIBlackhole = putByte bh 5 + put_ bh CIStackFrame = putByte bh 6 + get bh = getByte bh >>= \case + 1 -> CIFun <$> get bh <*> get bh + 2 -> pure CIThunk + 3 -> CICon <$> get bh + 4 -> pure CIPap + 5 -> pure CIBlackhole + 6 -> pure CIStackFrame + n -> error ("Binary get bh CIType: invalid tag: " ++ show n) + +instance Binary ExportedFun where + put_ bh (ExportedFun modu symb) = put_ bh modu >> put_ bh symb + get bh = ExportedFun <$> get bh <*> get bh + +instance Binary StaticInfo where + put_ bh (StaticInfo ident val cc) = put_ bh ident >> put_ bh val >> put_ bh cc + 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 + get bh = getByte bh >>= \case + 1 -> StaticFun <$> get bh <*> get bh + 2 -> StaticThunk <$> get bh + 3 -> StaticUnboxed <$> get bh + 4 -> StaticData <$> get bh <*> get bh + 5 -> StaticList <$> get bh <*> get bh + n -> error ("Binary get bh StaticVal: invalid tag " ++ show n) + +instance Binary StaticUnboxed where + put_ bh (StaticUnboxedBool b) = putByte bh 1 >> put_ bh b + put_ bh (StaticUnboxedInt i) = putByte bh 2 >> put_ bh i + put_ bh (StaticUnboxedDouble d) = putByte bh 3 >> put_ bh d + put_ bh (StaticUnboxedString str) = putByte bh 4 >> put_ bh str + put_ bh (StaticUnboxedStringOffset str) = putByte bh 5 >> put_ bh str + get bh = getByte bh >>= \case + 1 -> StaticUnboxedBool <$> get bh + 2 -> StaticUnboxedInt <$> get bh + 3 -> StaticUnboxedDouble <$> get bh + 4 -> StaticUnboxedString <$> get bh + 5 -> StaticUnboxedStringOffset <$> get bh + n -> error ("Binary get bh StaticUnboxed: invalid tag " ++ show n) + +instance Binary StaticArg where + put_ bh (StaticObjArg i) = putByte bh 1 >> put_ bh i + put_ bh (StaticLitArg p) = putByte bh 2 >> put_ bh p + put_ bh (StaticConArg c args) = putByte bh 3 >> put_ bh c >> put_ bh args + get bh = getByte bh >>= \case + 1 -> StaticObjArg <$> get bh + 2 -> StaticLitArg <$> get bh + 3 -> StaticConArg <$> get bh <*> get bh + n -> error ("Binary get bh StaticArg: invalid tag " ++ show n) + +instance Binary StaticLit where + put_ bh (BoolLit b) = putByte bh 1 >> put_ bh b + put_ bh (IntLit i) = putByte bh 2 >> put_ bh i + put_ bh NullLit = putByte bh 3 + put_ bh (DoubleLit d) = putByte bh 4 >> put_ bh d + put_ bh (StringLit t) = putByte bh 5 >> put_ bh t + put_ bh (BinLit b) = putByte bh 6 >> put_ bh b + put_ bh (LabelLit b t) = putByte bh 7 >> put_ bh b >> put_ bh t + get bh = getByte bh >>= \case + 1 -> BoolLit <$> get bh + 2 -> IntLit <$> get bh + 3 -> pure NullLit + 4 -> DoubleLit <$> get bh + 5 -> StringLit <$> get bh + 6 -> BinLit <$> get bh + 7 -> LabelLit <$> get bh <*> get bh + n -> error ("Binary get bh StaticLit: invalid tag " ++ show n) diff --git a/GHC/StgToJS/Prim.hs b/GHC/StgToJS/Prim.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Prim.hs @@ -0,0 +1,1502 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MultiWayIf #-} + +-- disable this warning because of all the lambdas matching on primops' +-- arguments. +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module GHC.StgToJS.Prim + ( genPrim + ) +where + +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) +import Data.Maybe + + +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 (newArray r l e) + ReadArrayOp -> \[r] [a,i] -> PrimInline $ boundsChecked bound a i (r |= a .! i) + WriteArrayOp -> \[] [a,i,v] -> PrimInline $ boundsChecked 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 $ boundsChecked 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 $ loopBlockS (Int 0) (.<. n) \i -> + [ ma .! (Add i o2) |= a .! (Add i o1) + , preIncrS i + ] + CopyMutableArrayOp -> \[] [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n] + CloneArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] + CloneMutableArrayOp -> \[r] [a,start,n] -> genPrim prof bound ty CloneArrayOp [r] [a,start,n] + FreezeArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] + ThawArrayOp -> \[r] [a,start,n] -> PrimInline $ r |= app "h$sliceArray" [a,start,n] + CasArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ + 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 $ boundsChecked bound a i (r |= a .! i) + WriteSmallArrayOp -> \[] [a,i,e] -> PrimInline $ boundsChecked 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 $ boundsChecked 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 $ + loopBlockS (Sub n one_) (.>=. zero_) \i -> + [ d .! (Add di i) |= s .! (Add si i) + , postDecrS i + ] + CopySmallMutableArrayOp -> \[] [s,si,d,di,n] -> PrimInline $ appS "h$copyMutableArray" [s,si,d,di,n] + CloneSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n + CloneSmallMutableArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n + FreezeSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n + ThawSmallArrayOp -> \[r] [a,o,n] -> PrimInline $ cloneArray r a (Just o) n + CasSmallArrayOp -> \[s,o] [a,i,old,new] -> PrimInline $ 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 . boundsChecked bound a i $ r |= read_u8 a i + IndexByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + IndexByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + IndexByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i + IndexByteArrayOp_Addr -> \[r1,r2] [a,i] -> + PrimInline . boundsChecked bound a i $ jVar \t -> mconcat + [ t |= a .^ "arr" + , ifBlockS (t .&&. t .! (i .<<. two_)) + [ r1 |= t .! (i .<<. two_) .! zero_ + , r2 |= t .! (i .<<. two_) .! one_ + ] + [ r1 |= null_ + , r2 |= zero_ + ] + ] + + IndexByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i + IndexByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i + IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> + PrimInline . boundsChecked bound a (Add i 3) $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= read_i32 a i + ] + IndexByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i + IndexByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i + IndexByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + IndexByteArrayOp_Int64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_i32 a (Add (i .<<. one_) one_) + , l |= read_u32 a (i .<<. one_) + ] + IndexByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i + IndexByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i + IndexByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i + IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_u32 a (Add (i .<<. one_) one_) + , l |= read_u32 a (i .<<. one_) + ] + ReadByteArrayOp_Char -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i + ReadByteArrayOp_WideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + ReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + ReadByteArrayOp_Word -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i + ReadByteArrayOp_Addr -> \[r1,r2] [a,i] -> + PrimInline $ jVar \x -> mconcat + [ x |= i .<<. two_ + , ifS (a .^ "arr" .&&. a .^ "arr" .! x) + (mconcat [ r1 |= a .^ "arr" .! x .! zero_ + , r2 |= a .^ "arr" .! x .! one_ + ]) + (mconcat [r1 |= null_, r2 |= one_]) + ] + ReadByteArrayOp_Float -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i + ReadByteArrayOp_Double -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i + ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] -> + PrimInline . boundsChecked bound a (Add i 3) $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= read_i32 a i + ] + ReadByteArrayOp_Int8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_i8 a i + ReadByteArrayOp_Int16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i + ReadByteArrayOp_Int32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + ReadByteArrayOp_Int64 -> \[h,l] [a,i] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_i32 a (Add (i .<<. one_) one_) + , l |= read_u32 a (i .<<. one_) + ] + ReadByteArrayOp_Word8 -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_u8 a i + ReadByteArrayOp_Word16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i + ReadByteArrayOp_Word32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i + ReadByteArrayOp_Word64 -> \[h,l] [a,i] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_u32 a (Add (i .<<. one_) one_) + , l |= read_u32 a (i .<<. one_) + ] + WriteByteArrayOp_Char -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e + WriteByteArrayOp_WideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e + WriteByteArrayOp_Int -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e + WriteByteArrayOp_Word -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e + WriteByteArrayOp_Addr -> \[] [a,i,e1,e2] -> + PrimInline $ mconcat + [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) + ] + WriteByteArrayOp_Float -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e + WriteByteArrayOp_Double -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e + WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2 + + WriteByteArrayOp_Int8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_i8 a i e + WriteByteArrayOp_Int16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e + WriteByteArrayOp_Int32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e + WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ write_i32 a (Add (i .<<. one_) one_) e1 + , write_u32 a (i .<<. one_) e2 + ] + WriteByteArrayOp_Word8 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_u8 a i e + WriteByteArrayOp_Word16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e + WriteByteArrayOp_Word32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e + WriteByteArrayOp_Word64 -> \[] [a,i,h,l] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ write_u32 a (Add (i .<<. one_) one_) h + , write_u32 a (i .<<. one_) l + ] + CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] -> + PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) + . boundsChecked bound a2 (Add o2 (Sub n 1)) + $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n] + + CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] -> + PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1)) + . boundsChecked bound a2 (Add o2 (Sub n 1)) + $ appS "h$copyMutableByteArray" [a1,o1,a2,o2,n] + CopyMutableByteArrayOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + CopyByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + CopyAddrToByteArrayOp -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs + + SetByteArrayOp -> \[] [a,o,n,v] -> + PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i -> + [ write_u8 a (Add o i) v + , postIncrS i + ] + + AtomicReadByteArrayOp_Int -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i + AtomicWriteByteArrayOp_Int -> \[] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v + FetchAddByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add r a i v + FetchSubByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub r a i v + FetchAndByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v + FetchOrByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr r a i v + FetchNandByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v + FetchXorByteArrayOp_Int -> \[r] [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ 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 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Addr -> \[ca,co] [a,o,i] -> + PrimInline . boundsChecked bound (a .^ "arr") (off32 o i) + $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_)) + [ ca |= a .^ "arr" .! (off32 o i) .! zero_ + , co |= a .^ "arr" .! (off32 o i) .! one_ + ] + [ ca |= null_ + , co |= zero_ + ] + IndexOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) + IndexOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) + IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat + [ c1 |= var "h$stablePtrBuf" + , c2 |= read_boff_i32 a (off32 o i) + ] + IndexOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_i8 a (off8 o i) + IndexOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i) + IndexOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] -> + PrimInline $ mconcat + [ h |= read_boff_i32 a (Add (off64 o i) (Int 4)) + , l |= read_boff_u32 a (off64 o i) + ] + IndexOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) + IndexOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i) + IndexOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) + IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] -> + PrimInline $ mconcat + [ h |= read_boff_u32 a (Add (off64 o i) (Int 4)) + , l |= read_boff_u32 a (off64 o i) + ] + ReadOffAddrOp_Char -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ c |= read_boff_u8 a (off8 o i) + ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i) + ReadOffAddrOp_Word -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i) + ReadOffAddrOp_Addr -> \[c1,c2] [a,o,i] -> + PrimInline $ jVar \x -> mconcat + [ x |= i .<<. two_ + , boundsChecked bound (a .^ "arr") (Add o x) $ + ifBlockS (a .^ "arr" .&&. a .^ "arr" .! (Add o x)) + [ c1 |= a .^ "arr" .! (Add o x) .! zero_ + , c2 |= a .^ "arr" .! (Add o x) .! one_ + ] + [ c1 |= null_ + , c2 |= zero_ + ] + ] + ReadOffAddrOp_Float -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i) + ReadOffAddrOp_Double -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i) + ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat + [ c1 |= var "h$stablePtrBuf" + , c2 |= read_boff_u32 a (off32 o i) + ] + ReadOffAddrOp_Int8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_i8 a (off8 o i) + ReadOffAddrOp_Int16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i) + ReadOffAddrOp_Int32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i) + ReadOffAddrOp_Int64 -> \[h,l] [a,o,i] -> + PrimInline $ mconcat + [ h |= read_i32 a (Add (off64 o i) (Int 4)) + , l |= read_u32 a (off64 o i) + ] + ReadOffAddrOp_Word8 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8 o i) $ AssignStat c $ read_boff_u8 a (off8 o i) + ReadOffAddrOp_Word16 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i) + ReadOffAddrOp_Word32 -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i) + ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] -> + PrimInline $ mconcat + [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4)) + , c2 |= read_boff_u32 a (off64 o i) + ] + WriteOffAddrOp_Char -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_WideChar -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Word -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Addr -> \[] [a,o,i,va,vo] -> + PrimInline $ mconcat + [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , boundsChecked bound (a .^ "arr") (off32 o i) $ + AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo]) + ] + WriteOffAddrOp_Float -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v + WriteOffAddrOp_Double -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v + WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2 + WriteOffAddrOp_Int8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_i8 a (off8 o i) v + WriteOffAddrOp_Int16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v + WriteOffAddrOp_Int32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v + WriteOffAddrOp_Int64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat + [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1 + , write_boff_u32 a (off64 o i) v2 + ] + WriteOffAddrOp_Word8 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off8 o i) $ write_boff_u8 a (off8 o i) v + WriteOffAddrOp_Word16 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v + WriteOffAddrOp_Word32 -> \[] [a,o,i,v] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v + WriteOffAddrOp_Word64 -> \[] [a,o,i,v1,v2] -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat + [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1 + , write_boff_u32 a (off64 o i) v2 + ] +-- Mutable variables + 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 $ r |= var "h$threads" + 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] + + IndexByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i + IndexByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> + PrimInline $ jVar \x -> mconcat + [ x |= i .<<. two_ + , boundsChecked bound (a .^ "arr") x $ + ifS (a .^ "arr" .&&. a .^ "arr" .! x) + (mconcat [ r1 |= a .^ "arr" .! x .! zero_ + , r2 |= a .^ "arr" .! x .! one_ + ]) + (mconcat [r1 |= null_, r2 |= one_]) + ] + IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i + IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i + IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> + PrimInline $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= read_boff_i32 a i + ] + IndexByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i + IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> + PrimInline $ mconcat + [ h |= read_boff_i32 a (Add i (Int 4)) + , l |= read_boff_u32 a i + ] + IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + IndexByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i + IndexByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i + IndexByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_boff_u32 a (Add i (Int 4)) + , l |= read_boff_u32 a i + ] + IndexByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i + + ReadByteArrayOp_Word8AsChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a i $ r |= read_boff_u8 a i + ReadByteArrayOp_Word8AsWideChar -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsAddr -> \[r1,r2] [a,i] -> + PrimInline $ jVar \x -> mconcat + [ x |= i .<<. two_ + , boundsChecked bound (a .^ "arr") x $ + ifS (a .^ "arr" .&&. a .^ "arr" .! x) + (mconcat [ r1 |= a .^ "arr" .! x .! zero_ + , r2 |= a .^ "arr" .! x .! one_ + ]) + (mconcat [r1 |= null_, r2 |= one_]) + ] + ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i + ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i + ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] -> + PrimInline $ mconcat + [ r1 |= var "h$stablePtrBuf" + , r2 |= read_boff_i32 a i + ] + ReadByteArrayOp_Word8AsInt16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i + ReadByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] -> + PrimInline $ mconcat + [ h |= read_boff_i32 a (Add i (Int 4)) + , l |= read_boff_u32 a i + ] + ReadByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i + ReadByteArrayOp_Word8AsWord16 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16 a i + ReadByteArrayOp_Word8AsWord32 -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i + ReadByteArrayOp_Word8AsWord64 -> \[h,l] [a,i] -> + PrimInline . boundsChecked bound a (Add i 7) $ mconcat + [ h |= read_boff_u32 a (Add i (Int 4)) + , l |= read_boff_u32 a i + ] + ReadByteArrayOp_Word8AsWord -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32 a i + + WriteByteArrayOp_Word8AsChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i $ write_boff_i8 a i e + WriteByteArrayOp_Word8AsWideChar -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsAddr -> \[] [a,i,e1,e2] -> + PrimInline $ mconcat + [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty + , boundsChecked bound (a .^ "arr") (i .<<. two_) $ + a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2]) + ] + + WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e + WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e + WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2 + WriteByteArrayOp_Word8AsInt16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e + WriteByteArrayOp_Word8AsInt32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] -> + -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i + -- then write the higher 4 bytes to i+4 + PrimInline . boundsChecked bound a i + $ mconcat [ write_boff_i32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + WriteByteArrayOp_Word8AsInt -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e + WriteByteArrayOp_Word8AsWord16 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e + WriteByteArrayOp_Word8AsWord32 -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e + WriteByteArrayOp_Word8AsWord64 -> \[] [a,i,h,l] -> + PrimInline . boundsChecked bound a (Add i 7) + $ mconcat [ write_boff_u32 a (Add i (Int 4)) h + , write_boff_u32 a i l + ] + WriteByteArrayOp_Word8AsWord -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e + + CasByteArrayOp_Int -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new + CasByteArrayOp_Int8 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i $ casOp read_i8 write_i8 r a i old new + CasByteArrayOp_Int16 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new + CasByteArrayOp_Int32 -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new + + CasByteArrayOp_Int64 -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $ + jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_) + , t_l |= read_u32 a (i .<<. one_) + , r_h |= t_h + , r_l |= t_l + , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast + (ifBlockS (t_h .===. old_h) + -- Pre-Condition is good, do the write + [ write_i32 a (Add (i .<<. one_) one_) new_h + , write_u32 a (i .<<. one_) new_l + ] + -- no good, don't write + mempty) + mempty + ] + + CasAddrOp_Addr -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $ + mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2]) + (appS "h$memcpy" [a3,o3,a1,o1,8]) + mempty + , r_a |= a1 + , r_o |= o1 + ] + 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 -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $ + mconcat [ r_h |= read_u32 a (Add o (Int 4)) + , r_l |= read_u32 a o + , ifS (r_l .===. old_l) + (ifBlockS (r_h .===. old_h) + [ write_u32 a (Add o (Int 4)) new_h + , write_u32 a o new_l + ] + mempty) + mempty + ] + + 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 -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $ + -- this primop can't be implemented + -- correctly because we don't store + -- the array reference part of an Addr#, + -- only the offset part. + -- + -- So let's assume that all the array + -- references are the same... + -- + -- Note: we could generate an assert + -- that checks that a1 === a2. However + -- we can't check that the Addr# read + -- at Addr# a2[o2] also comes from this + -- a1/a2 array. + mconcat [ r_a |= a1 -- might be wrong (see above) + , r_o |= read_boff_u32 a1 o1 + -- TODO (see above) + -- assert that a1 === a2 + , write_boff_u32 a1 o1 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 + +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 + +-- 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_] + +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_] + +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 arrays + -> 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 + ] + +-------------------------------------------------------------------------------- +-- Lifted Arrays +-------------------------------------------------------------------------------- +-- | lifted arrays +cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat +cloneArray tgt src mb_offset len = mconcat + [ tgt |= ApplExpr (src .^ "slice") [start, end] + , tgt .^ closureMeta_ |= zero_ + , tgt .^ "__ghcjsArray" |= true_ + ] + where + start = fromMaybe zero_ mb_offset + end = maybe len (Add len) mb_offset + +newArray :: JExpr -> JExpr -> JExpr -> JStat +newArray tgt len elem = + tgt |= app "h$newArray" [len, elem] + +newByteArray :: JExpr -> JExpr -> JStat +newByteArray tgt len = + tgt |= app "h$newByteArray" [len] + +boundsChecked :: Bool -- ^ Should we do bounds checking? + -> JExpr -- ^ Array + -> JExpr -- ^ Index + -> JStat -- ^ Result + -> JStat +boundsChecked False _ _ r = r +boundsChecked True xs i r = + ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_)) + r + (returnS $ app "h$exitProcess" [Int 134]) + +-- 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) diff --git a/GHC/StgToJS/Printer.hs b/GHC/StgToJS/Printer.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Printer.hs @@ -0,0 +1,218 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Profiling.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Profiling + ( initCostCentres + , emitCostCentreDecl + , emitCostCentreStackDecl + , enterCostCentreFun + , enterCostCentreThunk + , setCC + , pushRestoreCCS + , jCurrentCCS + , jCafCCS + , jSystemCCS + , costCentreLbl + , costCentreStackLbl + , singletonCCSLbl + , ccsVarJ + -- * Predicates + , profiling + , ifProfiling + , ifProfilingM + -- * helpers + , profStat + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Regs +import GHC.StgToJS.Types +import GHC.StgToJS.Symbols +import GHC.StgToJS.Monad + +import GHC.Types.CostCentre + +import GHC.Data.FastString +import GHC.Unit.Module +import GHC.Utils.Encoding +import GHC.Utils.Outputable +import GHC.Utils.Panic +import qualified Control.Monad.Trans.State.Strict as State + +-------------------------------------------------------------------------------- +-- Initialization + +initCostCentres :: CollectedCCs -> G () +initCostCentres (local_CCs, singleton_CCSs) = do + mapM_ emitCostCentreDecl local_CCs + mapM_ emitCostCentreStackDecl singleton_CCSs + +emitCostCentreDecl :: CostCentre -> G () +emitCostCentreDecl cc = do + ccsLbl <- costCentreLbl cc + let is_caf = isCafCC cc + 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 + ]) + emitGlobal js + +emitCostCentreStackDecl :: CostCentreStack -> G () +emitCostCentreStackDecl ccs = + case maybeSingletonCCS ccs of + Just cc -> do + ccsLbl <- singletonCCSLbl cc + ccLbl <- costCentreLbl cc + let js = ccsLbl ||= UOpExpr NewOp (ApplExpr (var "h$CCS") [null_, toJExpr ccLbl]) + emitGlobal js + Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs) + +-------------------------------------------------------------------------------- +-- Entering to cost-centres + +enterCostCentreFun :: CostCentreStack -> JStat +enterCostCentreFun ccs + | isCurrentCCS ccs = ApplStat (var "h$enterFunCCS") [jCurrentCCS, r1 .^ "cc"] + | otherwise = mempty -- top-level function, nothing to do + +enterCostCentreThunk :: JStat +enterCostCentreThunk = ApplStat (var "h$enterThunkCCS") [r1 .^ "cc"] + +setCC :: CostCentre -> Bool -> Bool -> G JStat +setCC cc _tick True = do + ccI@(TxtI _ccLbl) <- costCentreLbl cc + addDependency $ OtherSymb (cc_mod cc) + (moduleGlobalSymbol $ cc_mod cc) + return $ jCurrentCCS |= ApplExpr (var "h$pushCostCentre") [jCurrentCCS, toJExpr ccI] +setCC _cc _tick _push = return mempty + +pushRestoreCCS :: JStat +pushRestoreCCS = ApplStat (var "h$pushRestoreCCS") [] + +-------------------------------------------------------------------------------- +-- Some cost-centre stacks to be used in generator + +jCurrentCCS :: JExpr +jCurrentCCS = var "h$currentThread" .^ "ccs" + +jCafCCS :: JExpr +jCafCCS = var "h$CAF" + +jSystemCCS :: JExpr +jSystemCCS = var "h$CCS_SYSTEM" +-------------------------------------------------------------------------------- +-- Helpers for generating profiling related things + +profiling :: G Bool +profiling = csProf <$> getSettings + +ifProfiling :: Monoid m => m -> G m +ifProfiling m = do + prof <- profiling + return $ if prof then m else mempty + +ifProfilingM :: Monoid m => G m -> G m +ifProfilingM m = do + prof <- profiling + if prof then m else return mempty + +-- | If profiling is enabled, then use input JStat, else ignore +profStat :: StgToJSConfig -> JStat -> JStat +profStat cfg e = if csProf cfg then e else mempty +-------------------------------------------------------------------------------- +-- Generating cost-centre and cost-centre stack variables + +costCentreLbl' :: CostCentre -> G String +costCentreLbl' cc = do + curModl <- State.gets gsModule + let lbl = renderWithContext defaultSDocContext + $ withPprStyle PprCode (ppr cc) + return . ("h$"++) . zEncodeString $ + moduleNameColons (moduleName curModl) ++ "_" ++ if isCafCC cc then "CAF_ccs" else lbl + +costCentreLbl :: CostCentre -> G Ident +costCentreLbl cc = TxtI . mkFastString <$> costCentreLbl' cc + +costCentreStackLbl' :: CostCentreStack -> G (Maybe String) +costCentreStackLbl' ccs = do + ifProfilingM f + where + f | isCurrentCCS ccs = return $ Just "h$currentThread.ccs" + | dontCareCCS == ccs = return $ Just "h$CCS_DONT_CARE" + | otherwise = + case maybeSingletonCCS ccs of + Just cc -> Just <$> singletonCCSLbl' cc + Nothing -> pure Nothing + +costCentreStackLbl :: CostCentreStack -> G (Maybe Ident) +costCentreStackLbl ccs = fmap (TxtI . mkFastString) <$> costCentreStackLbl' ccs + +singletonCCSLbl' :: CostCentre -> G String +singletonCCSLbl' cc = do + curModl <- State.gets gsModule + ccLbl <- costCentreLbl' cc + let ccsLbl = ccLbl ++ "_ccs" + return . zEncodeString $ mconcat + [ moduleNameColons (moduleName curModl) + , "_" + , ccsLbl + ] + +singletonCCSLbl :: CostCentre -> G Ident +singletonCCSLbl cc = TxtI . mkFastString <$> singletonCCSLbl' cc + +ccsVarJ :: CostCentreStack -> G (Maybe JExpr) +ccsVarJ ccs = do + prof <- profiling + if prof + then fmap (ValExpr . JVar) <$> costCentreStackLbl ccs + else pure Nothing diff --git a/GHC/StgToJS/Regs.hs b/GHC/StgToJS/Regs.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Regs.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Regs + ( StgReg (..) + , Special(..) + , sp + , stack + , r1, r2, r3, r4 + , regsFromR1 + , regsFromR2 + , jsRegsFromR1 + , jsRegsFromR2 + , StgRet (..) + , jsRegToInt + , intToJSReg + , jsReg + , maxReg + , minReg + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.Data.FastString + +import Data.Array +import Data.Char + +-- | General purpose "registers" +-- +-- The JS backend arbitrarily supports 128 registers +data StgReg + = R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8 + | R9 | R10 | R11 | R12 | R13 | R14 | R15 | R16 + | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24 + | R25 | R26 | R27 | R28 | R29 | R30 | R31 | R32 + | R33 | R34 | R35 | R36 | R37 | R38 | R39 | R40 + | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48 + | R49 | R50 | R51 | R52 | R53 | R54 | R55 | R56 + | R57 | R58 | R59 | R60 | R61 | R62 | R63 | R64 + | R65 | R66 | R67 | R68 | R69 | R70 | R71 | R72 + | R73 | R74 | R75 | R76 | R77 | R78 | R79 | R80 + | R81 | R82 | R83 | R84 | R85 | R86 | R87 | R88 + | R89 | R90 | R91 | R92 | R93 | R94 | R95 | R96 + | R97 | R98 | R99 | R100 | R101 | R102 | R103 | R104 + | R105 | R106 | R107 | R108 | R109 | R110 | R111 | R112 + | R113 | R114 | R115 | R116 | R117 | R118 | R119 | R120 + | R121 | R122 | R123 | R124 | R125 | R126 | R127 | R128 + deriving (Eq, Ord, Show, Enum, Bounded, Ix) + +-- | Stack registers +data Special + = Stack + | Sp + deriving (Show, Eq) + +-- | Return registers +-- +-- Extra results from foreign calls can be stored here (while first result is +-- directly returned) +data StgRet = Ret1 | Ret2 | Ret3 | Ret4 | Ret5 | Ret6 | Ret7 | Ret8 | Ret9 | Ret10 + deriving (Eq, Ord, Show, Enum, Bounded, Ix) + +instance ToJExpr Special where + toJExpr Stack = var "h$stack" + toJExpr Sp = var "h$sp" + +instance ToJExpr StgReg where + toJExpr r = registers ! r + +instance ToJExpr StgRet where + toJExpr r = rets ! r + +--------------------------------------------------- +-- helpers +--------------------------------------------------- + +sp :: JExpr +sp = toJExpr Sp + +stack :: JExpr +stack = toJExpr Stack + +r1, r2, r3, r4 :: JExpr +r1 = toJExpr R1 +r2 = toJExpr R2 +r3 = toJExpr R3 +r4 = toJExpr R4 + + +jsRegToInt :: StgReg -> Int +jsRegToInt = (+1) . fromEnum + +intToJSReg :: Int -> StgReg +intToJSReg r = toEnum (r - 1) + +jsReg :: Int -> JExpr +jsReg r = toJExpr (intToJSReg r) + +maxReg :: Int +maxReg = jsRegToInt maxBound + +minReg :: Int +minReg = jsRegToInt minBound + +-- | List of registers, starting from R1 +regsFromR1 :: [StgReg] +regsFromR1 = enumFrom R1 + +-- | List of registers, starting from R2 +regsFromR2 :: [StgReg] +regsFromR2 = tail regsFromR1 + +-- | List of registers, starting from R1 as JExpr +jsRegsFromR1 :: [JExpr] +jsRegsFromR1 = fmap toJExpr regsFromR1 + +-- | List of registers, starting from R2 as JExpr +jsRegsFromR2 :: [JExpr] +jsRegsFromR2 = tail jsRegsFromR1 + +--------------------------------------------------- +-- caches +--------------------------------------------------- + +-- cache JExpr representing StgReg +registers :: Array StgReg JExpr +registers = listArray (minBound, maxBound) (map regN regsFromR1) + where + regN r + | fromEnum r < 32 = var . mkFastString . ("h$"++) . map toLower . show $ r + | otherwise = IdxExpr (var "h$regs") + (toJExpr ((fromEnum r) - 32)) + +-- cache JExpr representing StgRet +rets :: Array StgRet JExpr +rets = listArray (minBound, maxBound) (map retN (enumFrom Ret1)) + where + retN = var . mkFastString . ("h$"++) . map toLower . show diff --git a/GHC/StgToJS/Rts/Rts.hs b/GHC/StgToJS/Rts/Rts.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Rts/Rts.hs @@ -0,0 +1,661 @@ +{-# 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))) + ] diff --git a/GHC/StgToJS/Rts/Types.hs b/GHC/StgToJS/Rts/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Rts/Types.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE CPP, + FlexibleInstances, + OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Rts.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 +-- +-- Types and utility functions used in the JS RTS. +----------------------------------------------------------------------------- + +module GHC.StgToJS.Rts.Types where + +import GHC.Prelude + +import GHC.JS.Make +import GHC.JS.Syntax +import GHC.StgToJS.Regs +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 +traceRts s ex | (csTraceRts s) = appS "h$log" [ex] + | otherwise = mempty + +-- | Syntactic sugar. Given a @JExpr@, '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 s ex m | csAssertRts s = jwhenS (UOpExpr NotOp ex) (appS "throw" [toJExpr m]) + | otherwise = mempty + +-- | name of the closure 'c' +clName :: JExpr -> JExpr +clName c = c .^ "n" + +-- | Type name of the closure 'c' +clTypeName :: JExpr -> JExpr +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 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 + ] + )) + +-------------------------------------------------------------------------------- +-- Register utilities +-------------------------------------------------------------------------------- + +-- | Perform the computation 'f', on the range of registers bounded by 'start' +-- and 'end'. +withRegs :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat +withRegs start end f = mconcat $ fmap f [start..end] diff --git a/GHC/StgToJS/Sinker.hs b/GHC/StgToJS/Sinker.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Sinker.hs @@ -0,0 +1,180 @@ +{-# 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/Stack.hs b/GHC/StgToJS/Stack.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Stack.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.JS.Stack +-- 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 +-- +-- Utilities and wrappers for Stack manipulation in JS Land. +-- +-- In general, functions suffixed with a tick do the actual work, functions +-- suffixed with an "I" are identical to the non-I versions but work on 'Ident's +-- +-- The stack in JS land is held in the special JS array 'h$stack' and the stack +-- pointer is held in 'h$sp'. The top of the stack thus exists at +-- 'h$stack[h$sp]'. h$stack[h$sp + i] where i > 0, moves deeper into the stack +-- into older entries, whereas h$stack[h$sp - i] moves towards the top of the +-- stack. +-- +-- The stack layout algorithm is slightly peculiar. It makes an effort to +-- remember recently popped things so that if these values need to be pushed +-- then they can be quickly. The implementation for this is storing these values +-- above the stack pointer, and the pushing will skip slots that we know we will +-- use and fill in slots marked as unknown. Thus, you may find that our push and +-- pop functions do some non-traditional stack manipulation such as adding slots +-- in pop or removing slots in push. +----------------------------------------------------------------------------- + +module GHC.StgToJS.Stack + ( resetSlots + , isolateSlots + , setSlots + , getSlots + , addSlots + , dropSlots + , addUnknownSlots + , push + , push' + , adjSpN + , adjSpN' + , adjSp' + , adjSp + , pushNN + , pushNN' + , pushN' + , pushN + , pushOptimized' + , pushOptimized + , pushLneFrame + , popN + , popSkip + , popSkipI + , loadSkip + -- * Thunk update + , updateThunk + , updateThunk' + , bhStats + ) +where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Types +import GHC.StgToJS.Monad +import GHC.StgToJS.Ids +import GHC.StgToJS.ExprCtx +import GHC.StgToJS.Heap +import GHC.StgToJS.Regs + +import GHC.Types.Id +import GHC.Utils.Misc +import GHC.Data.FastString + +import qualified Data.Bits as Bits +import qualified Data.List as L +import qualified Control.Monad.Trans.State.Strict as State +import Data.Array +import Data.Monoid +import Control.Monad + +-- | Run the action, 'm', with no stack info +resetSlots :: G a -> G a +resetSlots m = do + s <- getSlots + d <- getStackDepth + setSlots [] + a <- m + setSlots s + setStackDepth d + return a + +-- | run the action, 'm', with current stack info, but don't let modifications +-- propagate +isolateSlots :: G a -> G a +isolateSlots m = do + s <- getSlots + d <- getStackDepth + a <- m + setSlots s + setStackDepth d + pure a + +-- | Set stack depth +setStackDepth :: Int -> G () +setStackDepth d = modifyGroup (\s -> s { ggsStackDepth = d}) + +-- | Get stack depth +getStackDepth :: G Int +getStackDepth = State.gets (ggsStackDepth . gsGroup) + +-- | Modify stack depth +modifyStackDepth :: (Int -> Int) -> G () +modifyStackDepth f = modifyGroup (\s -> s { ggsStackDepth = f (ggsStackDepth s) }) + +-- | overwrite our stack knowledge +setSlots :: [StackSlot] -> G () +setSlots xs = modifyGroup (\g -> g { ggsStack = xs}) + +-- | retrieve our current stack knowledge +getSlots :: G [StackSlot] +getSlots = State.gets (ggsStack . gsGroup) + +-- | Modify stack slots +modifySlots :: ([StackSlot] -> [StackSlot]) -> G () +modifySlots f = modifyGroup (\g -> g { ggsStack = f (ggsStack g)}) + +-- | add `n` unknown slots to our stack knowledge +addUnknownSlots :: Int -> G () +addUnknownSlots n = addSlots (replicate n SlotUnknown) + +-- | add knowledge about the stack slots +addSlots :: [StackSlot] -> G () +addSlots xs = do + s <- getSlots + setSlots (xs ++ s) + +-- | drop 'n' slots from our stack knowledge +dropSlots :: Int -> G () +dropSlots n = modifySlots (drop n) + +push :: [JExpr] -> G JStat +push xs = do + dropSlots (length xs) + modifyStackDepth (+ (length xs)) + flip push' xs <$> getSettings + +push' :: StgToJSConfig -> [JExpr] -> JStat +push' _ [] = mempty +push' cs xs + | csInlinePush cs || l > 32 || l < 2 = adjSp' l <> mconcat items + | otherwise = ApplStat (toJExpr $ pushN ! l) xs + where + items = zipWith f [(1::Int)..] xs + 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) + + +-- | 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' 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' 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 0 = return mempty +adjSp n = do + -- grow depth by n + modifyStackDepth (+n) + return (adjSp' n) + +-- | 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 0 = return mempty +adjSpN n = do + modifyStackDepth (\x -> x - n) + return (adjSpN' n) + +-- | A constant array that holds global function symbols which do N pushes onto +-- the stack. For example: +-- @ +-- function h$p1(x1) { +-- ++h$sp; +-- h$stack[(h$sp - 0)] = x1; +-- }; +-- function h$p2(x1, x2) { +-- h$sp += 2; +-- h$stack[(h$sp - 1)] = x1; +-- h$stack[(h$sp - 0)] = x2; +-- }; +-- @ +-- +-- and so on up to 32. +pushN :: Array Int Ident +pushN = listArray (1,32) $ map (TxtI . 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' = fmap (ValExpr . JVar) pushN + +-- | Partial Push functions. Like 'pushN' except these push functions skip +-- slots. For example, +-- @ +-- function h$pp33(x1, x2) { +-- h$sp += 6; +-- h$stack[(h$sp - 5)] = x1; +-- h$stack[(h$sp - 0)] = x2; +-- }; +-- @ +-- +-- 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] + +-- | Like 'pushN'' but for the partial push functions +pushNN' :: Array Integer JExpr +pushNN' = fmap (ValExpr . JVar) pushNN + +pushOptimized' :: [(Id,Int)] -> G JStat +pushOptimized' xs = do + slots <- getSlots + pushOptimized =<< (zipWithM f xs (slots++repeat SlotUnknown)) + where + f (i1,n1) xs2 = do + xs <- varsForId i1 + let !id_n1 = xs !! (n1-1) + + case xs2 of + SlotId i2 n2 -> pure (id_n1,i1==i2&&n1==n2) + _ -> pure (id_n1,False) + +-- | 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 [] = return mempty +pushOptimized xs = do + dropSlots l + modifyStackDepth (+ length xs) + go . csInlinePush <$> getSettings + where + go True = inlinePush + go _ + | all snd xs = adjSp' l + | all (not.snd) xs && l <= 32 = + ApplStat (pushN' ! l) (map fst xs) + | l <= 8 && not (snd $ last xs) = + ApplStat (pushNN' ! sig) [ e | (e,False) <- xs ] + | otherwise = inlinePush + l = length xs + sig :: Integer + sig = L.foldl1' (Bits..|.) $ zipWith (\(_e,b) i -> if not b then Bits.bit i else 0) xs [0..] + inlinePush = adjSp' l <> mconcat (zipWith pushSlot [1..] xs) + pushSlot i (ex, False) = IdxExpr stack (offset i) |= ex + pushSlot _ _ = mempty + offset i | i == l = sp + | otherwise = InfixExpr SubOp sp (toJExpr (l - i)) + +-- | push a let-no-escape frame onto the stack +pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStat +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 +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'. +-- This function does no stack pointer manipulation, it merely indexes into the +-- stack and loads payloads into 'xs'. +loadSkip :: Int -> [JExpr] -> JStat +loadSkip = loadSkipFrom sp + where + loadSkipFrom :: JExpr -> Int -> [JExpr] -> JStat + loadSkipFrom fr n xs = mconcat items + where + items = reverse $ zipWith f [(0::Int)..] (reverse xs) + -- helper to generate sp - n offset to index with + offset 0 = fr + offset n = InfixExpr SubOp fr (toJExpr n) + -- helper to load stack .! i into ex, e.g., ex = stack[i] + f i ex = ex |= IdxExpr stack (toJExpr (offset (i+n))) + + +-- | Pop but preserve the first N slots +popSkipI :: Int -> [(Ident,StackSlot)] -> G JStat +popSkipI 0 [] = pure mempty +popSkipI n [] = popN n +popSkipI n xs = do + -- add N unknown slots + addUnknownSlots n + -- now add the slots from xs, after this line the stack should look like + -- [xs] ++ [Unknown...] ++ old_stack + addSlots (map snd xs) + -- move stack pointer into the stack by (length xs + n), basically resetting + -- the stack pointer + a <- adjSpN (length xs + n) + -- 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 +loadSkipI = loadSkipIFrom sp + where loadSkipIFrom :: JExpr -> Int -> [Ident] -> JStat + loadSkipIFrom fr n xs = mconcat items + where + items = reverse $ zipWith f [(0::Int)..] (reverse xs) + offset 0 = fr + offset n = InfixExpr SubOp fr (toJExpr n) + f i ex = ex ||= IdxExpr stack (toJExpr (offset (i+n))) + +-- | Blindly pop N slots +popN :: Int -> G JStat +popN n = addUnknownSlots n >> adjSpN n + +-- | Generate statements to update the current node with a blackhole +bhStats :: StgToJSConfig -> Bool -> JStat +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" + , 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 = do + settings <- getSettings + -- update frame size + let adjPushStack :: Int -> G () + adjPushStack n = do modifyStackDepth (+n) + dropSlots n + adjPushStack 2 + 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' settings = + if csInlineBlackhole settings + then bhStats settings True + else ApplStat (var "h$bh") [] diff --git a/GHC/StgToJS/StaticPtr.hs b/GHC/StgToJS/StaticPtr.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/StaticPtr.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.StaticPtr + ( initStaticPtrs + ) +where + +import GHC.Prelude +import GHC.Linker.Types (SptEntry(..)) +import GHC.Fingerprint.Type +import GHC.Types.Literal + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.StgToJS.Types +import GHC.StgToJS.Literal +import GHC.StgToJS.Ids + +initStaticPtrs :: [SptEntry] -> G JStat +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] + diff --git a/GHC/StgToJS/StgUtils.hs b/GHC/StgToJS/StgUtils.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/StgUtils.hs @@ -0,0 +1,266 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Symbols.hs @@ -0,0 +1,89 @@ + +-- | JS symbol generation +module GHC.StgToJS.Symbols + ( moduleGlobalSymbol + , moduleExportsSymbol + , mkJsSymbol + , mkJsSymbolBS + , mkFreshJsSymbol + , mkRawSymbol + , intBS + ) where + +import GHC.Prelude + +import GHC.Data.FastString +import GHC.Unit.Module +import Data.ByteString (ByteString) +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 uniques. We could use base-62 as GHC usually does but this is likely +-- faster. +intBS :: Int -> ByteString +intBS = BSL.toStrict . BSB.toLazyByteString . BSB.wordHex . fromIntegral + +-- | 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 diff --git a/GHC/StgToJS/Types.hs b/GHC/StgToJS/Types.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Types.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StgToJS.Types +-- 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 holds the Types required for the StgToJS pass +----------------------------------------------------------------------------- + +module GHC.StgToJS.Types where + +import GHC.Prelude + +import GHC.JS.Syntax +import GHC.JS.Make +import GHC.JS.Ppr () + +import GHC.Stg.Syntax +import GHC.Core.TyCon + +import GHC.Types.Unique +import GHC.Types.Unique.FM +import GHC.Types.Var +import GHC.Types.ForeignCall + +import Control.Monad.Trans.State.Strict +import GHC.Utils.Outputable (Outputable (..), text, SDocContext, (<+>), ($$)) + +import GHC.Data.FastString +import GHC.Data.FastMutInt + +import GHC.Unit.Module + +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 + +-- | A State monad over IO holding the generator state. +type G = StateT GenState IO + +-- | The JS code generator state +data GenState = GenState + { gsSettings :: !StgToJSConfig -- ^ codegen settings, read-only + , gsModule :: !Module -- ^ current module + , gsId :: {-# UNPACK #-} !FastMutInt -- ^ unique number for the id generator + , 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) + } + +-- | The JS code generator state relevant for the current binding group +data GenGroupState = GenGroupState + { ggsToplevelStats :: [JStat] -- ^ 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 + , ggsStackDepth :: Int -- ^ current stack depth + , ggsExtraDeps :: Set OtherSymb -- ^ extra dependencies for the linkable unit that contains this group + , ggsGlobalIdCache :: GlobalIdCache + , ggsForeignRefs :: [ForeignJSRef] + } + +-- | The Configuration record for the StgToJS pass +data StgToJSConfig = StgToJSConfig + -- flags + { csInlinePush :: !Bool + , csInlineBlackhole :: !Bool + , csInlineLoadRegs :: !Bool + , csInlineEnter :: !Bool + , csInlineAlloc :: !Bool + , csTraceRts :: !Bool + , csAssertRts :: !Bool + , csBoundsCheck :: !Bool + , csDebugAlloc :: !Bool + , csTraceForeign :: !Bool + , csProf :: !Bool -- ^ Profiling enabled + , csRuntimeAssert :: !Bool -- ^ Enable runtime assertions + -- settings + , csContext :: !SDocContext + } + +-- | Information relevenat to code generation for closures. +data ClosureInfo = ClosureInfo + { ciVar :: Ident -- ^ object being infod + , 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) + +-- | 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 + } + deriving stock (Eq, Ord, Show, Generic) + +instance NFData CIRegs + +-- | Closure Information, 'ClosureInfo', layout +data CILayout + = CILayoutVariable -- ^ layout stored in object itself, first position from the start + | CILayoutUnknown -- ^ fixed size, but content unknown (for example stack apply frame) + { layoutSize :: !Int + } + | CILayoutFixed -- ^ whole layout known + { layoutSize :: !Int -- ^ closure size in array positions, including entry + , layout :: [VarType] -- ^ The set of sized Types to layout + } + deriving stock (Eq, Ord, Show, Generic) + +instance NFData CILayout + +-- | The type of 'ClosureInfo' +data CIType + = CIFun { citArity :: !Int -- ^ function arity + , citRegs :: !Int -- ^ number of registers for the args + } + | CIThunk -- ^ The closure is a THUNK + | CICon { citConstructor :: !Int } -- ^ The closure is a Constructor + | 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 + +-- | Static references that must be kept alive +newtype CIStatic = CIStaticRefs { staticRefs :: [FastString] } + deriving stock (Eq, Generic) + 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) + +-- | Free variable types +data VarType + = PtrV -- ^ pointer = reference to heap object (closure object) + | 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 + +instance ToJExpr VarType 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() }; +-- @ +-- 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() { +-- var h$$baseZCGHCziMaybezieta_8KXnScrCjF5 = h$r2; +-- h$r1 = h$c1(h$baseZCGHCziMaybeziJust_con_e, h$$baseZCGHCziMaybezieta_8KXnScrCjF5); +-- return h$rs(); +-- }; +-- @ +-- Which loads some payload from register 2, and applies the Constructor Entry +-- function for the Just to the payload, returns the result in register 1 and +-- returns whatever is on top of the stack +data IdType + = IdPlain -- ^ A plain identifier for values, no suffix added + | IdEntry -- ^ An entry function, suffix = "_e" in 'GHC.StgToJS.Ids.makeIdentForId' + | IdConEntry -- ^ A Constructor entry function, suffix = "_con_e" in 'GHC.StgToJS.Ids.makeIdentForId' + deriving (Enum, Eq, Ord) + +-- | Keys to differentiate Ident's in the ID Cache +data IdKey + = IdKey !Int !Int !IdType + deriving (Eq, Ord) + +-- | Some other symbol +data OtherSymb + = OtherSymb !Module !FastString + deriving Eq + +instance Ord OtherSymb where + compare (OtherSymb m1 t1) (OtherSymb m2 t2) + = stableModuleCmp m1 m2 <> lexicalCompareFS t1 t2 + +-- | The identifier cache indexed on 'IdKey' local to a module +newtype IdCache = IdCache (M.Map IdKey Ident) + +-- | The global Identifier Cache +newtype GlobalIdCache = GlobalIdCache (UniqFM Ident (IdKey, Id)) + +-- | A Stack Slot is either known or unknown. We avoid maybe here for more +-- strictness. +data StackSlot + = SlotId !Id !Int + | SlotUnknown + deriving (Eq, Ord) + +data StaticInfo = StaticInfo + { siVar :: !FastString -- ^ global object + , siVal :: !StaticVal -- ^ static initialization + , siCC :: !(Maybe Ident) -- ^ optional CCS name + } deriving stock (Eq, Show, Typeable, Generic) + +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 + -- ^ 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) + +data StaticUnboxed + = StaticUnboxedBool !Bool + | StaticUnboxedInt !Integer + | StaticUnboxedDouble !SaneDouble + | StaticUnboxedString !BS.ByteString + | StaticUnboxedStringOffset !BS.ByteString + deriving stock (Eq, Ord, Show, Generic) + +instance NFData StaticUnboxed + +-- | Static Arguments. Static Arguments are things that are statically +-- allocated, i.e., they exist at program startup. These are static heap objects +-- or literals or things that have been floated to the top level binding by ghc. +data StaticArg + = StaticObjArg !FastString -- ^ reference to a heap object + | StaticLitArg !StaticLit -- ^ literal + | StaticConArg !FastString [StaticArg] -- ^ unfloated constructor + deriving stock (Eq, Show, Generic) + +instance Outputable StaticArg where + ppr x = text (show x) + +-- | A Static literal value +data StaticLit + = BoolLit !Bool + | IntLit !Integer + | NullLit + | DoubleLit !SaneDouble -- should we actually use double here? + | StringLit !FastString + | BinLit !BS.ByteString + | LabelLit !Bool !FastString -- ^ is function pointer, label (also used for string / binary init) + deriving (Eq, Show, Generic) + +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 + +-- | A foreign reference to some JS code +data ForeignJSRef = ForeignJSRef + { foreignRefSrcSpan :: !FastString + , foreignRefPattern :: !FastString + , foreignRefSafety :: !Safety + , foreignRefCConv :: !CCallConv + , foreignRefArgs :: ![FastString] + , foreignRefResult :: !FastString + } deriving stock (Generic) + +-- | data used to generate one ObjUnit in our object file +data LinkableUnit = LinkableUnit + { luObjUnit :: ObjUnit -- ^ serializable unit info + , luIdExports :: [Id] -- ^ exported names from haskell identifiers + , luOtherExports :: [FastString] -- ^ other exports + , luIdDeps :: [Id] -- ^ identifiers this unit depends on + , luPseudoIdDeps :: [Unique] -- ^ pseudo-id identifiers this unit depends on (fixme) + , luOtherDeps :: [OtherSymb] -- ^ symbols not from a haskell id that this unit depends on + , luRequired :: Bool -- ^ always link this unit + , luForeignRefs :: [ForeignJSRef] + } + +-- | 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 ExpFun = ExpFun + { isIO :: !Bool + , args :: [JSFFIType] + , result :: !JSFFIType + } deriving (Eq, Ord, Show) + +-- | Types of FFI values +data JSFFIType + = Int8Type + | Int16Type + | Int32Type + | Int64Type + | Word8Type + | Word16Type + | Word32Type + | Word64Type + | DoubleType + | ByteArrayType + | PtrType + | RefType + deriving (Show, Ord, Eq, Enum) + + +-- | Typed expression +data TypedExpr = TypedExpr + { typex_typ :: !PrimRep + , typex_expr :: [JExpr] + } + +instance Outputable TypedExpr where + ppr x = text "TypedExpr: " <+> ppr (typex_expr x) + $$ text "PrimReps: " <+> ppr (typex_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 + +data ExprResult + = ExprCont + | ExprInline (Maybe [JExpr]) + deriving (Eq) + +newtype ExprValData = ExprValData [JExpr] + deriving newtype (Eq) + +-- | A Closure is one of six types +data ClosureType + = Thunk -- ^ The closure is a THUNK + | Fun -- ^ The closure is a Function + | Pap -- ^ The closure is a Partial Application + | 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) + +-- | Convert 'ClosureType' to an Int +ctNum :: ClosureType -> Int +ctNum Fun = 1 +ctNum Con = 2 +ctNum Thunk = 0 +ctNum Pap = 3 +ctNum Blackhole = 5 +ctNum StackFrame = -1 + +-- | Convert 'ClosureType' to a String +ctJsName :: ClosureType -> String +ctJsName = \case + Thunk -> "CLOSURE_TYPE_THUNK" + Fun -> "CLOSURE_TYPE_FUN" + Pap -> "CLOSURE_TYPE_PAP" + Con -> "CLOSURE_TYPE_CON" + Blackhole -> "CLOSURE_TYPE_BLACKHOLE" + StackFrame -> "CLOSURE_TYPE_STACKFRAME" + +instance ToJExpr ClosureType where + toJExpr e = toJExpr (ctNum e) + + +-- | A thread is in one of 4 states +data ThreadStatus + = Running -- ^ The thread is running + | Blocked -- ^ The thread is blocked + | Finished -- ^ The thread is done + | Died -- ^ The thread has died + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | Convert the status of a thread in JS land to an Int +threadStatusNum :: ThreadStatus -> Int +threadStatusNum = \case + Running -> 0 + Blocked -> 1 + Finished -> 16 + Died -> 17 + +-- | convert the status of a thread in JS land to a string +threadStatusJsName :: ThreadStatus -> String +threadStatusJsName = \case + Running -> "THREAD_RUNNING" + Blocked -> "THREAD_BLOCKED" + Finished -> "THREAD_FINISHED" + Died -> "THREAD_DIED" diff --git a/GHC/StgToJS/Utils.hs b/GHC/StgToJS/Utils.hs new file mode 100644 --- /dev/null +++ b/GHC/StgToJS/Utils.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHC.StgToJS.Utils + ( assignToTypedExprs + , assignCoerce1 + , assignToExprCtx + ) +where + +import GHC.Prelude + +import GHC.StgToJS.Types +import GHC.StgToJS.ExprCtx + +import GHC.JS.Syntax +import GHC.JS.Make + +import GHC.Core.TyCon + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable + +assignToTypedExprs :: HasDebugCallStack => [TypedExpr] -> [JExpr] -> JStat +assignToTypedExprs tes es = + assignAllEqual (concatMap typex_expr tes) es + +assignTypedExprs :: [TypedExpr] -> [TypedExpr] -> JStat +assignTypedExprs tes es = + -- TODO: check primRep (typex_typ) here? + assignToTypedExprs tes (concatMap typex_expr es) + +assignToExprCtx :: HasDebugCallStack => ExprCtx -> [JExpr] -> JStat +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 [x] [y] = assignCoerce x y +assignCoerce1 [] [] = mempty +assignCoerce1 x y = pprPanic "assignCoerce1" + (vcat [ text "lengths do not match" + , ppr x + , ppr y + ]) + +-- | Assign p2 to p1 with optional coercion +assignCoerce :: TypedExpr -> TypedExpr -> JStat +-- Coercion between StablePtr# and Addr# +assignCoerce (TypedExpr AddrRep [a_val, a_off]) (TypedExpr UnliftedRep [sptr]) = mconcat + [ a_val |= var "h$stablePtrBuf" + , a_off |= sptr + ] +assignCoerce (TypedExpr UnliftedRep [sptr]) (TypedExpr AddrRep [_a_val, a_off]) = + sptr |= a_off +assignCoerce p1 p2 = assignTypedExprs [p1] [p2] + diff --git a/GHC/SysTools.hs b/GHC/SysTools.hs --- a/GHC/SysTools.hs +++ b/GHC/SysTools.hs @@ -14,7 +14,6 @@ module GHC.SysTools ( -- * Initialisation initSysTools, - lazyInitLlvmConfig, -- * Interface to system tools module GHC.SysTools.Tasks, @@ -32,7 +31,6 @@ import GHC.Prelude -import GHC.Settings.Utils import GHC.Utils.Panic import GHC.Driver.Session @@ -44,9 +42,7 @@ import GHC.Settings.IO import Control.Monad.Trans.Except (runExceptT) -import System.FilePath import System.IO -import System.IO.Unsafe (unsafeInterleaveIO) import Foreign.Marshal.Alloc (allocaBytes) import System.Directory (copyFile) @@ -101,47 +97,6 @@ * * ************************************************************************ -} - --- Note [LLVM configuration] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain --- information needed by the LLVM backend to invoke `llc` and `opt`. --- Specifically: --- --- * llvm-targets maps autoconf host triples to the corresponding LLVM --- `data-layout` declarations. This information is extracted from clang using --- the script in utils/llvm-targets/gen-data-layout.sh and should be updated --- whenever we target a new version of LLVM. --- --- * llvm-passes maps GHC optimization levels to sets of LLVM optimization --- flags that GHC should pass to `opt`. --- --- This information is contained in files rather the GHC source to allow users --- to add new targets to GHC without having to recompile the compiler. --- --- Since this information is only needed by the LLVM backend we load it lazily --- with unsafeInterleaveIO. Consequently it is important that we lazily pattern --- match on LlvmConfig until we actually need its contents. - -lazyInitLlvmConfig :: String - -> IO LlvmConfig -lazyInitLlvmConfig top_dir - = unsafeInterleaveIO $ do -- see Note [LLVM configuration] - targets <- readAndParse "llvm-targets" - passes <- readAndParse "llvm-passes" - return $ LlvmConfig { llvmTargets = fmap mkLlvmTarget <$> targets, - llvmPasses = passes } - where - readAndParse :: Read a => String -> IO a - readAndParse name = - do let llvmConfigFile = top_dir name - llvmConfigStr <- readFile llvmConfigFile - case maybeReadFuzzy llvmConfigStr of - Just s -> return s - Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile) - - mkLlvmTarget :: (String, String, String) -> LlvmTarget - mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs) initSysTools :: String -- TopDir path diff --git a/GHC/SysTools/Ar.hs b/GHC/SysTools/Ar.hs --- a/GHC/SysTools/Ar.hs +++ b/GHC/SysTools/Ar.hs @@ -1,19 +1,20 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} -{- Note: [The need for Ar.hs] -Building `-staticlib` required the presence of libtool, and was a such -restricted to mach-o only. As libtool on macOS and gnu libtool are very +{- Note [The need for Ar.hs] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +Building `-staticlib` previously required the presence of libtool, and was a +such restricted to mach-o only. As libtool on macOS and gnu libtool are very different, there was no simple portable way to support this. -libtool for static archives does essentially: concatinate the input archives, +libtool for static archives does essentially: concatenate the input archives, add the input objects, and create a symbol index. Using `ar` for this task fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same features across platforms (e.g. index prefixed retrieval of objects with the same name.) -As Archives are rather simple structurally, we can just build the archives +As archives are rather simple structurally, we can just build the archives with Haskell directly and use ranlib on the final result to get the symbol -index. This should allow us to work around with the differences/abailability +index. This should allow us to work around with the differences/availability of libtool across different platforms. -} module GHC.SysTools.Ar @@ -143,7 +144,7 @@ if C.unpack (C.take 1 name) == "/" then case C.takeWhile (/= ' ') name of name@"/" -> name -- symbol table - name@"//" -> name -- extendedn file names table + name@"//" -> name -- extended file names table name -> getExtName extInfo (read . C.unpack $ C.drop 1 name) else C.takeWhile (/= '/') name case name of @@ -157,7 +158,7 @@ getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info -- | put an Archive Entry. This assumes that the entries --- have been preprocessed to account for the extenden file name +-- have been preprocessed to account for the extended file name -- table section "//" e.g. for GNU Archives. Or that the names -- have been move into the payload for BSD Archives. putArchEntry :: ArchiveEntry -> PutM () diff --git a/GHC/SysTools/BaseDir.hs b/GHC/SysTools/BaseDir.hs --- a/GHC/SysTools/BaseDir.hs +++ b/GHC/SysTools/BaseDir.hs @@ -55,13 +55,10 @@ Note [tooldir: How GHC finds mingw on Windows] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC has some custom logic on Windows for finding the mingw -toolchain and perl. Depending on whether GHC is built -with the make build system or Hadrian, and on whether we're -running a bindist, we might find the mingw toolchain -either under $topdir/../{mingw, perl}/ or -$topdir/../../{mingw, perl}/. +toolchain. In general we will find the mingw toolchain +in $topdir/../../mingw/. -This story is long and with lots of twist and turns.. But lets talk about how +This story is long and with lots of twist and turns.. But let's talk about how the build system finds and wires through the toolchain information. 1) It all starts in configure.ac which has two modes it operates on: @@ -90,25 +87,11 @@ From `aclocal.m4` we export a couple of variables starting with `Settings` which will be used to generate the settings file. -3) The next step is to generate the settings file, this is where things diverge - based on the build system. Both Make and Hadrian handle this differently: - -make) - Make deals with this rather simply. As an output of configure.ac - `config.mk.in` is processed and `config.mk` generated which has the values we - set in `aclocal.m4`. This allows the rest of the build system to have access - to these and other values determined by configure. - - Based on this file, `rts/include/ghc.mk` when ran will produce the settings file - by echoing the values into a the final file. Coincidentally this is also - where `ghcplatform.h` and `ghcversion.h` generated which contains information - about the build platform and sets CPP for use by the entire build. - -hadrian) - For hadrian the file `cfg/system.config.in` is preprocessed by configure and - the output written to `system.config`. This serves the same purpose as - `config.mk` but it rewrites the values that were exported. As an example - `SettingsCCompilerCommand` is rewritten to `settings-c-compiler-command`. +3) The next step is to generate the settings file: The file + `cfg/system.config.in` is preprocessed by configure and the output written to + `system.config`. This serves the same purpose as `config.mk` but it rewrites + the values that were exported. As an example `SettingsCCompilerCommand` is + rewritten to `settings-c-compiler-command`. Next up is `src/Oracles/Settings.hs` which makes from some Haskell ADT to the settings `keys` in the `system.config`. As an example, @@ -139,7 +122,7 @@ -- | Expand occurrences of the @$tooldir@ interpolation in a string -- on Windows, leave the string untouched otherwise. expandToolDir - :: Bool -- ^ whether we are use the ambiant mingw toolchain + :: Bool -- ^ whether we use the ambient mingw toolchain -> Maybe FilePath -- ^ tooldir -> String -> String #if defined(mingw32_HOST_OS) @@ -183,7 +166,7 @@ -- tooldir can't be located, or returns @Just tooldirpath@. -- If the distro toolchain is being used we treat Windows the same as Linux findToolDir - :: Bool -- ^ whether we are use the ambiant mingw toolchain + :: Bool -- ^ whether we use the ambient mingw toolchain -> FilePath -- ^ topdir -> IO (Maybe FilePath) #if defined(mingw32_HOST_OS) diff --git a/GHC/SysTools/Cpp.hs b/GHC/SysTools/Cpp.hs new file mode 100644 --- /dev/null +++ b/GHC/SysTools/Cpp.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +#include + +module GHC.SysTools.Cpp + ( doCpp + , CppOpts (..) + , getGhcVersionPathName + , applyCDefs + , offsetIncludePaths + ) +where + +import GHC.Prelude +import GHC.Driver.Session +import GHC.Driver.Backend +import GHC.CmmToLlvm.Config +import GHC.Platform +import GHC.Platform.ArchOS + +import GHC.SysTools + +import GHC.Unit.Env +import GHC.Unit.Info +import GHC.Unit.State +import GHC.Unit.Types + +import GHC.Utils.Logger +import GHC.Utils.TmpFs +import GHC.Utils.Panic + +import Data.Version +import Data.List (intercalate) +import Data.Maybe + +import Control.Monad + +import System.Directory +import System.FilePath + +data CppOpts = CppOpts + { cppUseCc :: !Bool -- ^ Use "cc -E" as preprocessor, otherwise use "cpp" + , cppLinePragmas :: !Bool -- ^ Enable generation of LINE pragmas + } + +-- | Run CPP +-- +-- UnitEnv is needed to compute MIN_VERSION macros +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 + pkg_include_dirs <- mayThrowUnitErr + (collectIncludeDirs <$> preloadUnitsInfo unit_env) + -- MP: This is not quite right, the headers which are supposed to be installed in + -- the package might not be the same as the provided include paths, but it's a close + -- enough approximation for things to work. A proper solution would be to have to declare which paths should + -- be propagated to dependent packages. + let home_pkg_deps = + [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) [] + (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs + ++ concatMap includePathsGlobal dep_pkg_extra_inputs) + let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) [] + (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 platform = targetPlatform dflags + targetArch = stringEncodeArch $ platformArch platform + targetOS = stringEncodeOS $ platformOS platform + isWindows = platformOS platform == OSMinGW32 + let target_defs = + [ "-D" ++ HOST_OS ++ "_BUILD_OS", + "-D" ++ HOST_ARCH ++ "_BUILD_ARCH", + "-D" ++ targetOS ++ "_HOST_OS", + "-D" ++ targetArch ++ "_HOST_ARCH" ] + -- remember, in code we *compile*, the HOST is the same our TARGET, + -- and BUILD is the same as our HOST. + + let io_manager_defs = + [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++ + [ "-D__IO_MANAGER_MIO__=1" ] + + let sse_defs = + [ "-D__SSE__" | isSseEnabled platform ] ++ + [ "-D__SSE2__" | isSse2Enabled platform ] ++ + [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] + + let avx_defs = + [ "-D__AVX__" | isAvxEnabled dflags ] ++ + [ "-D__AVX2__" | isAvx2Enabled dflags ] ++ + [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++ + [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++ + [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ + [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] + + backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags + + let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] + -- Default CPP defines in Haskell source + ghcVersionH <- getGhcVersionPathName dflags unit_env + let hsSourceCppOpts = [ "-include", ghcVersionH ] + + -- MIN_VERSION macros + let uids = explicitUnits unit_state + pkgs = mapMaybe (lookupUnit unit_state . fst) uids + mb_macro_include <- + if not (null pkgs) && gopt Opt_VersionMacros dflags + then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h" + writeFile macro_stub (generatePackageVersionMacros pkgs) + -- Include version macros for every *exposed* package. + -- Without -hide-all-packages and with a package database + -- size of 1000 packages, it takes cpp an estimated 2 + -- milliseconds to process this file. See #10970 + -- comment 8. + return [GHC.SysTools.FileOption "-include" macro_stub] + else return [] + + let line_pragmas + | cppLinePragmas opts = [] -- on by default + | otherwise = [GHC.SysTools.Option "-P"] -- disable LINE markers + + cpp_prog ( map GHC.SysTools.Option verbFlags + ++ map GHC.SysTools.Option include_paths + ++ map GHC.SysTools.Option hsSourceCppOpts + ++ map GHC.SysTools.Option target_defs + ++ map GHC.SysTools.Option backend_defs + ++ map GHC.SysTools.Option th_defs + ++ map GHC.SysTools.Option hscpp_opts + ++ map GHC.SysTools.Option sse_defs + ++ map GHC.SysTools.Option avx_defs + ++ map GHC.SysTools.Option io_manager_defs + ++ mb_macro_include + ++ line_pragmas + -- Set the language mode to assembler-with-cpp when preprocessing. This + -- alleviates some of the C99 macro rules relating to whitespace and the hash + -- operator, which we tend to abuse. Clang in particular is not very happy + -- about this. + ++ [ GHC.SysTools.Option "-x" + , GHC.SysTools.Option "assembler-with-cpp" + , GHC.SysTools.Option input_fn + -- We hackily use Option instead of FileOption here, so that the file + -- name is not back-slashed on Windows. cpp is capable of + -- dealing with / in filenames, so it works fine. Furthermore + -- if we put in backslashes, cpp outputs #line directives + -- with *double* backslashes. And that in turn means that + -- our error messages get double backslashes in them. + -- In due course we should arrange that the lexer deals + -- with these \\ escapes properly. + , GHC.SysTools.Option "-o" + , GHC.SysTools.FileOption "" output_fn + ]) + +-- --------------------------------------------------------------------------- +-- Macros (cribbed from Cabal) + +generatePackageVersionMacros :: [UnitInfo] -> String +generatePackageVersionMacros pkgs = concat + -- Do not add any C-style comments. See #3389. + [ generateMacros "" pkgname version + | pkg <- pkgs + , let version = unitPackageVersion pkg + pkgname = map fixchar (unitPackageNameString pkg) + ] + +fixchar :: Char -> Char +fixchar '-' = '_' +fixchar c = c + +generateMacros :: String -> String -> Version -> String +generateMacros prefix name version = + concat + ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n" + ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + where + take3 = \case + (a:b:c:_) -> (a,b,c) + _ -> error "take3" + (major1,major2,minor) = take3 $ map show (versionBranch version) ++ repeat "0" + + +-- | Find out path to @ghcversion.h@ file +getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath +getGhcVersionPathName dflags unit_env = do + candidates <- case ghcVersionFile dflags of + Just path -> return [path] + Nothing -> do + ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId]) + return (( "ghcversion.h") <$> collectIncludeDirs ps) + + found <- filterM doesFileExist candidates + case found of + [] -> throwGhcExceptionIO (InstallationError + ("ghcversion.h missing; tried: " + ++ intercalate ", " candidates)) + (x:_) -> return x + +applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String] +applyCDefs NoCDefs _ _ = return [] +applyCDefs LlvmCDefs logger dflags = do + llvmVer <- figureLlvmVersion logger dflags + return $ case fmap llvmVersionList llvmVer of + Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] + Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] + _ -> [] + where + format (major, minor) + | minor >= 100 = error "backendCDefs: Unsupported minor version" + | otherwise = show (100 * major + minor :: Int) -- Contract is Int + + +-- Note [Filepaths and Multiple Home Units] +offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs +offsetIncludePaths dflags (IncludeSpecs incs quotes impl) = + let go = map (augmentByWorkingDirectory dflags) + in IncludeSpecs (go incs) (go quotes) (go impl) diff --git a/GHC/SysTools/Elf.hs b/GHC/SysTools/Elf.hs --- a/GHC/SysTools/Elf.hs +++ b/GHC/SysTools/Elf.hs @@ -70,7 +70,7 @@ same thing applies to the field containing the number of segments, but we don't care about it here). - ELF-next: to solve this, theses fields in the ELF header have an escape + ELF-next: to solve this, these fields in the ELF header have an escape value (different for each case), and the actual section number is stashed into unused fields in the first section header. diff --git a/GHC/SysTools/Info.hs b/GHC/SysTools/Info.hs --- a/GHC/SysTools/Info.hs +++ b/GHC/SysTools/Info.hs @@ -113,7 +113,7 @@ | any (\line -> "LLD" `isPrefixOf` line || "LLD" `elem` words line) stdo = return (LlvmLLD $ map Option [ --see Note [ELF needed shared libs] - "-Wl,--no-as-needed"]) + "-Wl,--no-as-needed" | osElfTarget os || os == OSMinGW32 ]) -- Unknown linker. | otherwise = fail "invalid --version output, or linker is unsupported" diff --git a/GHC/SysTools/Tasks.hs b/GHC/SysTools/Tasks.hs --- a/GHC/SysTools/Tasks.hs +++ b/GHC/SysTools/Tasks.hs @@ -14,9 +14,10 @@ import GHC.ForeignSrcLang import GHC.IO (catchException) -import GHC.CmmToLlvm.Base (llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound) -import GHC.CmmToLlvm.Config (LlvmVersion) +import GHC.CmmToLlvm.Config (LlvmVersion, llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound) +import GHC.Settings + import GHC.SysTools.Process import GHC.SysTools.Info @@ -45,7 +46,7 @@ -} runUnlit :: Logger -> DynFlags -> [Option] -> IO () -runUnlit logger dflags args = traceToolCommand logger "unlit" $ do +runUnlit logger dflags args = traceSystoolCommand logger "unlit" $ do let prog = pgm_L dflags opts = getOpts dflags opt_L runSomething logger "Literate pre-processor" prog @@ -61,7 +62,7 @@ augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps) runCpp :: Logger -> DynFlags -> [Option] -> IO () -runCpp logger dflags args = traceToolCommand logger "cpp" $ do +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 @@ -73,14 +74,14 @@ (args0 ++ args1 ++ args2 ++ args) Nothing mb_env runPp :: Logger -> DynFlags -> [Option] -> IO () -runPp logger dflags args = traceToolCommand logger "pp" $ do +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 = traceToolCommand logger "cc" $ do +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 @@ -160,6 +161,10 @@ ,pgm_c dflags, "Asm Compiler") RawObject -> ("c", [] ,pgm_c dflags, "C Compiler") -- claim C for lack of a better idea + --JS backend shouldn't reach here, so we just pass + -- strings to satisfy the totality checker + LangJs -> ("js", [] + ,pgm_c dflags, "JS Backend Compiler") userOpts_c = getOpts dflags opt_c userOpts_cxx = getOpts dflags opt_cxx @@ -168,7 +173,7 @@ -- | Run the linker with some arguments and return the output askLd :: Logger -> DynFlags -> [Option] -> IO String -askLd logger dflags args = traceToolCommand logger "linker" $ do +askLd logger dflags args = traceSystoolCommand logger "linker" $ do let (p,args0) = pgm_l dflags args1 = map Option (getOpts dflags opt_l) args2 = args0 ++ args1 ++ args @@ -177,7 +182,7 @@ readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } runAs :: Logger -> DynFlags -> [Option] -> IO () -runAs logger dflags args = traceToolCommand logger "as" $ do +runAs logger dflags args = traceSystoolCommand logger "as" $ do let (p,args0) = pgm_a dflags args1 = map Option (getOpts dflags opt_a) args2 = args0 ++ args1 ++ args @@ -186,7 +191,7 @@ -- | Run the LLVM Optimiser runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO () -runLlvmOpt logger dflags args = traceToolCommand logger "opt" $ do +runLlvmOpt logger dflags args = traceSystoolCommand logger "opt" $ do let (p,args0) = pgm_lo dflags args1 = map Option (getOpts dflags opt_lo) -- We take care to pass -optlo flags (e.g. args0) last to ensure that the @@ -195,7 +200,7 @@ -- | Run the LLVM Compiler runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO () -runLlvmLlc logger dflags args = traceToolCommand logger "llc" $ do +runLlvmLlc logger dflags args = traceSystoolCommand logger "llc" $ do let (p,args0) = pgm_lc dflags args1 = map Option (getOpts dflags opt_lc) runSomething logger "LLVM Compiler" p (args0 ++ args1 ++ args) @@ -204,7 +209,7 @@ -- backend on OS X as LLVM doesn't support the OS X system -- assembler) runClang :: Logger -> DynFlags -> [Option] -> IO () -runClang logger dflags args = traceToolCommand logger "clang" $ do +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. @@ -222,9 +227,15 @@ throwIO err ) +runEmscripten :: Logger -> DynFlags -> [Option] -> IO () +runEmscripten logger dflags args = traceSystoolCommand logger "emcc" $ do + let (p,args0) = pgm_a dflags + args1 = args0 ++ args + runSomething logger "Emscripten" p args1 + -- | Figure out which version of LLVM we are running this session figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion) -figureLlvmVersion logger dflags = traceToolCommand logger "llc" $ do +figureLlvmVersion logger dflags = traceSystoolCommand logger "llc" $ do let (pgm,opts) = pgm_lc dflags args = filter notNull (map showOpt opts) -- we grab the args even though they should be useless just in @@ -267,7 +278,7 @@ runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () -runLink logger tmpfs dflags args = traceToolCommand logger "linker" $ do +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 @@ -332,7 +343,7 @@ -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () runMergeObjects logger tmpfs dflags args = - traceToolCommand logger "merge-objects" $ do + traceSystoolCommand logger "merge-objects" $ do let (p,args0) = fromMaybe err (pgm_lm dflags) err = throwGhcException $ UsageError $ unwords [ "Attempted to merge object files but the configured linker" @@ -348,38 +359,29 @@ else do runSomething logger "Merge objects" p args2 -runLibtool :: Logger -> DynFlags -> [Option] -> IO () -runLibtool logger dflags args = traceToolCommand logger "libtool" $ do - linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags - let args1 = map Option (getOpts dflags opt_l) - args2 = [Option "-static"] ++ args1 ++ args ++ linkargs - libtool = pgm_libtool dflags - mb_env <- getGccEnv args2 - runSomethingFiltered logger id "Libtool" libtool args2 Nothing mb_env - runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO () -runAr logger dflags cwd args = traceToolCommand logger "ar" $ do +runAr logger dflags cwd args = traceSystoolCommand logger "ar" $ do let ar = pgm_ar dflags runSomethingFiltered logger id "Ar" ar args cwd Nothing -askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String -askOtool logger dflags mb_cwd args = do - let otool = pgm_otool dflags +askOtool :: Logger -> ToolSettings -> Maybe FilePath -> [Option] -> IO String +askOtool logger toolSettings mb_cwd args = do + let otool = toolSettings_pgm_otool toolSettings runSomethingWith logger "otool" otool args $ \real_args -> readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd } -runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO () -runInstallNameTool logger dflags args = do - let tool = pgm_install_name_tool dflags +runInstallNameTool :: Logger -> ToolSettings -> [Option] -> IO () +runInstallNameTool logger toolSettings args = do + let tool = toolSettings_pgm_install_name_tool toolSettings runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing runRanlib :: Logger -> DynFlags -> [Option] -> IO () -runRanlib logger dflags args = traceToolCommand logger "ranlib" $ do +runRanlib logger dflags args = traceSystoolCommand logger "ranlib" $ do let ranlib = pgm_ranlib dflags runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing runWindres :: Logger -> DynFlags -> [Option] -> IO () -runWindres logger dflags args = traceToolCommand logger "windres" $ do +runWindres logger dflags args = traceSystoolCommand logger "windres" $ do let cc_args = map Option (sOpt_c (settings dflags)) windres = pgm_windres dflags opts = map Option (getOpts dflags opt_windres) @@ -387,17 +389,5 @@ runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env touch :: Logger -> DynFlags -> String -> String -> IO () -touch logger dflags purpose arg = traceToolCommand logger "touch" $ +touch logger dflags purpose arg = traceSystoolCommand logger "touch" $ runSomething logger purpose (pgm_T dflags) [FileOption "" arg] - --- * Tracing utility - --- | Record in the eventlog when the given tool command starts --- and finishes, prepending the given 'String' with --- \"systool:\", to easily be able to collect and process --- all the systool events. --- --- For those events to show up in the eventlog, you need --- to run GHC with @-v2@ or @-ddump-timings@. -traceToolCommand :: Logger -> String -> IO a -> IO a -traceToolCommand logger tool = withTiming logger (text "systool:" <> text tool) (const ()) diff --git a/GHC/SysTools/Terminal.hs b/GHC/SysTools/Terminal.hs --- a/GHC/SysTools/Terminal.hs +++ b/GHC/SysTools/Terminal.hs @@ -4,16 +4,12 @@ import GHC.Prelude -#if defined(MIN_VERSION_terminfo) -import GHC.IO (catchException) -import Data.Maybe (fromMaybe) -import System.Console.Terminfo (SetupTermError, Terminal, getCapability, - setupTermFromEnv, termColors) -import System.Posix (queryTerminal, stdError) -#elif defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) +import System.Environment (lookupEnv) +import System.IO (hIsTerminalDevice, stderr) +#else import GHC.IO (catchException) import GHC.Utils.Exception (try) --- import Data.Bits ((.|.), (.&.)) import Foreign (Ptr, peek, with) import qualified Graphics.Win32 as Win32 import qualified System.Win32 as Win32 @@ -40,18 +36,12 @@ -- | Check if ANSI escape sequences can be used to control color in stderr. stderrSupportsAnsiColors' :: IO Bool stderrSupportsAnsiColors' = do -#if defined(MIN_VERSION_terminfo) - stderr_available <- queryTerminal stdError - if stderr_available then - fmap termSupportsColors setupTermFromEnv - `catchException` \ (_ :: SetupTermError) -> pure False - else - pure False - where - termSupportsColors :: Terminal -> Bool - termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0 - -#elif defined(mingw32_HOST_OS) +#if !defined(mingw32_HOST_OS) + -- Equivalent of https://hackage.haskell.org/package/ansi-terminal/docs/System-Console-ANSI.html#v:hSupportsANSI + isTerminal <- hIsTerminalDevice stderr + term <- lookupEnv "TERM" + pure $ isTerminal && term /= Just "dumb" +#else h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE `catchException` \ (_ :: IOError) -> pure Win32.nullHANDLE @@ -100,6 +90,4 @@ foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL -#else - pure False #endif diff --git a/GHC/Tc/Deriv.hs b/GHC/Tc/Deriv.hs --- a/GHC/Tc/Deriv.hs +++ b/GHC/Tc/Deriv.hs @@ -28,7 +28,7 @@ import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault ) import GHC.Tc.Utils.Env import GHC.Tc.Deriv.Generate -import GHC.Tc.Validity( allDistinctTyVars, checkValidInstHead ) +import GHC.Tc.Validity( checkValidInstHead ) import GHC.Core.InstEnv import GHC.Tc.Utils.Instantiate import GHC.Core.FamInstEnv @@ -201,7 +201,6 @@ ; famInsts2 <- concatMapM genFamInsts infer_specs ; let famInsts = famInsts1 ++ famInsts2 - ; dflags <- getDynFlags ; logger <- getLogger -- We must put all the derived type family instances (from both @@ -229,7 +228,7 @@ ; let (_, aux_specs, fvs) = unzip3 (given_inst_binds ++ infer_inst_binds) ; loc <- getSrcSpanM - ; let aux_binds = genAuxBinds dflags loc (unionManyBags aux_specs) + ; let aux_binds = genAuxBinds loc (unionManyBags aux_specs) ; let infer_inst_infos = map fstOf3 infer_inst_binds ; let inst_infos = given_inst_infos ++ infer_inst_infos @@ -289,8 +288,8 @@ -- Bring the extra deriving stuff into scope -- before renaming the instances themselves ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)) - ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds - ; let aux_val_binds = ValBinds NoAnnSortKey aux_binds (bagToList aux_sigs) + ; let (aux_binds, aux_sigs) = unzipBag bagBinds + aux_val_binds = ValBinds NoAnnSortKey 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. @@ -636,8 +635,8 @@ -- is the case. | Just inst_ty <- lastMaybe inst_tys -> do - let via_kind = tcTypeKind via_ty - inst_ty_kind = tcTypeKind inst_ty + let via_kind = typeKind via_ty + inst_ty_kind = typeKind inst_ty mb_match = tcUnifyTy inst_ty_kind via_kind checkTc (isJust mb_match) @@ -645,9 +644,9 @@ DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind) let Just kind_subst = mb_match - ki_subst_range = getTCvSubstRangeFVs kind_subst + ki_subst_range = getSubstRangeTyCoFVs kind_subst -- See Note [Unification of two kind variables in deriving] - unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst + unmapped_tkvs = filter (\v -> v `notElemSubst` kind_subst && not (v `elemVarSet` ki_subst_range)) tvs (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs @@ -748,7 +747,7 @@ -- See Note [tc_args and tycon arity] (tc_args_to_keep, args_to_drop) = splitAt n_args_to_keep tc_args - inst_ty_kind = tcTypeKind (mkTyConApp tc tc_args_to_keep) + inst_ty_kind = typeKind (mkTyConApp tc tc_args_to_keep) -- Match up the kinds, and apply the resulting kind substitution -- to the types. See Note [Unify kinds in deriving] @@ -757,6 +756,12 @@ enough_args = n_args_to_keep >= 0 -- Check that the result really is well-kinded + ; traceTc "deriveTyData" $ + vcat [ text "class:" <+> ppr cls <+> dcolon <+> ppr (tyConKind (classTyCon cls)) + , text "cls_tys:" <+> ppr cls_tys + , 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) @@ -769,9 +774,9 @@ propagate_subst kind_subst tkvs' cls_tys' tc_args' mb_deriv_strat' = (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) where - ki_subst_range = getTCvSubstRangeFVs kind_subst + ki_subst_range = getSubstRangeTyCoFVs kind_subst -- See Note [Unification of two kind variables in deriving] - unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst + unmapped_tkvs = filter (\v -> v `notElemSubst` kind_subst && not (v `elemVarSet` ki_subst_range)) tkvs' (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs @@ -798,9 +803,9 @@ -- Perform an additional unification with the kind of the `via` -- type and the result of the previous kind unification. Just (ViaStrategy via_ty) -> do - let via_kind = tcTypeKind via_ty + let via_kind = typeKind via_ty inst_ty_kind - = tcTypeKind (mkTyConApp tc tc_args') + = typeKind (mkTyConApp tc tc_args') via_match = tcUnifyTy inst_ty_kind via_kind checkTc (isJust via_match) @@ -1008,7 +1013,7 @@ We used to accomplish this by doing the following: - unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs + unmapped_tkvs = filter (`notElemSubst` kind_subst) all_tkvs (subst, _) = substTyVarBndrs kind_subst unmapped_tkvs Where all_tkvs contains all kind variables in the class and instance types (in @@ -1024,9 +1029,9 @@ To prevent this, we need to filter out any variable from all_tkvs which either -1. Appears in the domain of kind_subst. notElemTCvSubst checks this. +1. Appears in the domain of kind_subst. notElemSubst checks this. 2. Appears in the range of kind_subst. To do this, we compute the free - variable set of the range of kind_subst with getTCvSubstRangeFVs, and check + variable set of the range of kind_subst with getSubstRangeTyCoFVs, and check if a kind variable appears in that set. Note [Eta-reducing type synonyms] @@ -1632,7 +1637,7 @@ newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad ) Remember, too, that type families are currently (conservatively) given a recursive flag, so this also allows newtype deriving to work -for type famillies. +for type families. We used to exclude recursive types, because we had a rather simple minded way of generating the instance decl: @@ -1920,13 +1925,13 @@ -- See Note [DeriveAnyClass and default family instances] DerivSpecAnyClass -> do let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) - mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env + mini_subst = mkTvSubst (mkInScopeSetList tyvars) mini_env dflags <- getDynFlags tyfam_insts <- -- canDeriveAnyClass should ensure that this code can't be reached -- unless -XDeriveAnyClass is enabled. assertPpr (xopt LangExt.DeriveAnyClass dflags) - (ppr "genFamInsts: bad derived class" <+> ppr clas) $ + (text "genFamInsts: bad derived class" <+> ppr clas) $ mapM (tcATDefault loc mini_subst emptyNameSet) (classATItems clas) pure $ concat tyfam_insts 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 @@ -505,11 +505,11 @@ -> Type -> (a, Bool) -- (result of type a, does type contain var) - go co ty | Just ty' <- tcView ty = go co ty' + go co ty | Just ty' <- coreView ty = go co ty' go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True) go co (FunTy { ft_arg = x, ft_res = y, ft_af = af }) - | InvisArg <- af = go co y - | xc || yc = (caseFun xr yr,True) + | isInvisibleFunArg af = go co y + | xc || yc = (caseFun xr yr,True) where (xr,xc) = go (not co) x (yr,yc) = go co y go co (AppTy x y) | xc = (caseWrongArg, True) @@ -532,8 +532,8 @@ -- actually needs. See #12399 (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args)) go co (ForAllTy (Bndr v vis) x) - | isVisibleArgFlag vis = panic "unexpected visible binder" - | v /= var && xc = (caseForAll v xr,True) + | isVisibleForAllTyFlag vis = panic "unexpected visible binder" + | v /= var && xc = (caseForAll v xr,True) where (xr,xc) = go co x go _ _ = (caseTrivial,False) 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 @@ -45,8 +45,8 @@ import GHC.Prelude import GHC.Tc.Utils.Monad -import GHC.Tc.TyCl.Class ( substATBndrs ) import GHC.Hs +import GHC.Types.FieldLabel import GHC.Types.Name.Reader import GHC.Types.Basic import GHC.Types.Fixity @@ -54,7 +54,6 @@ import GHC.Types.Name import GHC.Types.SourceText -import GHC.Driver.Session import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv import GHC.Builtin.Names @@ -73,8 +72,8 @@ import GHC.Builtin.Types import GHC.Core.Type import GHC.Core.Class + import GHC.Types.Unique.FM ( lookupUFM, listToUFM ) -import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Utils.Misc import GHC.Types.Var @@ -86,6 +85,8 @@ import GHC.Data.Pair import GHC.Data.Bag +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + import Data.List ( find, partition, intersperse ) import GHC.Data.Maybe ( expectJust ) import GHC.Unit.Module @@ -451,7 +452,7 @@ = nlHsCase (nlHsVar a_RDR) $ map (mkOrdOpAlt op) tycon_data_cons -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y... - -- C2 x -> case b of C2 x -> ....comopare x.... } + -- C2 x -> case b of C2 x -> ....compare x.... } | null non_nullary_cons -- All nullary, so go straight to comparing tags = mkTagCmp op @@ -853,7 +854,7 @@ enum_index = mkSimpleGeneratedFunBind loc unsafeIndex_RDR - [noLocA (AsPat noAnn (noLocA c_RDR) + [noLocA (AsPat noAnn (noLocA c_RDR) noHsTok (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( untag_Expr [(a_RDR, ah_RDR)] ( @@ -1112,7 +1113,7 @@ field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed con_arity = dataConSourceArity data_con - labels = map flLabel $ dataConFieldLabels data_con + labels = map (field_label . flLabel) $ dataConFieldLabels data_con dc_nm = getName data_con is_infix = dataConIsInfix data_con is_record = labels `lengthExceeds` 0 @@ -1169,14 +1170,14 @@ where lbl_str = unpackFS lbl mk_read_field read_field_rdr lbl - = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)] + = nlHsApps read_field_rdr [nlHsLit (mkHsStringFS lbl)] read_field | isSym lbl_str - = mk_read_field readSymField_RDR lbl_str + = mk_read_field readSymField_RDR lbl | Just (ss, '#') <- snocView lbl_str -- #14918 - = mk_read_field readFieldHash_RDR ss + = mk_read_field readFieldHash_RDR (mkFastString ss) | otherwise - = mk_read_field readField_RDR lbl_str + = mk_read_field readField_RDR lbl {- ************************************************************************ @@ -1236,7 +1237,7 @@ arg_tys = derivDataConInstArgTys data_con dit -- Correspond 1-1 with bs_needed con_pat = nlConVarPat data_con_RDR bs_needed nullary_con = con_arity == 0 - labels = map flLabel $ dataConFieldLabels data_con + labels = map (field_label . flLabel) $ dataConFieldLabels data_con lab_fields = length labels record_syntax = lab_fields > 0 @@ -1402,7 +1403,6 @@ where data_cons = tyConDataCons rep_tc n_cons = length data_cons - one_constr = n_cons == 1 ------------ gfoldl gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons) @@ -1419,11 +1419,11 @@ ------------ gunfold gunfold_bind = mkSimpleGeneratedFunBind loc gunfold_RDR - [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat] + [k_Pat, z_Pat, if n_cons == 1 then nlWildPat else c_Pat] gunfold_rhs gunfold_rhs - | one_constr = mk_unfold_rhs (head data_cons) -- No need for case + | [con] <- data_cons = mk_unfold_rhs con -- No need for case | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) (map gunfold_alt data_cons) @@ -1662,8 +1662,8 @@ mk_untyped_bracket = HsUntypedBracket noAnn . ExpBr noExtField mk_typed_bracket = HsTypedBracket noAnn - mk_usplice = HsUntypedSplice EpAnnNotUsed DollarSplice - mk_tsplice = HsTypedSplice EpAnnNotUsed DollarSplice + 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 @@ -1678,7 +1678,7 @@ (map lift_var as_needed) lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed) - lift_var x = noLocA (HsSpliceE EpAnnNotUsed (mk_splice x (nlHsPar (mk_lift_expr x)))) + lift_var x = noLocA (mk_splice (nlHsPar (mk_lift_expr x))) mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed) mk_lift_expr x = nlHsApps (Exact lift_name) [nlHsVar x] @@ -2080,7 +2080,7 @@ ats = classATs cls locn = noAnnSrcSpan loc' cls_tvs = classTyVars cls - in_scope = mkInScopeSet $ mkVarSet inst_tvs + in_scope = mkInScopeSetList inst_tvs lhs_env = zipTyEnv cls_tvs inst_tys lhs_subst = mkTvSubst in_scope lhs_env rhs_env = zipTyEnv cls_tvs underlying_inst_tys @@ -2097,8 +2097,8 @@ newFamInst SynFamilyInst axiom where fam_tvs = tyConTyVars fam_tc - (_, rep_lhs_tys) = substATBndrs lhs_subst fam_tvs - (_, rep_rhs_tys) = substATBndrs rhs_subst fam_tvs + rep_lhs_tys = substTyVars lhs_subst fam_tvs + rep_rhs_tys = substTyVars rhs_subst fam_tvs rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs @@ -2106,7 +2106,7 @@ rep_cvs' = scopedSort rep_cvs nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs -nlHsAppType e s = noLocA (HsAppType noSrcSpan e hs_ty) +nlHsAppType e s = noLocA (HsAppType noExtField e noHsTok hs_ty) where hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s @@ -2130,7 +2130,7 @@ (substTy lhs_subst user_meth_ty) where cls_tvs = classTyVars cls - in_scope = mkInScopeSet $ mkVarSet inst_tvs + in_scope = mkInScopeSetList inst_tvs lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys) rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty)) (_class_tvs, _class_constraint, user_meth_ty) @@ -2156,9 +2156,9 @@ -- | Generate the full code for an auxiliary binding. -- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@. -genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec +genAuxBindSpecOriginal :: SrcSpan -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs) -genAuxBindSpecOriginal dflags loc spec +genAuxBindSpecOriginal loc spec = (gen_bind spec, L loca (TypeSig noAnn [L locn (auxBindSpecRdrName spec)] (genAuxBindSpecSig loc spec))) @@ -2183,11 +2183,10 @@ = mkHsVarBind loc dataT_RDR rhs where tc_name = tyConName tycon - tc_name_string = occNameString (getOccName tc_name) - definition_mod_name = moduleNameString (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name)) - ctx = initDefaultSDocContext dflags + tc_name_string = occNameFS (getOccName tc_name) + definition_mod_name = moduleNameFS (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name)) rhs = nlHsVar mkDataType_RDR - `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (text definition_mod_name <> dot <> text tc_name_string))) + `nlHsApp` nlHsLit (mkHsStringFS (concatFS [definition_mod_name, fsLit ".", tc_name_string])) `nlHsApp` nlList (map nlHsVar dataC_RDRs) gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR) @@ -2197,12 +2196,12 @@ constr_args = [ nlHsVar dataT_RDR -- DataType - , nlHsLit (mkHsString (occNameString dc_occ)) -- Constructor name + , nlHsLit (mkHsStringFS (occNameFS dc_occ)) -- Constructor name , nlHsIntLit (toInteger (dataConTag dc)) -- Constructor tag , nlList labels -- Field labels , nlHsVar fixity ] -- Fixity - labels = map (nlHsLit . mkHsString . unpackFS . flLabel) + labels = map (nlHsLit . mkHsStringFS . field_label . flLabel) (dataConFieldLabels dc) dc_occ = getOccName dc is_infix = isDataSymOcc dc_occ @@ -2243,9 +2242,9 @@ -- | Take a 'Bag' of 'AuxBindSpec's and generate the code for auxiliary -- bindings based on the declarative descriptions in the supplied -- 'AuxBindSpec's. See @Note [Auxiliary binders]@. -genAuxBinds :: DynFlags -> SrcSpan -> Bag AuxBindSpec +genAuxBinds :: SrcSpan -> Bag AuxBindSpec -> Bag (LHsBind GhcPs, LSig GhcPs) -genAuxBinds dflags loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag) +genAuxBinds loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag) where -- Perform a CSE-like pass over the generated auxiliary bindings to avoid -- code duplication, as described in @@ -2259,7 +2258,7 @@ case lookupOccEnv original_rdr_name_env spec_occ of Nothing -> ( extendOccEnv original_rdr_name_env spec_occ spec_rdr_name - , genAuxBindSpecOriginal dflags loc spec `consBag` spec_bag ) + , genAuxBindSpecOriginal loc spec `consBag` spec_bag ) Just original_rdr_name -> ( original_rdr_name_env , genAuxBindSpecDup loc original_rdr_name spec `consBag` spec_bag ) @@ -2363,7 +2362,7 @@ (replicate arity nlWildPat) (error_Expr str) emptyLocalBinds] else matches - str = "Void " ++ occNameString (rdrNameOcc fun_rdr) + str = fsLit "Void " `appendFS` occNameFS (rdrNameOcc fun_rdr) box :: String -- The class involved @@ -2550,8 +2549,8 @@ -- 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 :: String -> LHsExpr GhcPs -error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string)) +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} @@ -2761,7 +2760,7 @@ -- | Apply a substitution to all of the 'Type's contained in a 'DerivInstTys'. -- See @Note [Instantiating field types in stock deriving]@ for why we need to -- substitute into a 'DerivInstTys' in the first place. -substDerivInstTys :: TCvSubst -> DerivInstTys -> DerivInstTys +substDerivInstTys :: Subst -> DerivInstTys -> DerivInstTys substDerivInstTys subst dit@(DerivInstTys { dit_cls_tys = cls_tys, dit_tc_args = tc_args , dit_rep_tc = rep_tc, 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 @@ -21,21 +21,25 @@ ) where -import GHC.Prelude +import GHC.Prelude hiding (head, init, last, tail) import GHC.Hs -import GHC.Core.Type import GHC.Tc.Utils.TcType import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor import GHC.Tc.Errors.Types +import GHC.Tc.Instance.Family + +import GHC.Core.Type import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) -import GHC.Tc.Instance.Family -import GHC.Unit.Module ( moduleName, moduleNameFS - , moduleUnit, unitFS, getModule ) + +import GHC.Unit.Module ( moduleName, moduleUnit + , unitFS, getModule ) + import GHC.Iface.Env ( newGlobalBinder ) + import GHC.Types.Name hiding ( varName ) import GHC.Types.Name.Reader import GHC.Types.SourceText @@ -58,8 +62,13 @@ import GHC.Data.FastString import GHC.Utils.Misc +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 qualified Data.List.NonEmpty as NE import Data.Maybe (isJust) {- @@ -289,9 +298,9 @@ , ft_var = caseVar, ft_co_var = caseVar -- (component_0,component_1,...,component_n) - , ft_tup = \_ components -> if any _ccdg1_hasParam (init components) - then bmbad con - else foldr bmplus bmzero components + , ft_tup = \_ components -> case nonEmpty components of + Just components' | any _ccdg1_hasParam (NE.init components') -> bmbad con + _ -> foldr bmplus bmzero components -- (dom -> rng), where the head of ty is not a tuple tycon , ft_fun = \dom rng -> -- cf #8516 @@ -338,11 +347,11 @@ gk2gkDC :: GenericKind -> DataCon -> [Type] -> GenericKind_DC gk2gkDC Gen0 _ _ = Gen0_DC gk2gkDC Gen1 dc tc_args = Gen1_DC $ assert (isTyVarTy last_dc_inst_univ) - $ getTyVar "gk2gkDC" last_dc_inst_univ + $ getTyVar last_dc_inst_univ where dc_inst_univs = dataConInstUnivs dc tc_args last_dc_inst_univ = assert (not (null dc_inst_univs)) $ - last dc_inst_univs + Partial.last dc_inst_univs -- Bindings for the Generic instance @@ -654,7 +663,7 @@ then promotedTrueDataCon else promotedFalseDataCon - selName = mkStrLitTy . flLabel + selName = mkStrLitTy . field_label . flLabel mbSel Nothing = mkTyConApp promotedNothingDataCon [typeSymbolKind] mbSel (Just s) = mkTyConApp promotedJustDataCon @@ -677,7 +686,7 @@ pDStrness = mkTyConTy $ case ib of HsLazy -> pDLzy - HsStrict -> pDStr + HsStrict _ -> pDStr HsUnpack{} -> pDUpk return (mkD tycon) @@ -1069,7 +1078,7 @@ The recommended approach thus far was to increase unfolding threshold, but this makes GHC inline more aggressively in general, whereas it should only be more -aggresive with generics-based code. +aggressive with generics-based code. The solution is to use a heuristic that'll annotate Generic class methods with INLINE[1] pragmas (the explicit phase is used to give users phase control as 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 @@ -16,16 +16,6 @@ import GHC.Prelude -import GHC.Data.Bag -import GHC.Types.Basic -import GHC.Core.Class -import GHC.Core.DataCon -import GHC.Utils.Error -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Utils.Panic.Plain -import GHC.Data.Pair -import GHC.Builtin.Names import GHC.Tc.Deriv.Utils import GHC.Tc.Utils.Env import GHC.Tc.Deriv.Generate @@ -35,24 +25,40 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint -import GHC.Core.Predicate import GHC.Tc.Utils.TcType -import GHC.Core.TyCon -import GHC.Core.TyCo.Ppr (pprTyVars) -import GHC.Core.Type import GHC.Tc.Solver import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Validity (validDerivPred) import GHC.Tc.Utils.Unify (buildImplicationFor) -import GHC.Builtin.Types (typeToTypeKind) + +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCo.Ppr (pprTyVars) +import GHC.Core.Type +import GHC.Core.Predicate import GHC.Core.Unify (tcUnifyTy) + +import GHC.Data.Pair +import GHC.Builtin.Names +import GHC.Builtin.Types (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 import GHC.Types.Var -import GHC.Types.Var.Set +import GHC.Data.Bag + import Control.Monad import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ask) +import Data.Function (on) +import Data.Functor.Classes (liftEq) import Data.List (sortBy) import Data.Maybe @@ -179,7 +185,7 @@ :: ([TyVar] -> CtOrigin -> TypeOrKind -> Type - -> [(ThetaSpec, Maybe TCvSubst)]) + -> [(ThetaSpec, Maybe Subst)]) -> (ThetaSpec, [TyVar], [TcType], DerivInstTys) con_arg_constraints get_arg_constraints = let -- Constraints from the fields of each data constructor. @@ -217,8 +223,8 @@ -- kinds with (* -> *). -- See Note [Inferring the instance context] subst = foldl' composeTCvSubst - emptyTCvSubst (catMaybes mbSubsts) - unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst + emptySubst (catMaybes mbSubsts) + unmapped_tvs = filter (\v -> v `notElemSubst` subst && not (v `isInScope` subst)) tvs (subst', _) = substTyVarBndrs subst unmapped_tvs stupid_theta_origin = mkDirectThetaSpec @@ -234,7 +240,7 @@ is_generic = main_cls `hasKey` genClassKey is_generic1 = main_cls `hasKey` gen1ClassKey -- is_functor_like: see Note [Inferring the instance context] - is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind + is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind || is_generic1 get_gen1_constraints :: @@ -242,7 +248,7 @@ -> [TyVar] -- The universally quantified type variables for the -- data constructor -> CtOrigin -> TypeOrKind -> Type - -> [(ThetaSpec, Maybe TCvSubst)] + -> [(ThetaSpec, Maybe Subst)] get_gen1_constraints functor_cls dc_univs orig t_or_k ty = mk_functor_like_constraints orig t_or_k functor_cls $ get_gen1_constrained_tys last_dc_univ ty @@ -257,7 +263,7 @@ [TyVar] -- The universally quantified type variables for the -- data constructor -> CtOrigin -> TypeOrKind -> Type - -> [(ThetaSpec, Maybe TCvSubst)] + -> [(ThetaSpec, Maybe Subst)] get_std_constrained_tys dc_univs orig t_or_k ty | is_functor_like = mk_functor_like_constraints orig t_or_k main_cls $ @@ -273,7 +279,7 @@ mk_functor_like_constraints :: CtOrigin -> TypeOrKind -> Class -> [Type] - -> [(ThetaSpec, Maybe TCvSubst)] + -> [(ThetaSpec, Maybe Subst)] -- 'cls' is usually main_cls (Functor or Traversable etc), but if -- main_cls = Generic1, then 'cls' can be Functor; see -- get_gen1_constraints @@ -286,7 +292,7 @@ -- message which points out the kind mismatch. -- See Note [Inferring the instance context] mk_functor_like_constraints orig t_or_k cls - = map $ \ty -> let ki = tcTypeKind ty in + = map $ \ty -> let ki = typeKind ty in ( [ mk_cls_pred orig t_or_k cls ty , SimplePredSpec { sps_pred = mkPrimEqPred ki typeToTypeKind @@ -307,7 +313,7 @@ -- and we need the Data constraints to typecheck the method extra_constraints | main_cls `hasKey` dataClassKey - , all (isLiftedTypeKind . tcTypeKind) rep_tc_args + , all (isLiftedTypeKind . typeKind) rep_tc_args = [ mk_cls_pred deriv_origin t_or_k main_cls ty | (t_or_k, ty) <- zip t_or_ks rep_tc_args] | otherwise @@ -694,7 +700,7 @@ current_solns infer_specs ; new_solns <- checkNoErrs $ extendLocalInstEnv inst_specs $ - mapM gen_soln infer_specs + mapM simplifyDeriv infer_specs ; if (current_solns `eqSolution` new_solns) then return [ setDerivSpecTheta soln spec @@ -702,29 +708,11 @@ else iterate_deriv (n+1) new_solns } - eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b) + eqSolution = (liftEq . liftEq) eqType `on` canSolution -- Canonicalise for comparison -- See Note [Deterministic simplifyInstanceContexts] canSolution = map (sortBy nonDetCmpType) - ------------------------------------------------------------------ - gen_soln :: DerivSpec ThetaSpec -> TcM ThetaType - gen_soln (DS { ds_loc = loc, ds_tvs = tyvars - , 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 the_pred) $ - do { theta <- simplifyDeriv skol_info user_ctxt tyvars deriv_rhs - -- checkValidInstance tyvars theta clas inst_tys - -- Not necessary; see Note [Exotic derived instance contexts] - ; traceTc "GHC.Tc.Deriv" (ppr deriv_rhs $$ ppr theta) - -- Claim: the result instance declaration is guaranteed valid - -- Hence no need to call: - -- checkValidInstance tyvars theta clas inst_tys - ; return theta } - where - the_pred = mkClassPred clas inst_tys - derivInstCtxt :: PredType -> SDoc derivInstCtxt pred = text "When deriving the instance for" <+> parens (ppr pred) @@ -737,29 +725,27 @@ *********************************************************************************** -} + -- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much -- as possible. Fail if not possible. -simplifyDeriv :: SkolemInfo -- ^ The 'SkolemInfo' used to skolemise the - -- 'TcTyVar' arguments - -> UserTypeCtxt -- ^ Used to inform error messages as to whether - -- we are in a @deriving@ clause or a standalone - -- @deriving@ declaration - -> [TcTyVar] -- ^ The tyvars bound by @inst_ty@. - -> ThetaSpec -- ^ The constraints to solve and simplify +simplifyDeriv :: DerivSpec ThetaSpec -> TcM ThetaType -- ^ Needed constraints (after simplification), -- i.e. @['PredType']@. -simplifyDeriv skol_info user_ctxt tvs theta - = do { let skol_set = mkVarSet tvs - +simplifyDeriv (DS { ds_loc = loc, ds_tvs = tvs + , 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)) $ + do { -- See [STEP DAC BUILD] -- Generate the implication constraints, one for each method, to solve -- with the skolemized variables. Start "one level down" because -- we are going to wrap the result in an implication with tvs, -- in step [DAC RESIDUAL] - ; (tc_lvl, wanteds) <- captureThetaSpecConstraints user_ctxt theta + ; (tc_lvl, wanteds) <- captureThetaSpecConstraints user_ctxt deriv_rhs ; traceTc "simplifyDeriv inputs" $ - vcat [ pprTyVars tvs $$ ppr theta $$ ppr wanteds, ppr skol_info ] + vcat [ pprTyVars tvs $$ ppr deriv_rhs $$ ppr wanteds, ppr skol_info ] -- See [STEP DAC SOLVE] -- Simplify the constraints, starting at the same level at which @@ -776,6 +762,7 @@ -- 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 -- Returns @Just p@ (where @p@ is the type of the Ct) if a Ct is @@ -784,10 +771,8 @@ -- See Note [Exotic derived instance contexts] for what -- constitutes an exotic constraint. get_good :: Ct -> Maybe PredType - get_good ct | validDerivPred skol_set p - = Just p - | otherwise - = Nothing + get_good ct | validDerivPred head_size p = Just p + | otherwise = Nothing where p = ctPred ct ; traceTc "simplifyDeriv outputs" $ @@ -816,6 +801,13 @@ -- See also Note [Exotic derived instance contexts], which are caught -- in this line of code. ; simplifyTopImplic leftover_implic + + ; traceTc "GHC.Tc.Deriv" (ppr deriv_rhs $$ ppr min_theta) + + -- 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] ; return min_theta } 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 @@ -28,23 +28,8 @@ import GHC.Data.Bag import GHC.Types.Basic -import GHC.Core.Class -import GHC.Core.DataCon -import GHC.Core.FamInstEnv -import GHC.Driver.Session -import GHC.Utils.Error -import GHC.Types.Fixity.Env (lookupFixity) -import GHC.Hs + import GHC.Tc.Utils.Instantiate -import GHC.Core.InstEnv -import GHC.Iface.Load (loadInterfaceForName) -import GHC.Unit.Module (getModule) -import GHC.Unit.Module.ModIface (mi_fix) -import GHC.Types.Name -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Builtin.Names -import GHC.Types.SrcLoc import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor import GHC.Tc.Deriv.Generics @@ -55,12 +40,33 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Unify (tcSubTypeSigma) import GHC.Tc.Utils.Zonk -import GHC.Builtin.Names.TH (liftClassKey) + +import GHC.Core.Class +import GHC.Core.DataCon +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv import GHC.Core.TyCon import GHC.Core.Type + +import GHC.Hs +import GHC.Driver.Session +import GHC.Unit.Module (getModule) +import GHC.Unit.Module.ModIface (mi_fix) + +import GHC.Types.Fixity.Env (lookupFixity) +import GHC.Iface.Load (loadInterfaceForName) +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.Outputable +import GHC.Utils.Panic +import GHC.Utils.Error + import Control.Monad.Trans.Reader import Data.Foldable (traverse_) import Data.Maybe @@ -637,7 +643,7 @@ , sps_type_or_kind = t_or_k }) -substPredSpec :: HasCallStack => TCvSubst -> PredSpec -> PredSpec +substPredSpec :: HasCallStack => Subst -> PredSpec -> PredSpec substPredSpec subst ps = case ps of SimplePredSpec { sps_pred = pred diff --git a/GHC/Tc/Errors.hs b/GHC/Tc/Errors.hs --- a/GHC/Tc/Errors.hs +++ b/GHC/Tc/Errors.hs @@ -1,11 +1,11 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# LANGUAGE ParallelListComp #-} module GHC.Tc.Errors( reportUnsolved, reportAllUnsolved, warnAllUnsolved, @@ -13,7 +13,6 @@ -- * GHC API helper functions solverReportMsg_ExpectedActuals, - solverReportInfo_ExpectedActuals ) where import GHC.Prelude @@ -61,8 +60,7 @@ import GHC.Core.Predicate import GHC.Core.Type import GHC.Core.Coercion -import GHC.Core.TyCo.Ppr ( pprTyVars - ) +import GHC.Core.TyCo.Ppr ( pprTyVars ) import GHC.Core.InstEnv import GHC.Core.TyCon import GHC.Core.DataCon @@ -79,13 +77,13 @@ 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 ( map, reverse ) -import Data.Ord ( comparing ) +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 {- @@ -175,7 +173,7 @@ -- 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 [Fail fast on kind errors] in "GHC.Tc.Solver") +-- (see Note [Failure in local type signatures] in GHC.Tc.Solver) reportAllUnsolved :: WantedConstraints -> TcM () reportAllUnsolved wanted = do { ev_binds <- newNoTcEvBinds @@ -263,13 +261,18 @@ -- | Make a report from a single 'TcSolverReportMsg'. important :: SolverReportErrCtxt -> TcSolverReportMsg -> SolverReport -important ctxt doc = mempty { sr_important_msgs = [SolverReportWithCtxt ctxt doc] } +important ctxt doc + = SolverReport { sr_important_msg = SolverReportWithCtxt ctxt doc + , sr_supplementary = [] + , sr_hints = [] } -mk_relevant_bindings :: RelevantBindings -> SolverReport -mk_relevant_bindings binds = mempty { sr_supplementary = [SupplementaryBindings binds] } +add_relevant_bindings :: RelevantBindings -> SolverReport -> SolverReport +add_relevant_bindings binds report@(SolverReport { sr_supplementary = supp }) + = report { sr_supplementary = SupplementaryBindings binds : supp } -mk_report_hints :: [GhcHint] -> SolverReport -mk_report_hints hints = mempty { sr_hints = hints } +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 @@ -388,7 +391,7 @@ warnRedundantConstraints :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM () -- See Note [Tracking redundant constraints] in GHC.Tc.Solver -warnRedundantConstraints ctxt env info ev_vars +warnRedundantConstraints ctxt env info redundant_evs | null redundant_evs = return () @@ -420,23 +423,11 @@ [] ; reportDiagnostic msg } - redundant_evs = - filterOut is_type_error $ - case info of -- See Note [Redundant constraints in instance decls] - InstSkol -> filterOut (improving . idType) ev_vars - _ -> ev_vars - - -- See #15232 - is_type_error = isJust . userTypeError_maybe . idType - - improving pred -- (transSuperClasses p) does not include p - = any isImprovementPred (pred : transSuperClasses pred) - reportBadTelescope :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM () reportBadTelescope ctxt env (ForAllSkol telescope) skols = do { msg <- mkErrorReport env - (TcRnSolverReport [report] ErrorWithoutFlag noHints) + (TcRnSolverReport report ErrorWithoutFlag noHints) (Just ctxt) [] ; reportDiagnostic msg } @@ -446,23 +437,6 @@ reportBadTelescope _ _ skol_info skols = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols) -{- Note [Redundant constraints in instance decls] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For instance declarations, 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.. --} - -- | 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. @@ -668,7 +642,7 @@ is_user_type_error item _ = isUserTypeError (errorItemPred item) is_homo_equality _ (EqPred _ ty1 ty2) - = tcTypeKind ty1 `tcEqType` tcTypeKind ty2 + = typeKind ty1 `tcEqType` typeKind ty2 is_homo_equality _ _ = False @@ -905,7 +879,7 @@ frr_origins = acc_errors errs diag = TcRnSolverReport - [SolverReportWithCtxt ctxt (FixedRuntimeRepError frr_origins)] + (SolverReportWithCtxt ctxt (FixedRuntimeRepError frr_origins)) ErrorWithoutFlag noHints -- Accumulate the different kind of errors arising from syntactic equality. @@ -961,10 +935,10 @@ -- with one from the immediately-enclosing implication. -- See Note [Inaccessible code] - ; (eq_err_msgs, _hints) <- mkEqErr_help ctxt item' ty1 ty2 + ; (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 (NE.reverse . NE.map (SolverReportWithCtxt ctxt) $ eq_err_msgs) + msg = TcRnInaccessibleCode implic (SolverReportWithCtxt ctxt eq_err_msg) ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) supplementary ; reportDiagnostic msg } where @@ -1061,7 +1035,7 @@ maybeReportError :: SolverReportErrCtxt -> [ErrorItem] -- items covered by the Report -> SolverReport -> TcM () -maybeReportError ctxt items@(item1:_) (SolverReport { sr_important_msgs = important +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 @@ -1094,18 +1068,18 @@ -> do { -- See Note [Deferred errors for coercion holes] let co_var = coHoleCoVar hole ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm - ; fillCoercionHole hole (mkTcCoVarCo co_var) } } + ; 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_msgs = important, sr_supplementary = supp }) +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 msg + ; let err_msg = pprLocMsgEnvelope (initTcMessageOpts dflags) msg err_str = showSDoc dflags $ err_msg $$ text "(deferred type error)" @@ -1171,10 +1145,13 @@ 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 $ TcRnMessageDetailed err_info msg) } + (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", @@ -1278,10 +1255,10 @@ mkIrredErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport mkIrredErr ctxt items - = do { (ctxt, binds_msg, item1) <- relevantBindings True ctxt item1 - ; let msg = important ctxt $ + = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 + ; let msg = important ctxt $ mkPlainMismatchMsg $ CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing - ; return $ msg `mappend` mk_relevant_bindings binds_msg } + ; return $ add_relevant_bindings binds msg } where (item1:others) = final_items @@ -1341,12 +1318,12 @@ ; let (imp_errs, hints) = unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env - (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ) - errs = [SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs)] - report = SolverReport errs [] hints + (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 errs (cec_out_of_scope_holes ctxt) hints) Nothing [] + ; 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. } @@ -1360,7 +1337,7 @@ , 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 Trac #8191 + -- The 'False' means "don't filter the bindings"; see #8191 ; show_hole_constraints <- goptM Opt_ShowHoleConstraints ; let relevant_cts @@ -1376,14 +1353,14 @@ ; (grouped_skvs, other_tvs) <- zonkAndGroupSkolTvs hole_ty ; let reason | ExprHole _ <- sort = cec_expr_holes ctxt | otherwise = cec_type_holes ctxt - errs = [SolverReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs] + 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 errs supp []) + ; maybeAddDeferredBindings ctxt hole (SolverReport err supp []) - ; mkErrorReport lcl_env (TcRnSolverReport errs reason noHints) (Just ctxt) supp + ; mkErrorReport lcl_env (TcRnSolverReport err reason noHints) (Just ctxt) supp } where @@ -1472,16 +1449,16 @@ -- 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_msg, item1) <- relevantBindings True ctxt item1 + = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1 ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others) - ; return $ msg `mappend` mk_relevant_bindings binds_msg } + ; return $ add_relevant_bindings binds msg } where item1:others = items ---------------- -- | Report a representation-polymorphism error to the user: --- a type is required to havehave a fixed runtime representation, +-- a type is required to have a fixed runtime representation, -- but doesn't. -- -- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin. @@ -1584,19 +1561,13 @@ mkEqErr1 :: SolverReportErrCtxt -> ErrorItem -> TcM SolverReport mkEqErr1 ctxt item -- Wanted only -- givens handled in mkGivenErrorReporter - = do { (ctxt, binds_msg, item) <- relevantBindings True ctxt item - ; rdr_env <- getGlobalRdrEnv - ; fam_envs <- tcGetFamInstEnvs - ; let mb_coercible_msg = case errorItemEqRel item of - NomEq -> Nothing - ReprEq -> ReportCoercibleMsg <$> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + = do { (ctxt, binds, item) <- relevantBindings True ctxt item ; traceTc "mkEqErr1" (ppr item $$ pprCtOrigin (errorItemOrigin item)) - ; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt item ty1 ty2 + ; (err_msg, hints) <- mkEqErr_help ctxt item ty1 ty2 ; let - report = foldMap (important ctxt) (reverse prev_msgs) - `mappend` (important ctxt $ mkTcReportWithInfo last_msg $ maybeToList mb_coercible_msg) - `mappend` (mk_relevant_bindings binds_msg) - `mappend` (mk_report_hints hints) + report = add_relevant_bindings binds + $ add_report_hints hints + $ important ctxt err_msg ; return report } where (ty1, ty2) = getEqPredTys (errorItemPred item) @@ -1642,38 +1613,55 @@ | otherwise = False --- | Accumulated messages in reverse order. -type AccReportMsgs = NonEmpty TcSolverReportMsg - mkEqErr_help :: SolverReportErrCtxt -> ErrorItem - -> TcType -> TcType -> TcM (AccReportMsgs, [GhcHint]) + -> TcType -> TcType -> TcM (TcSolverReportMsg, [GhcHint]) mkEqErr_help ctxt item ty1 ty2 - | Just casted_tv1 <- tcGetCastedTyVar_maybe ty1 + | Just casted_tv1 <- getCastedTyVar_maybe ty1 = mkTyVarEqErr ctxt item casted_tv1 ty2 - | Just casted_tv2 <- tcGetCastedTyVar_maybe ty2 + | Just casted_tv2 <- getCastedTyVar_maybe ty2 = mkTyVarEqErr ctxt item casted_tv2 ty1 | otherwise - = return (reportEqErr ctxt item ty1 ty2 :| [], []) + = do + err <- reportEqErr ctxt item ty1 ty2 + return (err, noHints) reportEqErr :: SolverReportErrCtxt -> ErrorItem - -> TcType -> TcType -> TcSolverReportMsg + -> TcType -> TcType + -> TcM TcSolverReportMsg reportEqErr ctxt item ty1 ty2 - = mkTcReportWithInfo mismatch eqInfos + = 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 (AccReportMsgs, [GhcHint]) + -> (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 (AccReportMsgs, [GhcHint]) + -> (TcTyVar, TcCoercionN) -> TcType -> TcM (TcSolverReportMsg, [GhcHint]) mkTyVarEqErr' ctxt item (tv1, co1) ty2 -- Is this a representation-polymorphism error, e.g. @@ -1681,24 +1669,28 @@ | Just frr_info <- mb_concrete_reason = do (_, infos) <- zonkTidyFRRInfos (cec_tidy ctxt) [frr_info] - return (FixedRuntimeRepError infos :| [], []) + return (FixedRuntimeRepError infos, []) -- Impredicativity is a simple error to understand; try it before -- anything more complicated. | check_eq_result `cterHasProblem` cteImpredicative = do - tyvar_eq_info <- extraTyVarEqInfo tv1 ty2 + tyvar_eq_info <- extraTyVarEqInfo (tv1, Nothing) ty2 let - poly_msg = CannotUnifyWithPolytype item tv1 ty2 - poly_msg_with_info + poly_msg = CannotUnifyWithPolytype item tv1 ty2 mb_tv_info + mb_tv_info | isSkolemTyVar tv1 - = mkTcReportWithInfo poly_msg tyvar_eq_info + = Just tyvar_eq_info | otherwise - = poly_msg + = 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 (poly_msg_with_info <| headline_msg :| [], []) + return (main_msg, []) | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have -- swapped in Solver.Canonical.canEqTyVarHomo @@ -1706,30 +1698,43 @@ || errorItemEqRel item == ReprEq -- The cases below don't really apply to ReprEq (except occurs check) = do - tv_extra <- extraTyVarEqInfo tv1 ty2 - return (mkTcReportWithInfo headline_msg tv_extra :| [], add_sig) + 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 extras2 = eqInfoMsgs ty1 ty2 + = let ambiguity_infos = eqInfoMsgs ty1 ty2 interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ filter isTyVar $ fvVarList $ tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 - extras3 = case interesting_tyvars of - [] -> [] - (tv : tvs) -> [OccursCheckInterestingTyVars (tv :| tvs)] + occurs_err = + OccursCheck + { occursCheckInterestingTyVars = interesting_tyvars + , occursCheckAmbiguityInfos = ambiguity_infos } + main_msg = + CannotUnifyVariable + { mismatchMsg = headline_msg + , cannotUnifyReason = occurs_err } - in return (mkTcReportWithInfo headline_msg (extras2 ++ extras3) :| [], []) + 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 :| [], []) + = 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 @@ -1739,16 +1744,26 @@ , Implic { ic_skols = skols } <- implic , tv1 `elem` skols = do - tv_extra <- extraTyVarEqInfo tv1 ty2 - return (mkTcReportWithInfo mismatch_msg tv_extra :| [], []) + 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) - = return (SkolemEscape item implic esc_skols :| [mismatch_msg], []) + = 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* @@ -1758,12 +1773,19 @@ , Implic { ic_tclvl = lvl } <- implic = assertPpr (not (isTouchableMetaTyVar lvl tv1)) (ppr tv1 $$ ppr lvl) $ do -- See Note [Error messages for untouchables] - let tclvl_extra = UntouchableVariable tv1 implic - tv_extra <- extraTyVarEqInfo tv1 ty2 - return (mkTcReportWithInfo tclvl_extra tv_extra :| [mismatch_msg], add_sig) + 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 - = return (reportEqErr ctxt item (mkTyVarTy tv1) ty2 :| [], []) + = 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. @@ -1802,7 +1824,7 @@ insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs -eqInfoMsgs :: TcType -> TcType -> [TcSolverReportInfo] +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 @@ -1836,7 +1858,7 @@ = Nothing misMatchOrCND :: Bool -> SolverReportErrCtxt -> ErrorItem - -> TcType -> TcType -> TcSolverReportMsg + -> 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] @@ -1904,23 +1926,30 @@ in GHC.Tc.TyCl.PatSyn). -} -extraTyVarEqInfo :: TcTyVar -> TcType -> TcM [TcSolverReportInfo] +extraTyVarEqInfo :: (TcTyVar, Maybe Implication) -> TcType -> TcM TyVarInfo -- Add on extra info about skolem constants -- NB: The types themselves are already tidied -extraTyVarEqInfo tv1 ty2 - = (:) <$> extraTyVarInfo tv1 <*> ty_extra ty2 +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 tcGetCastedTyVar_maybe ty of - Just (tv, _) -> (:[]) <$> extraTyVarInfo tv - Nothing -> return [] + ty_extra ty = case getCastedTyVar_maybe ty of + Just (tv, _) -> Just <$> extraTyVarInfo tv + Nothing -> return Nothing -extraTyVarInfo :: TcTyVar -> TcM TcSolverReportInfo +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 $ TyVarInfo (mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps)) - _ -> return $ TyVarInfo tv + return $ mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps) + _ -> return tv suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint @@ -1932,7 +1961,7 @@ = Nothing where inferred_bndrs = - case tcGetTyVar_maybe ty1 of + case getTyVar_maybe ty1 of Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv _ -> [] @@ -1949,30 +1978,29 @@ = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv -------------------- -mkMismatchMsg :: ErrorItem -> Type -> Type -> TcSolverReportMsg +mkMismatchMsg :: ErrorItem -> Type -> Type -> MismatchMsg mkMismatchMsg item ty1 ty2 = case orig of TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } -> - mkTcReportWithInfo - (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}) - extras + (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 -> - mkTcReportWithInfo (Mismatch False item ty1 ty2) - (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k : extras) + (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 } _ -> - mkTcReportWithInfo - (Mismatch False item ty1 ty2) - extras + (mkBasicMismatchMsg NoEA item ty1 ty2) + { mismatch_mb_same_occ = mb_same_occ } where orig = errorItemOrigin item - extras = sameOccExtras ty2 ty1 + mb_same_occ = sameOccExtras ty2 ty1 ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig -- | Whether to print explicit kinds (with @-fprint-explicit-kinds@) @@ -2011,7 +2039,7 @@ want to be as draconian with them.) -} -sameOccExtras :: TcType -> TcType -> [TcSolverReportInfo] +sameOccExtras :: TcType -> TcType -> Maybe SameOccInfo -- See Note [Disambiguating (X ~ X) errors] sameOccExtras ty1 ty2 | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 @@ -2022,9 +2050,9 @@ same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2) , n1 /= n2 -- Different Names , same_occ -- but same OccName - = [SameOcc same_pkg n1 n2] + = Just $ SameOcc same_pkg n1 n2 | otherwise - = [] + = Nothing {- Note [Suggest adding a type signature] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2145,26 +2173,24 @@ -- and the result of evaluating ...". mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupResult) -> TcM TcSolverReportMsg --- Report an overlap error if this class constraint results --- from an overlap (returning Left clas), otherwise return (Right pred) -mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) - | null matches -- No matches but perhaps several unifiers - = do { (_, 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) } +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) } - | null unsafe_overlapped -- Some matches => overlap errors - = return $ overlap_msg + -- Some matches => overlap errors + (Just matchesNE, Nothing) -> return $ + OverlappingInstances item (NE.map fst matchesNE) (getPotentialUnifiers unifiers) - | otherwise - = return $ safe_haskell_msg + (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 - ispecs = [ispec | (ispec, _) <- matches] - unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] get_candidate_instances :: TcM [ClsInst] -- See Note [Report candidate instances] @@ -2213,18 +2239,6 @@ cannot_resolve_msg item candidate_insts binds imp_errs field_suggestions = CannotResolveInstance item (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds - -- Overlap errors. - overlap_msg, safe_haskell_msg :: TcSolverReportMsg - -- Normal overlap error - overlap_msg - = assert (not (null matches)) $ OverlappingInstances item ispecs (getPotentialUnifiers unifiers) - - -- Overlap error because of Safe Haskell (first - -- match should be the most specific match) - safe_haskell_msg - = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $ - UnsafeOverlap item ispecs unsafe_ispecs - {- Note [Report candidate instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have an unsolved (Num Int), where `Int` is not the Prelude Int, @@ -2237,7 +2251,7 @@ 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 @@ -2468,28 +2482,14 @@ solverReportMsg_ExpectedActuals :: TcSolverReportMsg -> [(Type, Type)] solverReportMsg_ExpectedActuals = \case - TcReportWithInfo msg infos -> - solverReportMsg_ExpectedActuals msg - ++ (solverReportInfo_ExpectedActuals =<< toList infos) - Mismatch { 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)] - _ -> [] - --- | Retrieves all @"expected"/"actual"@ messages from a 'TcSolverReportInfo'. --- --- Prefer using this over inspecting the 'TcSolverReportInfo' datatype if --- you just need this information, as the datatype itself is subject to change --- across GHC versions. -solverReportInfo_ExpectedActuals :: TcSolverReportInfo -> [(Type, Type)] -solverReportInfo_ExpectedActuals - = \case - ExpectedActual { ea_expected = exp, ea_actual = act } -> - [(exp, act)] - ExpectedActualAfterTySynExpansion - { ea_expanded_expected = exp, ea_expanded_actual = act } -> - [(exp, act)] + 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 {} -> + [] _ -> [] 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 @@ -2,8 +2,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Tc.Errors.Hole ( findValidHoleFits , tcCheckHoleFit @@ -82,8 +80,7 @@ import GHC.Tc.Errors.Hole.FitTypes import qualified Data.Set as Set import GHC.Types.SrcLoc -import GHC.Utils.Trace (warnPprTrace) -import GHC.Data.FastString (unpackFS) +import GHC.Data.FastString (NonDetFastString(..)) import GHC.Types.Unique.Map @@ -400,7 +397,7 @@ Note [Speeding up valid hole-fits] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To fix #16875 we noted that a lot of time was being spent on uneccessary work. +To fix #16875 we noted that a lot of time was being spent on unecessary 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 @@ -462,7 +459,7 @@ ; if showDocs then do { dflags <- getDynFlags ; mb_local_docs <- extractDocs dflags =<< getGblEnv - ; (mods_without_docs, fits') <- mapAccumM (upd mb_local_docs) Set.empty fits + ; (mods_without_docs, fits') <- mapAccumLM (upd mb_local_docs) Set.empty fits ; report mods_without_docs ; return fits' } else return fits } @@ -483,16 +480,16 @@ Just m -> Right m Nothing -> Left $ case nameSrcLoc name of - RealSrcLoc r _ -> unpackFS $ srcLocFile r - UnhelpfulLoc s -> unpackFS $ s + -- Nondeterminism is fine, this is used only to display a warning + RealSrcLoc r _ -> NonDetFastString $ srcLocFile r + UnhelpfulLoc s -> NonDetFastString s report mods = do { let warning = text "WARNING: Couldn't find any documentation for the following modules:" $+$ nest 2 - (fsep (punctuate comma - (either text ppr <$> Set.toList mods)) $+$ + (pprWithCommas (either ppr ppr) (Set.toList mods) $+$ text "Make sure the modules are compiled with '-haddock'.") - ; warnPprTrace (not $ Set.null mods)"addHoleFitDocs" warning (pure ()) + ; warnPprTrace (not $ Set.null mods) "addHoleFitDocs" warning (pure ()) } -- For pretty printing hole fits, we display the name and type of the fit, @@ -503,7 +500,7 @@ 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 binderArgFlag b of + where pprArg b arg = case binderFlag b of Specified -> text "@" <> pprParendType arg -- Do not print type application for inferred -- variables (#16456) @@ -521,11 +518,11 @@ -- e.g. -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a) -- into [m, a] - unwrapTypeVars :: Type -> [TyCoVarBinder] + unwrapTypeVars :: Type -> [ForAllTyBinder] unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of - Just (_, _, unfunned) -> unwrapTypeVars unfunned + Just (_, _, _, unfunned) -> unwrapTypeVars unfunned _ -> [] - where (vars, unforalled) = splitForAllTyCoVarBinders t + where (vars, unforalled) = splitForAllForAllTyBinders t holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches holeDisp = if sMs then holeVs else sep $ replicate (length hfMatches) $ text "_" @@ -677,8 +674,7 @@ -- of only concrete hole fits like `sum`. mkRefTy :: Int -> TcM (TcType, [TcTyVar]) mkRefTy refLvl = (wrapWithVars &&& id) <$> newTyVars - where newTyVars = replicateM refLvl $ setLvl <$> - (newOpenTypeKind >>= newFlexiTyVar) + where newTyVars = replicateM refLvl $ setLvl <$> newOpenFlexiTyVar setLvl = flip setMetaTyVarTcLevel hole_lvl wrapWithVars vars = mkVisFunTysMany (map mkTyVarTy vars) hole_ty @@ -919,7 +915,7 @@ _ -> True allConcrete = all notAbstract z_wrp_tys ; z_vars <- zonkTcTyVars ref_vars - ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars + ; let z_mtvs = mapMaybe getTyVar_maybe z_vars ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs ; allowAbstract <- goptM Opt_AbstractRefHoleFits ; if allowAbstract || (allFilled && allConcrete ) 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 @@ -2,3140 +2,4103 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage - -module GHC.Tc.Errors.Ppr - ( pprTypeDoesNotHaveFixedRuntimeRep - , pprScopeError - -- - , tidySkolemInfo - , tidySkolemInfoAnon - -- - , withHsDocContext - , pprHsDocContext - , inHsDocContext - ) - where - -import GHC.Prelude - -import GHC.Builtin.Names - -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.Hs - -import GHC.Tc.Errors.Types -import GHC.Tc.Types.Constraint -import {-# SOURCE #-} GHC.Tc.Types (getLclEnvLoc) -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.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.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 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 - - -instance Diagnostic TcRnMessage where - diagnosticMessage = \case - TcRnUnknownMessage m - -> diagnosticMessage m - TcRnMessageWithInfo unit_state msg_with_info - -> case msg_with_info of - TcRnMessageDetailed err_info msg - -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg) - TcRnSolverReport msgs _ _ - -> mkDecorated $ - map pprSolverReportWithCtxt msgs - 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 contras - -> mkSimpleDecorated $ - hang (text "Inaccessible code in") - 2 (ppr (ic_info implic)) - $$ vcat (map pprSolverReportWithCtxt (NE.toList contras)) - 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 mb_ctxt - -> mkSimpleDecorated $ vcat [ main_msg, context_msg ] - where - main_msg :: SDoc - main_msg = 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 - context_msg :: SDoc - context_msg = case mb_ctxt of - Just ctxt -> nest 2 (text "in" <+> pprHsDocContext ctxt) - _ -> empty - 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") - 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 ty - -> mkSimpleDecorated $ vcat - [ hang (text "Illegal visible, dependent quantification" <+> - text "in the type of a term:") - 2 (pprType ty) - , text "(GHC does not yet support this)" ] - 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) - 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) - 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 $ text "Illegal foreign declaration:" <+> - case expectedBknds of - COrAsmOrLlvm -> - text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)" - COrAsmOrLlvmOrInterp -> - text "requires interpreted, unregisterised, llvm or native code generation" - - 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" - 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"] - 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 - 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 - 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 - 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 - 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 - TcRnCannotDefaultConcrete{} - -> ErrorWithoutFlag - - diagnosticHints = \case - TcRnUnknownMessage m - -> diagnosticHints m - TcRnMessageWithInfo _ msg_with_info - -> case msg_with_info of - TcRnMessageDetailed _ m -> diagnosticHints m - 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 - 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 - 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] - 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 - TcRnCannotDefaultConcrete{} - -> [SuggestAddTypeSignatures UnnamedBinding] - - -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 - -> DecoratedSDoc - -> DecoratedSDoc -messageWithInfoDiagnosticMessage unit_state ErrInfo{..} important = - let err_info' = map (pprWithUnitState unit_state) [errInfoContext, 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 . IdP (GhcPass p) -> IE (GhcPass p) -dodgy_msg_insert tc = IEThingAll noAnn ii - where - ii :: LIEWrappedName (IdP (GhcPass p)) - ii = noLocA (IEName $ 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 (tcTypeKind 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 ctxt (TcReportWithInfo msg (info :| infos)) = - vcat - ( pprTcSolverReportMsg ctxt msg - : pprTcSolverReportInfo ctxt info - : map (pprTcSolverReportInfo ctxt) infos ) -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 _ (CannotUnifyWithPolytype item tv1 ty2) = - 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) ] - where - what = text $ levelString $ - ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel -pprTcSolverReportMsg _ - (Mismatch { mismatch_ea = add_ea - , mismatch_item = item - , mismatch_ty1 = ty1 - , mismatch_ty2 = ty2 }) - = addArising (errorItemOrigin item) msg - 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 add_ea then "expected" else "" - , what ] - herald2 = conc [ "with" - , if is_repr then "that of" else "" - , if add_ea then ("actual " ++ what) else "" ] - - padding = length herald1 - length herald2 - - 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) -pprTcSolverReportMsg _ - (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 | tcIsConstraintKind 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) - - -pprTcSolverReportMsg ctxt - (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds - , teq_mismatch_item = item - , teq_mismatch_ty1 = ty1 - , teq_mismatch_ty2 = ty2 - , teq_mismatch_expected = exp - , teq_mismatch_actual = act - , teq_mismatch_what = mb_thing }) - = addArising orig $ pprWithExplicitKindsWhen ppr_explicit_kinds msg - where - msg - | isUnliftedTypeKind act, isLiftedTypeKind exp - = sep [ text "Expecting a lifted type, but" - , thing_msg mb_thing (text "an") (text "unlifted") ] - | isLiftedTypeKind act, isUnliftedTypeKind exp - = sep [ text "Expecting an unlifted type, but" - , thing_msg mb_thing (text "a") (text "lifted") ] - | tcIsLiftedTypeKind exp - = maybe_num_args_msg $$ - sep [ text "Expected a type, but" - , case mb_thing of - Nothing -> text "found something with kind" - Just thing -> quotes (ppr thing) <+> text "has kind" - , quotes (pprWithTYPE act) ] - | Just nargs_msg <- num_args_msg - , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig - = nargs_msg $$ pprTcSolverReportMsg ctxt ea_msg - | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $ - ea_looks_same ty1 ty2 exp act - , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig - = pprTcSolverReportMsg ctxt ea_msg - -- The mismatched types are /inside/ exp and act - | let mismatch_err = Mismatch False item ty1 ty2 - errs = case mk_ea_msg ctxt Nothing level orig of - Left ea_info -> [ mkTcReportWithInfo mismatch_err ea_info ] - Right ea_err -> [ mismatch_err, ea_err ] - = vcat $ map (pprTcSolverReportMsg ctxt) errs - - ct_loc = errorItemCtLoc item - orig = errorItemOrigin item - level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel - - thing_msg (Just thing) _ levity = quotes (ppr thing) <+> text "is" <+> levity - thing_msg Nothing an levity = text "got" <+> an <+> levity <+> text "type" - - 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 isVisibleBinder $ fst $ splitPiTys ty -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 _ (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 -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 (errorItemOrigin item) $ - sep [ text "Unbound implicit parameter" <> plural preds - , nest 2 (pprParendTheta preds) ] - else pprTcSolverReportMsg ctxt (CouldNotDeduce givens (item :| items) Nothing) - where - preds = map errorItemPred (item : items) -pprTcSolverReportMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra) - = main_msg $$ - case supplementary of - Left infos - -> vcat (map (pprTcSolverReportInfo ctxt) infos) - Right other_msg - -> pprTcSolverReportMsg ctxt other_msg - where - main_msg - | null useful_givens - = addArising orig (no_instance_msg <+> missing) - | otherwise - = vcat (addArising orig (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 - orig = errorItemOrigin item - 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] -> pprParendType wanted - _ -> pprTheta wanteds - -pprTcSolverReportMsg ctxt (AmbiguityPreventsSolvingCt item ambigs) = - pprTcSolverReportInfo ctxt (Ambiguity True ambigs) <+> - pprArising (errorItemOrigin 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 - [ pprTcSolverReportMsg ctxt 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 $ - pprTcSolverReportInfo ctxt (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) - , 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] - (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 :: TcSolverReportMsg - no_inst_msg - | lead_with_ambig - = AmbiguityPreventsSolvingCt item (ambig_kvs, ambig_tvs) - | otherwise - = 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 (tcTypeKind 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") - -pprTcSolverReportMsg (CEC {cec_encl = implics}) (OverlappingInstances item matches unifiers) = - vcat - [ addArising orig $ - (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, unifiers }) - , ppWhen (null matching_givens && isSingleton 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 (isSingleton 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 - orig = errorItemOrigin item - 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 matches unsafe_overlapped) = - vcat [ addArising orig (text "Unsafe overlapping instances for" - <+> pprType (mkClassPred clas tys)) - , sep [text "The matching instance is:", - nest 2 (pprInstance $ head matches)] - , 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 $ unsafe_overlapped]) - ] - ] - where - orig = errorItemOrigin item - pred = errorItemPred item - (clas, tys) = getClassPredTys pred - -{- ********************************************************************* -* * - 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 TcSolverReportInfo -* * -**********************************************************************-} - --- | Pretty-print an informational message, to accompany a 'TcSolverReportMsg'. -pprTcSolverReportInfo :: SolverReportErrCtxt -> TcSolverReportInfo -> SDoc -pprTcSolverReportInfo _ (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" -pprTcSolverReportInfo ctxt (TyVarInfo 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 -pprTcSolverReportInfo _ (NonInjectiveTyFam tc) = - text "NB:" <+> quotes (ppr tc) - <+> text "is a non-injective type family" -pprTcSolverReportInfo _ (ReportCoercibleMsg msg) = - pprCoercibleMsg msg -pprTcSolverReportInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) = - vcat - [ text "Expected:" <+> ppr exp - , text " Actual:" <+> ppr act ] -pprTcSolverReportInfo _ - (ExpectedActualAfterTySynExpansion - { ea_expanded_expected = exp - , ea_expanded_actual = act } ) - = vcat - [ text "Type synonyms expanded:" - , text "Expected type:" <+> ppr exp - , text " Actual type:" <+> ppr act ] -pprTcSolverReportInfo 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 (tcTypeKind cty1) - , ppr cty2 <+> dcolon <+> - ppr (tcTypeKind 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 (pprTcSolverReportInfo ctxt) infos - Right msg -> pprTcSolverReportMsg ctxt msg -pprTcSolverReportInfo _ (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 -pprTcSolverReportInfo ctxt (OccursCheckInterestingTyVars (tv :| tvs)) = - hang (text "Type variable kinds:") 2 $ - vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) - (tv:tvs)) - where - tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) - -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" ]) - -{- ********************************************************************* -* * - Outputting HoleError messages -* * -**********************************************************************-} - -pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc -pprHoleError _ (Hole { hole_ty, hole_occ = occ }) (OutOfScopeHole imp_errs) - = out_of_scope_msg $$ vcat (map ppr imp_errs) - where - herald | isDataOcc occ = 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 occ) - | otherwise = hang herald 2 (pp_occ_with_type occ 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_occ_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 = tcTypeKind 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 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_occ_with_type :: OccName -> Type -> SDoc -pp_occ_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 - , (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 :: CtOrigin -> SDoc --- Used for the main, top-level error message --- We've done special processing for TypeEq, KindEq, givens -pprArising (TypeEqOrigin {}) = empty -pprArising (KindEqOrigin {}) = empty -pprArising (AmbiguityCheckOrigin {}) = empty -- the "In the ambiguity check" context - -- is sufficient; this would just be - -- repetitive -pprArising orig | isGivenOrigin orig = empty - | otherwise = pprCtOrigin orig - --- Add the "arising from..." part to a message -addArising :: CtOrigin -> SDoc -> SDoc -addArising orig msg = hang msg 2 (pprArising orig) - -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 (ctLocOrigin 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')) - -{- ********************************************************************* -* * - 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 InvisArg w arg res) -- Look under c => t - = 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 [TcSolverReportInfo] TcSolverReportMsg -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 [TcSolverReportInfo] TcSolverReportMsg --- 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 mismatch = - Mismatch - { mismatch_ea = True - , mismatch_item = item - , mismatch_ty1 = exp - , mismatch_ty2 = act } - = Right $ - if expanded_syns - then mkTcReportWithInfo mismatch [ea_expanded] - else 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` tcView 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} -* * -************************************************************************ --} - -withHsDocContext :: HsDocContext -> SDoc -> SDoc -withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt - -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 +{-# 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) ] + 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." ] + + 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 + 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 + + 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 + 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 + + 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" 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,2768 +1,4025 @@ -{-# LANGUAGE GADTs #-} - -module GHC.Tc.Errors.Types ( - -- * Main types - TcRnMessage(..) - , TcRnMessageDetailed(..) - , ErrInfo(..) - , FixedRuntimeRepProvenance(..) - , pprFixedRuntimeRepProvenance - , ShadowedNameProvenance(..) - , RecordFieldPart(..) - , InjectivityErrReason(..) - , HasKinds(..) - , hasKinds - , SuggestUndecidableInstances(..) - , suggestUndecidableInstances - , 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(..), TcSolverReportInfo(..) - , CND_Extra(..) - , mkTcReportWithInfo - , FitsMbSuppressed(..) - , ValidHoleFits(..), noValidHoleFits - , HoleFitDispConfig(..) - , RelevantBindings(..), pprRelevantBindings - , NotInScopeError(..), mkTcRnNotInScope - , ImportError(..) - , HoleError(..) - , CoercibleMsg(..) - , PotentialInstances(..) - , UnsupportedCallConvention(..) - , ExpectedBackends(..) - , ArgOrResult(..) - ) where - -import GHC.Prelude - -import GHC.Hs -import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo) -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.FieldLabel (FieldLabelString) -import GHC.Types.ForeignCall (CLabelString) -import GHC.Types.Name (Name, OccName, getSrcLoc) -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) -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.Unit.Module.Name (ModuleName) -import GHC.Types.Basic -import GHC.Utils.Misc (filterOut) -import qualified GHC.LanguageExtensions as LangExt -import GHC.Data.FastString (FastString) - -import qualified Data.List.NonEmpty as NE -import Data.Typeable hiding (TyCon) -import qualified Data.Semigroup as Semigroup - -{- -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 bulletted 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 - --- | An error which might arise during typechecking/renaming. -data TcRnMessage where - {-| Simply wraps a generic 'Diagnostic' message @a@. It can be used by plugins - to provide custom diagnostic messages originated during typechecking/renaming. - -} - TcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> 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 - - {-| 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. - -> NE.NonEmpty SolverReportWithCtxt -- ^ The contradiction(s). - -> 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 :: Outputable var => var -> !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 occurrs 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 - -> !(Maybe HsDocContext) - -> 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 - - {-| 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 :: !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 - - {-| 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 - - {-| 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 -> 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 -> 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 -> 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 -> 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 ForeignImport - -> 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 ForeignImport -> 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 - - {- TcRnCannotDefaultConcrete is an error occurring when a concrete - type variable cannot be defaulted. - - Test cases: - T23153 - -} - TcRnCannotDefaultConcrete - :: !FixedRuntimeRepOrigin - -> TcRnMessage - --- | Specifies which backend code generators where expected for an FFI declaration -data ExpectedBackends - = COrAsmOrLlvm -- ^ C, Asm, or LLVM - | COrAsmOrLlvmOrInterp -- ^ C, Asm, LLVM, or interpreted - deriving Eq - --- | 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 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 - --- | 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 perhas 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 - -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_msgs :: [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. - } - -instance Semigroup SolverReport where - SolverReport main1 supp1 hints1 <> SolverReport main2 supp2 hints2 - = SolverReport (main1 ++ main2) (supp1 ++ supp2) (hints1 ++ hints2) - -instance Monoid SolverReport where - mempty = SolverReport [] [] [] - mappend = (Semigroup.<>) - --- | 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 evidence - , 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 - -- NB: this datatype is only a first step in refactoring GHC.Tc.Errors - -- to use the diagnostic infrastructure (TcRnMessage etc). - -- If you see possible improvements, please go right ahead! - - -- | Wrap a message with additional information. - -- - -- Prefer using the 'mkTcReportWithInfo' smart constructor - = TcReportWithInfo TcSolverReportMsg (NE.NonEmpty TcSolverReportInfo) - - -- | 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 - - -- | A type equality between a type variable and a polytype. - -- - -- Test cases: T12427a, T2846b, T10194, ... - | CannotUnifyWithPolytype ErrorItem TyVar Type - - -- | Couldn't unify two types or kinds. - -- - -- Example: - -- - -- 3 + 3# -- can't match a lifted type with an unlifted type - -- - -- Test cases: T1396, T8263, ... - | Mismatch - { mismatch_ea :: Bool -- ^ 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) - } - - -- | 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 'Mismatch' and 'KindMismatch' messages. - - -- | 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? - } - -- TODO: combine 'Mismatch' and 'TypeEqMismatch' messages. - - -- | A violation of the representation-polymorphism invariants. - -- - -- See 'FixedRuntimeRepErrorInfo' and 'FixedRuntimeRepContext' for more information. - | FixedRuntimeRepError [FixedRuntimeRepErrorInfo] - - -- | 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] - - -- | Trying to unify an untouchable variable, e.g. a variable from an outer scope. - -- - -- Test case: Simple14 - | UntouchableVariable TyVar Implication - - -- | An equality between two types is blocked on a kind equality - -- beteen their kinds. - -- - -- Test cases: none. - | BlockedEquality ErrorItem - - -- | 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) - - -- | Couldn't solve some Wanted constraints using the Givens. - -- This is the most commonly used constructor, used for generic - -- @"No instance for ..."@ and @"Could not deduce ... from"@ messages. - | 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 - } - - -- | 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 :: [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_matches :: [ClsInst] - , unsafeOverlapped :: [ClsInst] } - --- | 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 - --- | Additional information that can be appended to an existing 'TcSolverReportMsg'. -data TcSolverReportInfo - -- NB: this datatype is only a first step in refactoring GHC.Tc.Errors - -- to use the diagnostic infrastructure (TcRnMessage etc). - -- It would be better for these constructors to not be so closely tied - -- to the constructors of 'TcSolverReportMsg'. - -- If you see possible improvements, please go right ahead! - - -- | 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. - } - - -- | Specify some information about a type variable, - -- e.g. its 'SkolemInfo'. - | TyVarInfo TyVar - - -- | Remind the user that a particular type family is not injective. - | NonInjectiveTyFam TyCon - - -- | Explain why we couldn't coerce between two types. See 'CoercibleMsg'. - | ReportCoercibleMsg CoercibleMsg - - -- | 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. - | WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind) - - -- | Add some information to disambiguate errors in which - -- two 'Names' would otherwise appear to be identical. - -- - -- See Note [Disambiguating (X ~ X) errors]. - | SameOcc - { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package. - , sameOcc_lhs :: Name - , sameOcc_rhs :: Name } - - -- | Report some type variables that might be participating in an occurs-check failure. - | OccursCheckInterestingTyVars (NE.NonEmpty TyVar) - --- | 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 doesnt 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 - --- | 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] - } - --- | Append additional information to a `TcSolverReportMsg`. -mkTcReportWithInfo :: TcSolverReportMsg -> [TcSolverReportInfo] -> TcSolverReportMsg -mkTcReportWithInfo msg [] - = msg -mkTcReportWithInfo (TcReportWithInfo msg (prev NE.:| prevs)) infos - = TcReportWithInfo msg (prev NE.:| prevs ++ infos) -mkTcReportWithInfo msg (info : infos) - = TcReportWithInfo msg (info NE.:| infos) - --- | 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's it's here for the moment as it's needed in "GHC.Tc.Errors". -pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) = - ppUnless (null bds) $ - hang (text "Relevant bindings include") - 2 (vcat (map ppr_binding 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)))] - -discardMsg :: SDoc -discardMsg = text "(Some bindings suppressed;" <+> - text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" - --- | Stores the information to be reported in a representation-polymorphism --- error message. -data FixedRuntimeRepErrorInfo - = FRR_Info - { frr_info_origin :: FixedRuntimeRepOrigin - -- ^ What is the original type we checked for - -- representation-polymorphism, and what specific - -- check did we perform? - , frr_info_not_concrete :: Maybe (TcTyVar, TcType) - -- ^ Which non-concrete type did we try to - -- unify this concrete type variable with? - } - -{- -************************************************************************ -* * -\subsection{Contexts for renaming errors} -* * -************************************************************************ --} - --- AZ:TODO: Change these all to be Name instead of RdrName. --- Merge TcType.UserTypeContext in to it. -data HsDocContext - = TypeSigCtx SDoc - | StandaloneKindSigCtx SDoc - | PatCtx - | SpecInstSigCtx - | DefaultDeclCtx - | ForeignDeclCtx (LocatedN RdrName) - | DerivDeclCtx - | RuleCtx FastString - | TyDataCtx (LocatedN RdrName) - | TySynCtx (LocatedN RdrName) - | TyFamilyCtx (LocatedN RdrName) - | FamPatCtx (LocatedN RdrName) -- The patterns of a type/data family instance - | ConDeclCtx [LocatedN Name] - | ClassDeclCtx (LocatedN RdrName) - | ExprWithTySigCtx - | TypBrCtx - | HsTypeCtx - | HsTypePatCtx - | GHCiCtx - | SpliceTypeCtx (LHsType GhcPs) - | ClassInstanceCtx - | GenericCtx SDoc +{-# 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 + + {- 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 + + 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 evidence + , 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 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 @@ -48,7 +48,7 @@ ; return [] } tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation -tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do +tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do -- Work out what the full target of this annotation was mod <- getModule let target = annProvenanceToTarget mod provenance 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,13 +2,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- % (c) The University of Glasgow 2006 @@ -22,21 +19,14 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) -import GHC.Types.Basic ( Arity, ExprOrPat(Expression) ) -import GHC.Types.Id ( idArity, idName, hasNoBinding ) -import GHC.Types.Name ( isWiredInName ) import GHC.Types.Var import GHC.Builtin.Types ( multiplicityTy ) -import GHC.Core.ConLike ( ConLike(..) ) -import GHC.Core.DataCon ( dataConRepArity - , isNewDataCon, isUnboxedSumDataCon, isUnboxedTupleDataCon ) 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.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType @@ -48,6 +38,7 @@ 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 ) @@ -94,7 +85,7 @@ * When QL is done, we don't need to turn the un-filled-in instantiation variables into unification variables -- they - already /are/ unification varibles! See also + 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. @@ -224,7 +215,7 @@ It treats application chains (f e1 @ty e2) specially: -* So we can report errors like "in the third arument of a call of f" +* 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. @@ -238,7 +229,7 @@ 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 the application after + and returns a Rebuilder to re-assemble the application after typechecking. The "list of arguments" is [HsExprArg], described in Note [HsExprArg]. @@ -297,6 +288,7 @@ 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -331,28 +323,16 @@ -- See Note [tcApp: typechecking applications] tcApp rn_expr exp_res_ty | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr - = do { (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args + = 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 - -- Check for representation polymorphism in the case that - -- the head of the application is a primop or data constructor - -- which has argument types that are representation-polymorphic. - -- This amounts to checking that the leftover argument types, - -- up until the arity, are not representation-polymorphic, - -- so that we can perform eta-expansion later without introducing - -- representation-polymorphic binders. - -- - -- See Note [Checking for representation-polymorphic built-ins] - ; traceTc "tcApp FRR" $ - vcat - [ text "tc_fun =" <+> ppr tc_fun - , text "inst_args =" <+> ppr inst_args - , text "app_res_rho =" <+> ppr app_res_rho ] - ; hasFixedRuntimeRep_remainingValArgs inst_args app_res_rho tc_fun - -- Quick look at result ; app_res_rho <- if do_ql then quickLookResultType delta app_res_rho exp_res_ty @@ -372,249 +352,56 @@ = 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 $ - tcSubTypeNC (exprCtOrigin rn_expr) GenSigCtxt (Just $ HsExprRnThing rn_expr) - app_res_rho exp_res_ty - -- Need tcSubType because of the possiblity of deep subsumption. - -- app_res_rho and exp_res_ty are both rho-types, so without - -- deep subsumption unifyExpectedType would be sufficient + 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) } - ; 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 "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 ]) } + 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 cases for tagToEnum#. + -- 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 return (rebuildHsApps tc_fun fun_ctxt tc_args) + 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) } -{- -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 like unsafeCoerce#, with compulsory unfoldings. -2. Primops, such as raise#. -3. Newtype constructors with `UnliftedNewtypes` that 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 three 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 hasFixedRuntimeRep_remainingValArgs -function, which computes the types of the remaining value arguments, and checks -that each of these have a fixed runtime representation using hasFixedRuntimeRep. - -Wrinkles - -* Because of Note [Typechecking data constructors] in GHC.Tc.Gen.Head, - we desugar a representation-polymorphic data constructor application - like this: - (/\(r :: RuntimeRep) (a :: TYPE r) \(x::a). K r a x) @LiftedRep Int 4 - That is, a rep-poly lambda applied to arguments that instantiate it in - a rep-mono way. It's a bit like a compulsory unfolding that has been - inlined, but not yet beta-reduced. - - Because we want to accept this, we switch off Lint's representation - polymorphism checks when Lint checks the output of the desugarer; - see the lf_check_fixed_rep flag in GHC.Core.Lint.lintCoreBindings. - - We then rely on the simple optimiser to beta reduce these - representation-polymorphic lambdas (e.g. GHC.Core.SimpleOpt.simple_app). - -* 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} - --} - --- | Check for representation-polymorphism in the remaining argument types --- of a variable or data constructor, after it has been instantiated and applied to some arguments. --- --- See Note [Checking for representation-polymorphic built-ins] -hasFixedRuntimeRep_remainingValArgs :: [HsExprArg 'TcpInst] -> TcRhoType -> HsExpr GhcTc -> TcM () -hasFixedRuntimeRep_remainingValArgs applied_args app_res_rho = \case - - 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 - -> check_thing fun_id 1 (FRRNoBindingResArg 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 - -> check_thing fun_id (idArity fun_id) (FRRNoBindingResArg 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 - -> check_thing con (dataConRepArity con) (FRRDataConArg Expression con) - - _ -> return () - - where - 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 - - arg_tys :: [(Type,AnonArgFlag)] - 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. - - check_thing :: Outputable thing - => thing - -> Arity - -> (Int -> FixedRuntimeRepContext) - -> TcM () - check_thing thing arity mk_frr_orig = do - traceTc "tcApp remainingValArgs check_thing" (debug_msg thing arity) - go (nb_applied_vis_val_args + 1) (nb_applied_val_args + 1) arg_tys - where - go :: 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 we don't check too many argument types - -> [(Type, AnonArgFlag)] -- run-time argument types - -> TcM () - go _ i_val _ - | i_val > arity - = return () - go _ _ [] - -- Should never happen: it would mean that the arity is higher - -- than the number of arguments apparent from the type - = pprPanic "hasFixedRuntimeRep_remainingValArgs" (debug_msg thing arity) - go i_visval !i_val ((arg_ty, af) : tys) - = case af of - InvisArg -> - go i_visval (i_val + 1) tys - VisArg -> do - hasFixedRuntimeRep_syntactic (mk_frr_orig i_visval) arg_ty - go (i_visval + 1) (i_val + 1) tys - - -- A message containing all the relevant info, in case this functions - -- needs to be debugged again at some point. - debug_msg :: Outputable thing => thing -> Arity -> SDoc - debug_msg thing arity = - vcat - [ text "thing =" <+> ppr thing - , text "arity =" <+> ppr arity - , text "applied_args =" <+> ppr applied_args - , text "nb_applied_val_args =" <+> ppr nb_applied_val_args - , text "arg_tys =" <+> ppr arg_tys ] - -------------------- wantQuickLook :: HsExpr GhcRn -> TcM Bool --- GHC switches on impredicativity all the time for ($) wantQuickLook (HsVar _ (L _ f)) | getUnique f `elem` quickLookKeys = return True wantQuickLook _ = xoptM LangExt.ImpredicativeTypes @@ -649,6 +436,7 @@ ---------------- + tcValArgs :: Bool -- Quick-look on? -> [HsExprArg 'TcpInst] -- Actual argument -> TcM [HsExprArg 'TcpTc] -- Resulting argument @@ -656,9 +444,9 @@ = mapM tc_arg args where tc_arg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpTc) - tc_arg (EPrag l p) = return (EPrag l (tcExprPrag p)) - tc_arg (EWrap w) = return (EWrap w) - tc_arg (ETypeArg l hs_ty ty) = return (ETypeArg l hs_ty ty) + tc_arg (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 }) @@ -698,9 +486,13 @@ = 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 - ; let arg' = mkHsWrapCo co $ rebuildHsApps inner_fun fun_ctxt tc_args - ; traceTc "tcEValArgQL }" empty + + ; 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') } {- ********************************************************************* @@ -716,7 +508,7 @@ tcInstFun :: Bool -- True <=> Do quick-look -> Bool -- False <=> Instantiate only /inferred/ variables at the end - -- so may return a sigma-typex + -- 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 @@ -737,18 +529,9 @@ , text "do_ql" <+> ppr do_ql ]) ; go emptyVarSet [] [] fun_sigma rn_args } where - fun_loc = appCtxtLoc fun_ctxt fun_orig = exprCtOrigin (case fun_ctxt of VAExpansion e _ -> e VACall e _ _ -> e) - set_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 -- Count value args only when complaining about a function -- applied to too many value args @@ -760,7 +543,7 @@ HsUnboundVar {} -> True _ -> False - inst_all, inst_inferred, inst_none :: ArgFlag -> Bool + inst_all, inst_inferred, inst_none :: ForAllTyFlag -> Bool inst_all (Invisible {}) = True inst_all Required = False @@ -770,7 +553,7 @@ inst_none _ = False - inst_fun :: [HsExprArg 'TcpRn] -> ArgFlag -> Bool + inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool inst_fun [] | inst_final = inst_all | otherwise = inst_none -- Using `inst_none` for `:type` avoids @@ -789,7 +572,7 @@ -- go: If fun_ty=kappa, look it up in Theta go delta acc so_far fun_ty args - | Just kappa <- tcGetTyVar_maybe fun_ty + | Just kappa <- getTyVar_maybe fun_ty , kappa `elemVarSet` delta = do { cts <- readMetaTyVar kappa ; case cts of @@ -807,9 +590,9 @@ | (tvs, body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty , (theta, body2) <- tcSplitPhiTy body1 , not (null tvs && null theta) - = do { (inst_tvs, wrap, fun_rho) <- set_fun_ctxt $ + = do { (inst_tvs, wrap, fun_rho) <- addHeadCtxt fun_ctxt $ instantiateSigma fun_orig tvs theta body2 - -- set_fun_ctxt: important for the class constraints + -- 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 } @@ -828,19 +611,19 @@ = go1 delta (EPrag sp prag : acc) so_far fun_ty args -- Rule ITYARG from Fig 4 of the QL paper - go1 delta acc so_far fun_ty ( ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty } + 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_hs_ty = hs_ty, eva_ty = ty_arg } + ; 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 <- tcGetTyVar_maybe fun_ty + | 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 @@ -867,8 +650,8 @@ ; let delta' = delta `extendVarSetList` (res_nu:arg_nus) arg_tys = mkTyVarTys arg_nus res_ty = mkTyVarTy res_nu - fun_ty' = mkVisFunTys (zipWithEqual "tcInstFun" mkScaled mults arg_tys) res_ty - co_wrap = mkWpCastN (mkTcGReflLeftCo Nominal fun_ty' kind_co) + 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 @@ -898,19 +681,26 @@ addArgCtxt :: AppCtxt -> LHsExpr GhcRn -> TcM a -> TcM a --- Adds a "In the third argument of f, namely blah" --- context, unless we are in generated code, in which case --- use "In the expression: arg" +-- 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 (VACall fun arg_no _) (L arg_loc arg) thing_inside - = setSrcSpanA arg_loc $ - addErrCtxt (funAppCtxt fun arg arg_no) $ - thing_inside +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 -addArgCtxt (VAExpansion {}) (L arg_loc arg) thing_inside - = setSrcSpanA arg_loc $ - addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated - thing_inside + _ -> setSrcSpanA arg_loc $ + addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated + thing_inside } {- ********************************************************************* * * @@ -925,7 +715,7 @@ -- The function type has already had its Inferred binders instantiated tcVTA fun_ty hs_ty | Just (tvb, inner_ty) <- tcSplitForAllTyVarBinder_maybe fun_ty - , binderArgFlag tvb == Specified + , 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] @@ -940,11 +730,12 @@ 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 [ppr tv, debugPprType kind - , debugPprType ty_arg - , debugPprType (tcTypeKind ty_arg) - , debugPprType inner_ty - , debugPprType insted_ty ]) + ; 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 @@ -967,7 +758,7 @@ 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 TyCoBinder in terms] +The ice is thin; c.f. Note [No Required PiTyBinder in terms] in GHC.Core.TyCo.Rep. Note [VTA for out-of-scope functions] @@ -1085,7 +876,7 @@ -- 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 <- tcGetTyVar_maybe arg_ty + | Just kappa <- getTyVar_maybe arg_ty , kappa `elemVarSet` delta = do { info <- readMetaTyVar kappa ; case info of @@ -1199,8 +990,8 @@ -- Now, and only now, expand synonyms go bvs rho1 rho2 - | Just rho1 <- tcView rho1 = go bvs rho1 rho2 - | Just rho2 <- tcView rho2 = 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 @@ -1210,25 +1001,25 @@ -- Decompose (arg1 -> res1) ~ (arg2 -> res2) -- and (c1 => res1) ~ (c2 => res2) - -- But for the latter we only learn instantiation info from t1~t2 + -- 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 - = do { when (af1 == VisArg) $ - do { go bvs arg1 arg2; go bvs mult1 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 tcRepSplitAppTy here, which does not split (c => t) + -- Also NB tcSplitAppTyNoView here, which does not split (c => t) go bvs (AppTy t1a t1b) ty2 - | Just (t2a, t2b) <- tcRepSplitAppTy_maybe 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) <- tcRepSplitAppTy_maybe ty1 + | Just (t1a, t1b) <- tcSplitAppTyNoView_maybe ty1 = do { go bvs t1a t2a; go bvs t1b t2b } go (bvs1, bvs2) (ForAllTy bv1 ty1) (ForAllTy bv2 ty2) @@ -1269,7 +1060,7 @@ ; writeMetaTyVar kappa (mkCastTy ty2 co) } | otherwise - = return () -- Occurs-check or forall-bound varialbe + = return () -- Occurs-check or forall-bound variable {- Note [Actual unification in qlUnify] @@ -1294,7 +1085,7 @@ * 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 herterogeneous equalities; see Note + the main constraint solver for heterogeneous equalities; see Note [Equalities with incompatible kinds] in Solver.Canonical Why different? Because: @@ -1424,17 +1215,19 @@ check_enumeration res_ty rep_tc ; let rep_ty = mkTyConApp rep_tc rep_args tc_fun' = mkHsWrap (WpTyApp rep_ty) tc_fun - tc_expr = rebuildHsApps tc_fun' fun_ctxt [val_arg] - df_wrap = mkWpCastR (mkTcSymCo coi) + 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 = return (rebuildHsApps tc_fun fun_ctxt tc_args) + 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') @@ -1446,4 +1239,4 @@ ********************************************************************* -} tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc -tcExprPrag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann +tcExprPrag (HsPragSCC x1 ann) = HsPragSCC x1 ann 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 @@ -33,6 +33,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence import GHC.Core.Multiplicity +import GHC.Core.Coercion import GHC.Types.Id( mkLocalId ) import GHC.Tc.Utils.Instantiate import GHC.Builtin.Types @@ -104,8 +105,7 @@ ; (pat', cmd') <- newArrowScope $ tcCheckPat (ArrowMatchCtxt ProcExpr) pat (unrestricted arg_ty) $ tcCmdTop cmd_env names' cmd (unitTy, res_ty) - ; let res_co = mkTcTransCo co - (mkTcAppCo co1 (mkTcNomReflCo res_ty)) + ; let res_co = co `mkTransCo` mkAppCo co1 (mkNomReflCo res_ty) ; return (pat', cmd', res_co) } {- @@ -339,7 +339,7 @@ -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc)) tcCmdMatchLambda env ctxt - mg@MG { mg_alts = L l matches } + 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 @@ -349,7 +349,7 @@ ; let arg_tys' = map unrestricted arg_tys mg' = mg { mg_alts = L l matches' - , mg_ext = MatchGroupTc arg_tys' res_ty } + , mg_ext = MatchGroupTc arg_tys' res_ty origin } ; return (mkWpCastN co, mg') } where @@ -383,11 +383,11 @@ matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcTypeFRR], TcType) matchExpectedCmdArgs 0 ty - = return (mkTcNomReflCo ty, [], ty) + = return (mkNomReflCo ty, [], ty) matchExpectedCmdArgs n ty = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2 - ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) } + ; return (mkTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) } {- ************************************************************************ @@ -424,7 +424,8 @@ , recS_rec_ids = rec_names }) res_ty thing_inside = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith (\n p -> mkLocalId n Many p) tup_names tup_elt_tys -- Many because it's a recursive definition + ; let tup_ids = zipWith (\n p -> mkLocalId n ManyTy p) tup_names tup_elt_tys + -- Many because it's a recursive definition ; tcExtendIdEnv tup_ids $ do { (stmts', tup_rets) <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> @@ -435,7 +436,7 @@ -- NB: The rec_ids for the recursive things -- already scope over this part. This binding may shadow -- some of them with polymorphic things with the same Name - -- (see Note [RecStmt] in GHC.Hs.Expr) + -- (see Note [How RecStmt works] in Language.Haskell.Syntax.Expr) ; let rec_ids = takeList rec_names tup_ids ; later_ids <- tcLookupLocalIds later_names 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 @@ -28,10 +28,11 @@ import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) import GHC.Types.Tickish (CoreTickish, GenTickish (..)) -import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) +import GHC.Types.CostCentre (mkUserCC, mkDeclCCFlavour) import GHC.Driver.Session import GHC.Data.FastString import GHC.Hs + import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) @@ -42,45 +43,53 @@ import GHC.Tc.Solver import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint -import GHC.Core.Predicate + 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.Core.Reduction ( Reduction(..) ) import GHC.Core.Multiplicity import GHC.Core.FamInstEnv( normaliseType ) -import GHC.Tc.Instance.Family( tcGetFamInstEnvs ) import GHC.Core.Class ( Class ) -import GHC.Tc.Utils.TcType +import GHC.Core.Coercion( mkSymCo ) import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy) -import GHC.Builtin.Types ( mkBoxedTupleTy ) +import GHC.Core.TyCo.Ppr( pprTyVars ) + +import GHC.Builtin.Types ( mkConstraintTupleTy ) import GHC.Builtin.Types.Prim +import GHC.Unit.Module + import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.Var as Var import GHC.Types.Var.Set -import GHC.Types.Var.Env( TidyEnv ) -import GHC.Unit.Module +import GHC.Types.Var.Env( TidyEnv, TyVarEnv, mkVarEnv, lookupVarEnv ) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.SrcLoc -import GHC.Data.Bag + import GHC.Utils.Error -import GHC.Data.Graph.Directed -import GHC.Data.Maybe 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.Tc.Validity (checkValidType, checkEscapingKind) import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Types.Unique.Set import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.Bag +import GHC.Data.Graph.Directed +import GHC.Data.Maybe + import Control.Monad import Data.Foldable (find) @@ -208,7 +217,7 @@ -- 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)) + 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 @@ -270,7 +279,7 @@ ; let p = mkStrLitTy $ hsIPNameFS ip ; ip_id <- newDict ipClass [ p, ty ] ; expr' <- tcCheckMonoExpr expr ty - ; let d = mapLoc (toDict ipClass p ty) expr' + ; 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`. @@ -505,7 +514,7 @@ ; traceTc "Generalisation plan" (ppr plan) ; result@(_, poly_ids) <- case plan of NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list - InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list + InferGen -> tcPolyInfer rec_tc prag_fn sig_fn bind_list CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind ; mapM_ (\ poly_id -> @@ -539,7 +548,7 @@ , Just poly_id <- completeSigPolyId_maybe sig = poly_id | otherwise - = mkLocalId name Many forall_a_a + = mkLocalId name ManyTy forall_a_a forall_a_a :: TcType -- At one point I had (forall r (a :: TYPE r). a), but of course @@ -634,8 +643,8 @@ ; let bind' = FunBind { fun_id = L nm_loc poly_id2 , fun_matches = matches' - , fun_ext = wrap_gen <.> wrap_res - , fun_tick = tick } + , fun_ext = (wrap_gen <.> wrap_res, tick) + } export = ABE { abe_wrap = idHsWrapper , abe_poly = poly_id @@ -658,7 +667,7 @@ funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] -> TcM [CoreTickish] funBindTicks loc fun_id mod sigs - | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] + | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ] -- this can only be a singleton list, as duplicate pragmas are rejected -- by the renamer , let cc_str @@ -666,9 +675,9 @@ = sl_fs $ unLoc cc_str | otherwise = getOccFS (Var.varName fun_id) - cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str + cc_name = concatFS [moduleNameFS (moduleName mod), fsLit ".", cc_str] = do - flavour <- DeclCC <$> getCCIndexTcM cc_name + flavour <- mkDeclCCFlavour <$> getCCIndexTcM cc_name let cc = mkUserCC cc_name mod loc flavour return [ProfNote cc True True] | otherwise @@ -698,20 +707,20 @@ :: RecFlag -- Whether it's recursive after breaking -- dependencies based on type signatures -> TcPragEnv -> TcSigFun - -> Bool -- True <=> apply the monomorphism restriction -> [LHsBind GhcRn] -> TcM (LHsBinds GhcTc, [TcId]) -tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list +tcPolyInfer 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 + ; traceTc "tcPolyInfer" (ppr apply_mr $$ ppr (map mbi_sig mono_infos)) + ; let name_taus = [ (mbi_poly_name info, idType (mbi_mono_id info)) | info <- mono_infos ] sigs = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ] - infer_mode = if mono then ApplyMR else NoRestrictions - - ; mapM_ (checkOverloadedSig mono) sigs + infer_mode = if apply_mr then ApplyMR else NoRestrictions ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted) ; ((qtvs, givens, ev_binds, insoluble), residual) @@ -740,6 +749,59 @@ ; return (unitBag abs_bind, poly_ids) } -- poly_ids are guaranteed zonked by mkExport +checkMonomorphismRestriction :: [MonoBindInfo] -> [LHsBind GhcRn] -> TcM Bool +-- True <=> apply the MR +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 + ; 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 ] + + is_mono_psig (TISI { sig_inst_theta = theta, sig_inst_wcx = mb_extra_constraints }) + = null theta && isNothing mb_extra_constraints + + -- The Haskell 98 monomorphism restriction + 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) + + 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) + +checkOverloadedSig :: TcIdSigInst -> 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) $ + failWith $ TcRnOverloadedSig orig_sig + | otherwise + = return () + -------------- mkExport :: TcPragEnv -> WantedConstraints -- residual constraints, already emitted (for errors only) @@ -851,7 +913,7 @@ -- do this check; otherwise (#14000) we may report an ambiguity -- error for a rather bogus type. - ; return (mkLocalId poly_name Many inferred_poly_ty) } + ; return (mkLocalId poly_name ManyTy inferred_poly_ty) } chooseInferredQuantifiers :: WantedConstraints -- residual constraints @@ -882,7 +944,8 @@ ; let psig_qtvs = map binderVar psig_qtv_bndrs psig_qtv_set = mkVarSet psig_qtvs psig_qtv_prs = psig_qtv_nms `zip` psig_qtvs - + psig_bndr_map :: TyVarEnv InvisTVBinder + psig_bndr_map = mkVarEnv [ (binderVar tvb, tvb) | tvb <- psig_qtv_bndrs ] -- Check whether the quantified variables of the -- partial signature have been unified together @@ -898,32 +961,35 @@ ; annotated_theta <- zonkTcTypes annotated_theta ; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx + -- NB: free_tvs includes tau_tvs - ; let keep_me = free_tvs `unionVarSet` psig_qtv_set - final_qtvs = [ mkTyVarBinder vis tv - | tv <- qtvs -- Pulling from qtvs maintains original order - , tv `elemVarSet` keep_me - , let vis = case lookupVarBndr tv psig_qtv_bndrs of - Just spec -> spec - Nothing -> InferredSpec ] + ; let (_,final_qtvs) = foldr (choose_qtv psig_bndr_map) (free_tvs, []) qtvs + -- Pulling from qtvs maintains original order + -- NB: qtvs is already in dependency order + ; traceTc "chooseInferredQuantifiers" $ + vcat [ text "qtvs" <+> pprTyVars qtvs + , text "psig_qtv_bndrs" <+> ppr psig_qtv_bndrs + , text "free_tvs" <+> ppr free_tvs + , text "final_tvs" <+> ppr final_qtvs ] + ; return (final_qtvs, my_theta) } where - report_dup_tyvar_tv_err (n1,n2) - = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty) - - report_mono_sig_tv_err (n,tv) - = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty) - where - m_unif_ty = listToMaybe - [ rhs - -- recall that residuals are always implications - | residual_implic <- bagToList $ wc_impl residual - , residual_ct <- bagToList $ wc_simple (ic_wanted residual_implic) - , let residual_pred = ctPred residual_ct - , Just (Nominal, lhs, rhs) <- [ getEqPredTys_maybe residual_pred ] - , Just lhs_tv <- [ tcGetTyVar_maybe lhs ] - , lhs_tv == tv ] + choose_qtv :: TyVarEnv InvisTVBinder -> TcTyVar + -> (TcTyVarSet, [InvisTVBinder]) -> (TcTyVarSet, [InvisTVBinder]) + -- Pick which of the original qtvs should be retained + -- Keep it if (a) it is mentioned in the body of the type (free_tvs) + -- (b) it is a forall'd variable of the partial signature (psig_qtv_bndrs) + -- (c) it is mentioned in the kind of a retained qtv (#22065) + choose_qtv psig_bndr_map tv (free_tvs, qtvs) + | Just psig_bndr <- lookupVarEnv psig_bndr_map tv + = (free_tvs', psig_bndr : qtvs) + | tv `elemVarSet` free_tvs + = (free_tvs', mkTyVarBinder InferredSpec tv : qtvs) + | otherwise -- Do not pick it + = (free_tvs, qtvs) + where + free_tvs' = free_tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType -> TcM (VarSet, TcThetaType) @@ -949,12 +1015,12 @@ -- NB: my_theta already includes all the annotated constraints ; diff_theta <- findInferredDiff annotated_theta my_theta - ; case tcGetCastedTyVar_maybe wc_var_ty of + ; case getCastedTyVar_maybe wc_var_ty of -- 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 (mk_ctuple diff_theta - `mkCastTy` mkTcSymCo wc_co) + Just (wc_var, wc_co) -> writeMetaTyVar wc_var (mkConstraintTupleTy diff_theta + `mkCastTy` mkSymCo wc_co) Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty) ; traceTc "completeTheta" $ @@ -967,10 +1033,22 @@ -- Return (annotated_theta ++ diff_theta) -- See Note [Extra-constraints wildcards] - mk_ctuple preds = mkBoxedTupleTy preds - -- Hack alert! See GHC.Tc.Gen.HsType: - -- Note [Extra-constraint holes in partial type signatures] + report_dup_tyvar_tv_err (n1,n2) + = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty) + report_mono_sig_tv_err (n,tv) + = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty) + where + m_unif_ty = listToMaybe + [ rhs + -- recall that residuals are always implications + | residual_implic <- bagToList $ wc_impl residual + , residual_ct <- bagToList $ wc_simple (ic_wanted residual_implic) + , let residual_pred = ctPred residual_ct + , Just (Nominal, lhs, rhs) <- [ getEqPredTys_maybe residual_pred ] + , Just lhs_tv <- [ getTyVar_maybe lhs ] + , lhs_tv == tv ] + chooseInferredQuantifiers _ _ _ _ (Just (TISI { sig_inst_sig = sig@(CompleteSig {}) })) = pprPanic "chooseInferredQuantifiers" (ppr sig) @@ -995,22 +1073,6 @@ ; let dia = TcRnPolymorphicBinderMissingSig (idName id) tidy_ty ; addDiagnosticTcM (env1, dia) } -checkOverloadedSig :: Bool -> TcIdSigInst -> 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 monomorphism_restriction_applies sig - | not (null (sig_inst_theta sig)) - , monomorphism_restriction_applies - , let orig_sig = sig_inst_sig sig - = setSrcSpan (sig_loc orig_sig) $ - failWith $ TcRnOverloadedSig orig_sig - | otherwise - = return () - {- Note [Partial type signatures and generalisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If /any/ of the signatures in the group is a partial type signature @@ -1036,14 +1098,33 @@ doesn't seem much point. Indeed, adding a partial type signature is a way to get per-binding inferred generalisation. -We apply the MR if /all/ of the partial signatures lack a context. -In particular (#11016): +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 @@ -1077,7 +1158,7 @@ We get [W] Foo (), [W] Applicative f. When we do pickCapturedPreds in choose_psig_context, we'll discard Foo ()! Usually would not quantify over such (closed) predicates. So my_theta will be (Applicative f). But we really -do want to quantify over (Foo ()) -- it was speicfied by the programmer. +do want to quantify over (Foo ()) -- it was specified by the programmer. Solution: always return annotated_theta (user-specified) plus the extra piece diff_theta. @@ -1095,22 +1176,6 @@ or multi-parameter type classes - an inferred type that includes unboxed tuples -Note [Inferred type with escaping kind] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Check for an inferred type with an escaping kind; e.g. #23051 - forall {k} {f :: k -> RuntimeRep} {g :: k} {a :: TYPE (f g)}. a -where the kind of the body of the forall mentions `f` and `g` which -are bound by the forall. No no no. - -This check, mkInferredPolyId, is really in the wrong place: -`inferred_poly_ty` doesn't obey the PKTI and it would be better not to -generalise it in the first place; see #20686. But for now it works. - -I considered adjusting the generalisation in GHC.Tc.Solver to directly check for -escaping kind variables; instead, promoting or defaulting them. But that -gets into the defaulting swamp and is a non-trivial and unforced -change, so I have left it alone for now. - Note [Impedance matching] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1200,20 +1265,18 @@ , 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 + <- tcInfer $ \ exp_ty -> 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 Many rhs_ty' + ; mono_id <- newLetBndr no_gen name ManyTy rhs_ty' ; return (unitBag $ L b_loc $ FunBind { fun_id = L nm_loc mono_id, fun_matches = matches', - fun_ext = co_fn, fun_tick = [] }, + fun_ext = (co_fn, []) }, [MBI { mbi_poly_name = name , mbi_sig = Nothing , mbi_mono_id = mono_id }]) } @@ -1224,9 +1287,7 @@ | 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 - -- a fixed runtime rep. See #23176 + do { (grhss', pat_ty) <- tcInfer $ \ exp_ty -> tcGRHSsPat grhss exp_ty ; let exp_pat_ty :: Scaled ExpSigmaTypeFRR @@ -1236,7 +1297,7 @@ ; return ( unitBag $ L b_loc $ PatBind { pat_lhs = pat', pat_rhs = grhss' - , pat_ext = pat_ty, pat_ticks = ([],[]) } + , pat_ext = (pat_ty, ([],[])) } , mbis ) } where @@ -1294,7 +1355,7 @@ (combine head ids), and use that to tell us the polymorphic types of x and y. -We don't need to check -XImpredicativeTypes beucase without it +We don't need to check -XImpredicativeTypes because without it these types like [forall a. a->a] are illegal anyway, so this special case code only really has an effect if -XImpredicativeTypes is on. Small exception: @@ -1368,7 +1429,7 @@ | otherwise -- No type signature = do { mono_ty <- newOpenFlexiTyVarTy - ; mono_id <- newLetBndr no_gen name Many mono_ty + ; 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. @@ -1385,7 +1446,7 @@ [ (mbi_poly_name mbi, mbi_mono_id mbi) | mbi <- sig_mbis ] - -- See Note [Existentials in pattern bindings] + -- See Note [Typechecking pattern bindings] ; ((pat', nosig_mbis), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $ tcInferFRR FRRPatBind $ \ exp_ty -> @@ -1439,7 +1500,7 @@ | CompleteSig { 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 Many tau + = newLetBndr no_gen name ManyTy tau -- Binders with a signature are currently always of multiplicity -- Many. Because they come either from toplevel, let, or where -- declarations. Which are all unrestricted currently. @@ -1455,8 +1516,8 @@ matches (mkCheckExpType $ idType mono_id) ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id , fun_matches = matches' - , fun_ext = co_fn - , fun_tick = [] } ) } + , fun_ext = (co_fn, []) + } ) } tcRhs (TcPatBind infos pat' grhss pat_ty) = -- When we are doing pattern bindings we *don't* bring any scoped @@ -1469,8 +1530,7 @@ tcGRHSsPat grhss (mkCheckExpType pat_ty) ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss' - , pat_ext = pat_ty - , pat_ticks = ([],[]) } )} + , pat_ext = (pat_ty, ([],[])) } )} tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a tcExtendTyVarEnvForRhs Nothing thing_inside @@ -1636,79 +1696,55 @@ = NoGen -- No generalisation, no AbsBinds | InferGen -- Implicit generalisation; there is an AbsBinds - Bool -- True <=> apply the MR; generalise only unconstrained type vars - | CheckGen (LHsBind GhcRn) TcIdSigInfo - -- One FunBind with a signature - -- Explicit generalisation + | CheckGen -- One FunBind with a complete signature: + (LHsBind GhcRn) -- do explicit generalisation + TcIdSigInfo -- Always CompleteSig -- A consequence of the no-AbsBinds choice (NoGen) is that there is -- no "polymorphic Id" and "monmomorphic Id"; there is just the one instance Outputable GeneralisationPlan where ppr NoGen = text "NoGen" - ppr (InferGen b) = text "InferGen" <+> ppr b + ppr InferGen = text "InferGen" ppr (CheckGen _ s) = text "CheckGen" <+> ppr s decideGeneralisationPlan :: DynFlags -> TopLevelFlag -> IsGroupClosed -> TcSigFun -> [LHsBind GhcRn] -> GeneralisationPlan decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds - | has_partial_sigs = InferGen (and partial_sig_mrs) | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig - | do_not_generalise = NoGen - | otherwise = InferGen mono_restriction + | generalise_binds = InferGen + | otherwise = NoGen where - binds = map unLoc lbinds - - partial_sig_mrs :: [Bool] - -- One for each partial signature (so empty => no partial sigs) - -- The Bool is True if the signature has no constraint context - -- so we should apply the MR - -- See Note [Partial type signatures and generalisation] - partial_sig_mrs - = [ null $ fromMaybeContext mtheta - | TcIdSig (PartialSig { psig_hs_ty = hs_ty }) - <- mapMaybe sig_fn (collectHsBindListBinders CollNoDictBinders lbinds) - , let (mtheta, _) = splitLHsQualTy (hsSigWcType hs_ty) ] - - has_partial_sigs = not (null partial_sig_mrs) - - mono_restriction = xopt LangExt.MonomorphismRestriction dflags - && any restricted binds - - do_not_generalise - | isTopLevel top_lvl = False + generalise_binds + | isTopLevel top_lvl = True -- See Note [Always generalise top-level bindings] - | IsGroupClosed _ True <- closed = False + | IsGroupClosed _ True <- closed = True -- The 'True' means that all of the group's -- free vars have ClosedTypeId=True; so we can ignore -- -XMonoLocalBinds, and generalise anyway - | otherwise = xopt LangExt.MonoLocalBinds dflags + | has_partial_sigs = True + -- See Note [Partial type signatures and generalisation] + | otherwise = not (xopt LangExt.MonoLocalBinds dflags) + -- With OutsideIn, all nested bindings are monomorphic - -- except a single function binding with a signature + -- except a single function binding with a complete signature one_funbind_with_sig | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds - , Just (TcIdSig sig) <- sig_fn (unLoc v) + , Just (TcIdSig sig@(CompleteSig {})) <- sig_fn (unLoc v) = Just (lbind, sig) | otherwise = Nothing - -- The Haskell 98 monomorphism restriction - 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) - - restricted_match mg = matchGroupArity mg == 0 - -- No args => like a pattern binding - -- Some args => a function binding - - no_sig n = not (hasCompleteSig sig_fn n) + 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 isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed isClosedBndrGroup type_env binds 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 @@ -12,7 +12,8 @@ import GHC.Hs import GHC.Core.Class -import GHC.Core.Type ( typeKind ) +import GHC.Core.Type( typeKind ) + import GHC.Types.Var( tyVarKind ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad @@ -26,9 +27,10 @@ import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Outputable -import GHC.Utils.Panic import qualified GHC.LanguageExtensions as LangExt +import Data.List.NonEmpty ( NonEmpty (..) ) + tcDefaults :: [LDefaultDecl GhcRn] -> TcM (Maybe [Type]) -- Defaulting types to heave -- into Tc monad for later use @@ -67,9 +69,9 @@ ; return (Just tau_tys) } -tcDefaults decls@(L locn (DefaultDecl _ _) : _) +tcDefaults (decl@(L locn (DefaultDecl _ _)) : decls) = setSrcSpan (locA locn) $ - failWithTc (dupDefaultDeclErr decls) + failWithTc (dupDefaultDeclErr (decl:|decls)) tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type @@ -103,7 +105,6 @@ defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" -dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> TcRnMessage -dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things) +dupDefaultDeclErr :: NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage +dupDefaultDeclErr (L _ (DefaultDecl _ _) :| dup_things) = TcRnMultipleDefaultDeclarations dup_things -dupDefaultDeclErr [] = panic "dupDefaultDeclErr []" 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 @@ -125,7 +125,7 @@ , T defined at A.hs:4:23 ] Then, we get @[C{C;}, C{T;}, T{T;}, T{D;}]@, which eventually gets merged -into @[C{C, T;}, T{T, D;}]@ (which satsifies the AvailTC invariant). +into @[C{C, T;}, T{T, D;}]@ (which satisfies the AvailTC invariant). -} data ExportAccum -- The type of the accumulating parameter of @@ -190,7 +190,7 @@ | explicit_mod = exports | has_main = Just (noLocA [noLocA (IEVar noExtField - (noLocA (IEName $ noLocA default_main)))]) + (noLocA (IEName noExtField $ noLocA default_main)))]) -- ToDo: the 'noLoc' here is unhelpful if 'main' -- turns out to be out of scope | otherwise = Nothing @@ -369,8 +369,8 @@ lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier - lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName] - -> RnM (Located Name, [LIEWrappedName Name], [Name], + 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 @@ -381,7 +381,7 @@ , map (ieWrappedName . unLoc) non_flds , flds) - lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName + lookup_ie_all :: IE GhcPs -> LIEWrappedName GhcPs -> RnM (Located Name, [Name], [FieldLabel]) lookup_ie_all ie (L l rdr) = do name <- lookupGlobalOccRn $ ieWrappedName rdr @@ -421,8 +421,7 @@ {- Note [Modules without a module header] --------------------------------------------------- - +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Haskell 2010 report says in section 5.1: >> An abbreviated form of module, consisting only of the module body, is @@ -477,8 +476,8 @@ -lookupChildrenExport :: Name -> [LIEWrappedName RdrName] - -> RnM ([LIEWrappedName Name], [Located FieldLabel]) +lookupChildrenExport :: Name -> [LIEWrappedName GhcPs] + -> RnM ([LIEWrappedName GhcRn], [Located FieldLabel]) lookupChildrenExport spec_parent rdr_items = do xs <- mapAndReportM doOne rdr_items @@ -493,8 +492,8 @@ | ns == tcName = [dataName, tcName] | otherwise = [ns] -- Process an individual child - doOne :: LIEWrappedName RdrName - -> RnM (Either (LIEWrappedName Name) (Located FieldLabel)) + doOne :: LIEWrappedName GhcPs + -> RnM (Either (LIEWrappedName GhcRn) (Located FieldLabel)) doOne n = do let bareName = (ieWrappedName . unLoc) n @@ -514,7 +513,7 @@ case name of NameNotFound -> do { ub <- reportUnboundName unboundName ; let l = getLoc n - ; return (Left (L l (IEName (L (la2na l) ub))))} + ; 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) @@ -523,7 +522,8 @@ IncorrectParent p c gs -> failWithDcErr p c gs --- Note: [Typing Pattern Synonym Exports] +-- Note [Typing Pattern Synonym Exports] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- It proved quite a challenge to precisely specify which pattern synonyms -- should be allowed to be bundled with which type constructors. -- In the end it was decided to be quite liberal in what we allow. Below is @@ -567,8 +567,8 @@ -- type constructor. -- -- --- Note: [Types of TyCon] --- +-- Note [Types of TyCon] +-- ~~~~~~~~~~~~~~~~~~~~~ -- This check appears to be overly complicated, Richard asked why it -- is not simply just `isAlgTyCon`. The answer for this is that -- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow. @@ -758,4 +758,4 @@ case SrcLoc.leftmost_smallest (greSrcSpan gre1) (greSrcSpan gre2) of LT -> (child1, gre1, ie1, child2, gre2, ie2) GT -> (child2, gre2, ie2, child1, gre1, ie1) - EQ -> panic "exportClashErr: clashing exports have idential location" + EQ -> panic "exportClashErr: clashing exports have identical location" 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 @@ -23,11 +23,11 @@ tcPolyExpr, tcExpr, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, - getFixedTyVars ) where + ) where import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket ) +import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcTypedSplice, tcTypedBracket, tcUntypedBracket ) import GHC.Hs import GHC.Hs.Syn.Type @@ -37,16 +37,19 @@ 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 ) +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 @@ -66,10 +69,11 @@ 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.Types.Var.Set 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 @@ -82,9 +86,14 @@ 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, groupBy, intersect) +import Data.List (partition, sortBy, intersect) +import qualified Data.List.NonEmpty as NE +import GHC.Data.Bag ( unitBag ) + {- ************************************************************************ * * @@ -178,7 +187,7 @@ tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) --- Use tcApp to typecheck appplications, which are treated specially +-- 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 @@ -280,7 +289,7 @@ ************************************************************************ -} --- Explict lists [e1,e2,e3] have been expanded already in the renamer +-- 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] @@ -323,7 +332,7 @@ -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make - act_res_ty = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys) + act_res_ty = mkScaledFunTys missing_tys (mkTupleTy1 boxity arg_tys) ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty) @@ -502,319 +511,30 @@ where orig = OccurrenceOf con_name -{- -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" - --} - -- 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 { -- STEP -2: typecheck the record_expr, the record to be updated - (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr - -- Record update drops some of the content of the record (namely the - -- content of the field being updated). As a consequence, unless the - -- field being updated is unrestricted in the record, or 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 (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds - sel_ids = map selectorAmbiguousFieldOcc upd_flds - -- 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 Selectors] - ; 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 - - mtycon :: Maybe TyCon - mtycon = case idDetails sel_id of - RecSelId (RecSelData tycon) _ -> Just tycon - _ -> Nothing - - 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 - ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes) - - -- Take apart a representative constructor - ; let con1 = assert (not (null relevant_cons) ) head relevant_cons - (con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _) - = conLikeFullSig con1 - con1_arg_tys = map scaledThing scaled_con1_arg_tys - -- We can safely drop the fields' multiplicities because - -- they are currently always 1: there is no syntax for record - -- fields with other multiplicities yet. This way we don't need - -- to handle it in the rest of the function - con1_flds = map flLabel $ conLikeFieldLabels con1 - con1_tv_tys = mkTyVarTys con1_tvs - con1_res_ty = case mtycon of - Just tc -> mkFamilyTyConApp tc con1_tv_tys - Nothing -> conLikeResTy con1 con1_tv_tys - - -- Check that we're not dealing with a unidirectional pattern - -- synonym - ; checkTc (conLikeHasBuilder con1) $ - nonBidirectionalErr (conLikeName con1) - - -- STEP 3 Note [Criteria for update] - -- Check that each updated field is polymorphic; that is, its type - -- mentions only the universally-quantified variables of the data con - ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys - bad_upd_flds = filter bad_fld flds1_w_tys - con1_tv_set = mkVarSet con1_tvs - bad_fld (fld, ty) = fld `elem` upd_fld_occs && - not (tyCoVarsOfType ty `subVarSet` con1_tv_set) - ; checkTc (null bad_upd_flds) (TcRnFieldUpdateInvalidType bad_upd_flds) - - -- STEP 4 Note [Type of a record update] - -- Figure out types for the scrutinee and result - -- Both are of form (T a b c), with fresh type variables, but with - -- common variables where the scrutinee and result must have the same type - -- These are variables that appear in *any* arg of *any* of the - -- relevant constructors *except* in the updated fields - -- - ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons - is_fixed_tv tv = tv `elemVarSet` fixed_tvs - - mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType) - -- Deals with instantiation of kind variables - -- c.f. GHC.Tc.Utils.TcMType.newMetaTyVars - mk_inst_ty subst (tv, result_inst_ty) - | is_fixed_tv tv -- Same as result type - = return (extendTvSubst subst tv result_inst_ty, result_inst_ty) - | otherwise -- Fresh type, of correct kind - = do { (subst', new_tv) <- newMetaTyVarX subst tv - ; return (subst', mkTyVarTy new_tv) } - - ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs - ; let result_inst_tys = mkTyVarTys con1_tvs' - init_subst = mkEmptyTCvSubst (getTCvInScope result_subst) - - ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst - (con1_tvs `zip` result_inst_tys) - - ; let rec_res_ty = TcType.substTy result_subst con1_res_ty - scrut_ty = TcType.substTy scrut_subst con1_res_ty - con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys - - ; co_scrut <- unifyType (Just . HsExprRnThing $ unLoc record_expr) record_rho scrut_ty - -- NB: normal unification is OK here (as opposed to subsumption), - -- because for this to work out, both record_rho and scrut_ty have - -- to be normal datatypes -- no contravariant stuff can go on - - -- STEP 5 - -- Typecheck the bindings - ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds - - -- STEP 6: Deal with the stupid theta. - -- See Note [The stupid context] in GHC.Core.DataCon. - ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1) - ; instStupidTheta RecordUpdOrigin theta' - - -- Step 7: make a cast for the scrutinee, in the - -- case that it's from a data family - ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty - fam_co | Just tycon <- mtycon - , Just co_con <- tyConFamilyCoercion_maybe tycon - = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys []) - | otherwise - = idHsWrapper - - -- Step 8: Check that the req constraints are satisfied - -- For normal data constructors req_theta is empty but we must do - -- this check for pattern synonyms. - ; let req_theta' = substThetaUnchecked scrut_subst req_theta - ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta' + do { -- Desugar the record update. See Note [Record Updates]. + ; (ds_expr, ds_res_ty, err_ctxt) <- desugarRecordUpd record_expr rbnds res_ty - -- Phew! - ; let upd_tc = RecordUpdTc { rupd_cons = relevant_cons - , rupd_in_tys = scrut_inst_tys - , rupd_out_tys = result_inst_tys - , rupd_wrap = req_wrap } - expr' = RecordUpd { rupd_expr = mkLHsWrap fam_co $ - mkLHsWrapCo co_scrut record_expr' - , rupd_flds = Left rbinds' - , rupd_ext = upd_tc } + -- 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. - ; tcWrapResult expr expr' rec_res_ty res_ty } -tcExpr (RecordUpd {}) _ = panic "GHC.Tc.Gen.Expr: tcExpr: The impossible happened!" + ; 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" {- ************************************************************************ @@ -850,17 +570,18 @@ ************************************************************************ -} --- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceExpr'. -- 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 (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr))) - res_ty - = do addModFinalizersWithLclEnv mod_finalizers - tcExpr expr res_ty -tcExpr (HsSpliceE _ splice) res_ty = tcSpliceExpr splice res_ty -tcExpr e@(HsTypedBracket _ body) res_ty = tcTypedBracket e body res_ty +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" {- ************************************************************************ @@ -928,7 +649,7 @@ arithSeqEltType Nothing res_ty = do { res_ty <- expTypeToType res_ty ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; return (mkWpCastN coi, One, elt_ty, Nothing) } + ; return (mkWpCastN coi, OneTy, elt_ty, Nothing) } arithSeqEltType (Just fl) res_ty = do { ((elt_mult, elt_ty), fl') <- tcSyntaxOp ListOrigin fl [SynList] res_ty $ @@ -1127,7 +848,7 @@ ; (list_co, elt_ty) <- matchExpectedListTy rho_ty -- list_co :: [elt_ty] ~N rho_ty ; result <- thing_inside [elt_ty] - ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) } + ; 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 @@ -1163,34 +884,545 @@ {- ********************************************************************* * * - Record bindings + Desugaring record update * * ********************************************************************* -} -getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet --- These tyvars must not change across the updates -getFixedTyVars upd_fld_occs univ_tvs cons - = mkVarSet [tv1 | con <- cons - , let (u_tvs, _, eqspec, prov_theta - , req_theta, arg_tys, _) - = conLikeFullSig con - theta = eqSpecPreds eqspec - ++ prov_theta - ++ req_theta - flds = conLikeFieldLabels con - fixed_tvs = exactTyCoVarsOfTypes (map scaledThing fixed_tys) - -- fixed_tys: See Note [Type of a record update] - `unionVarSet` tyCoVarsOfTypes theta - -- Universally-quantified tyvars that - -- appear in any of the *implicit* - -- arguments to the constructor are fixed - -- See Note [Implicit type sharing] +{- +Note [Type of a record update] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The main complication with RecordUpd is that we need to explicitly +handle the *non-updated* fields. Consider: - fixed_tys = [ty | (fl, ty) <- zip flds arg_tys - , not (flLabel fl `elem` upd_fld_occs)] - , (tv1,tv) <- univ_tvs `zip` u_tvs - , tv `elemVarSet` fixed_tvs ] + 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 @@ -1350,35 +1582,7 @@ , hfbRHS = rhs' , hfbPun = hfbPun fld}))) } -tcRecordUpd - :: ConLike - -> [TcType] -- Expected type for each field - -> [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)] - -> TcM [LHsRecUpdField GhcTc] -tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds - where - fields = map flSelector $ conLikeFieldLabels con_like - flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys - - do_bind :: LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn) - -> TcM (Maybe (LHsRecUpdField GhcTc)) - do_bind (L l fld@(HsFieldBind { hfbLHS = L loc af - , hfbRHS = rhs })) - = do { let lbl = rdrNameAmbiguousFieldOcc af - sel_id = selectorAmbiguousFieldOcc af - f = L loc (FieldOcc (idName sel_id) (L (l2l loc) lbl)) - ; mb <- tcRecordField con_like flds_w_tys f rhs - ; case mb of - Nothing -> return Nothing - Just (f', rhs') -> - return (Just - (L l (fld { hfbLHS - = L loc (Unambiguous - (foExt (unLoc f')) - (L (l2l loc) lbl)) - , hfbRHS = rhs' }))) } - tcRecordField :: ConLike -> Assoc Name Type -> LFieldOcc GhcRn -> LHsExpr GhcRn -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc)) @@ -1386,11 +1590,11 @@ | Just field_ty <- assocMaybe flds_w_tys sel_name = addErrCtxt (fieldCtxt field_lbl) $ do { rhs' <- tcCheckPolyExprNC rhs field_ty - ; hasFixedRuntimeRep_syntactic (FRRRecordUpdate (unLoc lbl) (unLoc rhs')) + ; hasFixedRuntimeRep_syntactic (FRRRecordCon (unLoc lbl) (unLoc rhs')) field_ty ; let field_id = mkUserLocal (nameOccName sel_name) (nameUnique sel_name) - Many field_ty (locA loc) + 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 @@ -1400,7 +1604,7 @@ = do { addErrTc (badFieldConErr (getName con_like) field_lbl) ; return Nothing } where - field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) + field_lbl = FieldLabelString $ occNameFS $ rdrNameOcc (unLoc lbl) checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM () @@ -1497,7 +1701,7 @@ in -- Fields that don't change the membership status of the set -- are redundant and can be dropped. - map (fst . head) $ groupBy ((==) `on` snd) growingSets + map (fst . NE.head) $ NE.groupWith snd growingSets aMember = assert (not (null members) ) fst (head members) (members, nonMembers) = partition (or . snd) membership @@ -1506,7 +1710,7 @@ membership :: [(FieldLabelString, [Bool])] membership = sortMembership $ map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $ - map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds + map (FieldLabelString . occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds fieldLabelSets :: [UniqSet FieldLabelString] fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons 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 @@ -44,29 +44,35 @@ import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Expr import GHC.Tc.Utils.Env - +import GHC.Tc.Utils.TcType import GHC.Tc.Instance.Family + import GHC.Core.FamInstEnv import GHC.Core.Coercion import GHC.Core.Reduction import GHC.Core.Type import GHC.Core.Multiplicity +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.TyCon.RecWalk + import GHC.Types.ForeignCall -import GHC.Utils.Error import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Core.TyCon.RecWalk -import GHC.Tc.Utils.TcType +import GHC.Types.SrcLoc + import GHC.Builtin.Names +import GHC.Builtin.Types.Prim( isArrowTyCon ) + import GHC.Driver.Session import GHC.Driver.Backend + +import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Platform -import GHC.Types.SrcLoc + import GHC.Data.Bag import GHC.Driver.Hooks import qualified GHC.LanguageExtensions as LangExt @@ -96,7 +102,7 @@ newtype Age = MkAge Int we want to see that Age -> IO () is the same as Int -> IO (). But, we don't -need to recur on any type parameters, because no paramaterized types (with +need to recur on any type parameters, because no parameterized types (with interesting parameters) are marshalable! The full list of marshalable types is in the body of boxedMarshalableTyCon in GHC.Tc.Utils.TcType. The only members of that list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled @@ -122,13 +128,13 @@ where go :: Role -> RecTcChecker -> Type -> WriterT (Bag GlobalRdrElt) TcM Reduction go role rec_nts ty - | Just ty' <- tcView ty -- Expand synonyms + | Just ty' <- coreView ty -- Expand synonyms = go role rec_nts ty' | Just (tc, tys) <- splitTyConApp_maybe ty = go_tc_app role rec_nts tc tys - | (bndrs, inner_ty) <- splitForAllTyCoVarBinders ty + | (bndrs, inner_ty) <- splitForAllForAllTyBinders ty , not (null bndrs) = do redn <- go role rec_nts inner_ty return $ mkHomoForAllRedn bndrs redn @@ -139,14 +145,18 @@ go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type] -> WriterT (Bag GlobalRdrElt) TcM Reduction go_tc_app role rec_nts tc tys + | isArrowTyCon tc -- Recurse through arrows, or at least the top + = children_only -- level arrows. Remember, the default case is + -- "don't recurse" (see last eqn for go_tc_app) + + | tc_key `elem` [ioTyConKey, funPtrTyConKey] -- We don't want to look through the IO newtype, even if it is -- in scope, so we have a special case for it: - | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey] = children_only | isNewTyCon tc -- Expand newtypes , Just rec_nts' <- checkRecTc rec_nts tc - -- See Note [Expanding newtypes] in GHC.Core.TyCon + -- See Note [Expanding newtypes and products] in GHC.Core.TyCon.RecWalk -- We can't just use isRecursiveTyCon; sometimes recursion is ok: -- newtype T = T (Ptr T) -- Here, we don't reject the type for being recursive. @@ -173,7 +183,7 @@ children_only = do { args <- unzipRedns <$> zipWithM ( \ ty r -> go r rec_nts ty ) - tys (tyConRolesX role tc) + tys (tyConRoleListX role tc) ; return $ mkTyConAppRedn role tc args } nt_co = mkUnbranchedAxInstCo role (newTyConCo tc) tys [] nt_rhs = newTyConInstRhs tc tys @@ -198,7 +208,7 @@ want to report it as "defined but not used" or "imported but not used". eg newtype D = MkD Int foreign import foo :: D -> IO () -Here 'MkD' us used. See #7408. +Here 'MkD' is used. See #7408. GHC also expands type functions during this process, so it's not enough just to look at the free variables of the declaration. @@ -244,10 +254,17 @@ do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty ; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty ; let - -- Drop the foralls before inspecting the - -- structure of the foreign type. - (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty) - id = mkLocalId nm Many sig_ty + -- Drop the foralls before inspecting the + -- structure of the foreign type. + -- Use splitFunTys, which splits (=>) as well as (->) + -- so that for foreign import foo :: Eq a => a -> blah + -- we get "unacceptable argument Eq a" rather than + -- "unacceptable result Eq a => a -> blah" + -- Not a big deal. We could make a better error message specially + -- for overloaded functions, but doesn't seem worth it + (arg_tys, res_ty) = splitFunTys (dropForAlls norm_sig_ty) + + 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). @@ -264,24 +281,24 @@ -- ------------ Checking types for foreign import ---------------------- -tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport +tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport GhcRn -> TcM (ForeignImport GhcTc) -tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh l@(CLabel _) src) +tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh l@(CLabel _)) -- Foreign import label - = do checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + = do checkCg (Right idecl) backendValidityOfCImport -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a) - check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) + check (isFFILabelTy (mkScaledFunTys arg_tys res_ty)) (TcRnIllegalForeignType Nothing) cconv' <- checkCConv (Right idecl) cconv - return (CImport (L lc cconv') safety mh l src) + return (CImport src (L lc cconv') safety mh l) -tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh CWrapper src) = do +tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh CWrapper) = do -- Foreign wrapper (former f.e.d.) -- 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. - checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + checkCg (Right idecl) backendValidityOfCImport cconv' <- checkCConv (Right idecl) cconv case arg_tys of [Scaled arg1_mult arg1_ty] -> do @@ -292,39 +309,44 @@ where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty _ -> addErrTc (TcRnIllegalForeignType Nothing OneArgExpected) - return (CImport (L lc cconv') safety mh CWrapper src) + return (CImport src (L lc cconv') safety mh CWrapper) -tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh - (CFunction target) src) +tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh + (CFunction target)) | isDynamicTarget target = do -- Foreign import dynamic - checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + checkCg (Right idecl) backendValidityOfCImport cconv' <- checkCConv (Right idecl) cconv case arg_tys of -- The first arg must be Ptr or FunPtr [] -> addErrTc (TcRnIllegalForeignType Nothing AtLeastOneArgExpected) (Scaled arg1_mult arg1_ty:arg_tys) -> do dflags <- getDynFlags - let curried_res_ty = mkVisFunTys arg_tys res_ty + let curried_res_ty = mkScaledFunTys arg_tys res_ty checkNoLinearFFI arg1_mult check (isFFIDynTy curried_res_ty arg1_ty) (TcRnIllegalForeignType (Just Arg)) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty - return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src + return $ CImport src (L lc cconv') (L ls safety) mh (CFunction target) | cconv == PrimCallConv = do dflags <- getDynFlags checkTc (xopt LangExt.GHCForeignImportPrim dflags) (TcRnForeignImportPrimExtNotSet idecl) - checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + checkCg (Right idecl) backendValidityOfCImport checkCTarget idecl target checkTc (playSafe safety) (TcRnForeignImportPrimSafeAnn idecl) checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys -- prim import result is more liberal, allows (#,,#) checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty - return idecl + return (CImport src (L lc cconv) (L ls safety) mh (CFunction target)) + | cconv == JavaScriptCallConv = do + cconv' <- checkCConv (Right idecl) cconv + checkCg (Right idecl) backendValidityOfCImport + -- leave the rest to the JS backend (at least for now) + return (CImport src (L lc cconv') (L ls safety) mh (CFunction target)) | otherwise = do -- Normal foreign import - checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + checkCg (Right idecl) backendValidityOfCImport cconv' <- checkCConv (Right idecl) cconv checkCTarget idecl target dflags <- getDynFlags @@ -336,18 +358,18 @@ | not (null arg_tys) -> addErrTc (TcRnForeignFunctionImportAsValue idecl) _ -> return () - return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src + return $ CImport src (L lc cconv') (L ls safety) mh (CFunction target) -- This makes a convenient place to check -- that the C identifier is valid for C -checkCTarget :: ForeignImport -> CCallTarget -> TcM () +checkCTarget :: ForeignImport GhcRn -> CCallTarget -> TcM () checkCTarget idecl (StaticTarget _ str _ _) = do - checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + checkCg (Right idecl) backendValidityOfCImport checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget" -checkMissingAmpersand :: ForeignImport -> [Type] -> Type -> TcM () +checkMissingAmpersand :: ForeignImport GhcRn -> [Type] -> Type -> TcM () checkMissingAmpersand idecl arg_tys res_ty | null arg_tys && isFunPtrTy res_ty = addDiagnosticTc $ TcRnFunPtrImportWithoutAmpersand idecl @@ -413,14 +435,14 @@ -- ------------ Checking argument types for foreign export ---------------------- -tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport -tcCheckFEType sig_ty edecl@(CExport (L l (CExportStatic esrc str cconv)) src) = do - checkCg (Left edecl) checkCOrAsmOrLlvm +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) cconv' <- checkCConv (Left edecl) cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty - return (CExport (L l (CExportStatic esrc str cconv')) src) + return (CExport src (L l (CExportStatic esrc str cconv'))) where -- Drop the foralls before inspecting -- the structure of the foreign type. @@ -442,8 +464,8 @@ check (pred ty) (TcRnIllegalForeignType (Just Arg)) checkNoLinearFFI :: Mult -> TcM () -- No linear types in FFI (#18472) -checkNoLinearFFI Many = return () -checkNoLinearFFI _ = addErrTc $ TcRnIllegalForeignType (Just Arg) +checkNoLinearFFI ManyTy = return () +checkNoLinearFFI _ = addErrTc $ TcRnIllegalForeignType (Just Arg) LinearTypesNotAllowed ------------ Checking result types for foreign calls ---------------------- @@ -464,7 +486,7 @@ -- We disallow nested foralls in foreign types -- (at least, for the time being). See #16702. - | tcIsForAllTy ty + | isForAllTy ty = addErrTc $ TcRnIllegalForeignType (Just Result) UnexpectedNestedForall -- Case for non-IO result type with FFI Import @@ -497,36 +519,20 @@ checkSafe = True noCheckSafe = False --- | Checking a supported backend is in use -checkCOrAsmOrLlvm :: Backend -> Validity' ExpectedBackends -checkCOrAsmOrLlvm ViaC = IsValid -checkCOrAsmOrLlvm NCG = IsValid -checkCOrAsmOrLlvm LLVM = IsValid -checkCOrAsmOrLlvm _ = NotValid COrAsmOrLlvm - --- | Checking a supported backend is in use -checkCOrAsmOrLlvmOrInterp :: Backend -> Validity' ExpectedBackends -checkCOrAsmOrLlvmOrInterp ViaC = IsValid -checkCOrAsmOrLlvmOrInterp NCG = IsValid -checkCOrAsmOrLlvmOrInterp LLVM = IsValid -checkCOrAsmOrLlvmOrInterp Interpreter = IsValid -checkCOrAsmOrLlvmOrInterp _ = NotValid COrAsmOrLlvmOrInterp - -checkCg :: Either ForeignExport ForeignImport -> (Backend -> Validity' ExpectedBackends) -> TcM () +checkCg :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) + -> (Backend -> Validity' ExpectedBackends) -> TcM () checkCg decl check = do dflags <- getDynFlags let bcknd = backend dflags - case bcknd of - NoBackend -> return () - _ -> - case check bcknd of - IsValid -> return () - NotValid expectedBcknd -> - addErrTc $ TcRnIllegalForeignDeclBackend decl bcknd expectedBcknd + case check bcknd of + IsValid -> return () + NotValid expectedBcknds -> + addErrTc $ TcRnIllegalForeignDeclBackend decl bcknd expectedBcknds -- Calling conventions -checkCConv :: Either ForeignExport ForeignImport -> CCallConv -> TcM CCallConv +checkCConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn) + -> CCallConv -> TcM CCallConv checkCConv _ CCallConv = return CCallConv checkCConv _ CApiConv = return CApiConv checkCConv decl StdCallConv = do 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 @@ -9,8 +9,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DisambiguateRecordFields #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- % (c) The University of Glasgow 2006 @@ -31,23 +29,24 @@ , tyConOf, tyConOfET, lookupParents, fieldNotInType , notSelector, nonBidirectionalErr - , addExprCtxt, addFunResCtxt ) where + , 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.Types.Basic -import GHC.Types.Error +import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) -import GHC.Core.FamInstEnv ( FamInstEnvs ) -import GHC.Core.UsageEnv ( unitUE ) -import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) import GHC.Unit.Module ( getModule ) import GHC.Tc.Errors.Types import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) @@ -55,37 +54,43 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType -import GHC.Hs +import GHC.Tc.Types.Evidence import GHC.Hs.Syn.Type -import GHC.Types.Id -import GHC.Types.Id.Info + +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.Types.Name -import GHC.Types.Name.Reader import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.Type -import GHC.Tc.Types.Evidence + +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.Types.SrcLoc import GHC.Utils.Misc -import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain + +import GHC.Data.Maybe import Control.Monad -import Data.Function -import GHC.Prelude - {- ********************************************************************* * * HsExprArg: auxiliary data type @@ -171,6 +176,7 @@ , 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 @@ -199,12 +205,40 @@ = VAExpansion (HsExpr GhcRn) -- Inside an expansion of this expression SrcSpan -- The SrcSpan of the expression - -- noSrcSpan if outermost + -- 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 @@ -234,9 +268,11 @@ mkEValArg ctxt e = EValArg { eva_arg = ValArg e, eva_ctxt = ctxt , eva_arg_ty = noExtField } -mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn -mkETypeArg ctxt hs_ty = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty - , eva_ty = noExtField } +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 @@ -249,9 +285,13 @@ -- 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 (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 @@ -260,14 +300,16 @@ go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn] -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn]) - go (HsPar _ _ (L l fun) _) ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt) : args) - go (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) + -- 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) + = 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 @@ -287,25 +329,316 @@ dec l (VACall f n _) = VACall f (n-1) (locA l) dec _ ctxt@(VAExpansion {}) = ctxt -rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-> HsExpr GhcTc -rebuildHsApps fun _ [] = fun -rebuildHsApps fun ctxt (arg : args) +-- | 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' } - -> rebuildHsApps (HsApp noAnn lfun arg) ctxt' args - ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' } - -> rebuildHsApps (HsAppType ty lfun hs_ty) ctxt' args + -> 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 - -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args + -> rebuild_hs_apps (HsPragE noExtField p lfun) ctxt' args EWrap (EPar ctxt') - -> rebuildHsApps (gHsPar lfun) ctxt' args + -> rebuild_hs_apps (gHsPar lfun) ctxt' args EWrap (EExpand orig) - -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args + -> rebuild_hs_apps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args EWrap (EHsWrap wrap) - -> rebuildHsApps (mkHsWrap wrap fun) ctxt args + -> 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 @@ -431,12 +764,11 @@ -- -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App tcInferAppHead (fun,ctxt) args - = setSrcSpan (appCtxtLoc ctxt) $ + = addHeadCtxt ctxt $ do { mb_tc_fun <- tcInferAppHead_maybe fun args ; case mb_tc_fun of Just (fun', fun_sigma) -> return (fun', fun_sigma) - Nothing -> add_head_ctxt fun args $ - tcInfer (tcExpr fun) } + Nothing -> tcInfer (tcExpr fun) } tcInferAppHead_maybe :: HsExpr GhcRn -> [HsExprArg 'TcpRn] @@ -447,20 +779,23 @@ = case fun of HsVar _ (L _ nm) -> Just <$> tcInferId nm HsRecSel _ f -> Just <$> tcInferRecSelId f - ExprWithTySig _ e hs_ty -> add_head_ctxt fun args $ - Just <$> tcExprWithSig e hs_ty + ExprWithTySig _ e hs_ty -> Just <$> tcExprWithSig e hs_ty HsOverLit _ lit -> Just <$> tcInferOverLit lit - HsSpliceE _ (HsSpliced _ _ (HsSplicedExpr e)) + HsUntypedSplice (HsUntypedSpliceTop _ e) _ -> tcInferAppHead_maybe e args _ -> return Nothing -add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a --- Don't push an expression context if the arguments are empty, --- because it has already been pushed by tcExpr -add_head_ctxt fun args thing_inside - | null args = thing_inside - | otherwise = addExprCtxt fun thing_inside - +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 {- ********************************************************************* * * @@ -497,8 +832,7 @@ -- nor does it need the 'lifting' treatment -- hence no checkTh stuff here - _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - ppr thing <+> text "used where a value identifier was expected" } + _ -> failWithTc $ TcRnExpectedValueId thing } ------------------------ @@ -553,16 +887,7 @@ UnknownSubordinate (text "field of type" <+> quotes (ppr p)) notSelector :: Name -> TcRnMessage -notSelector field - = TcRnUnknownMessage $ mkPlainError noHints $ - hsep [quotes (ppr field), text "is not a record selector"] - -naughtyRecordSel :: OccName -> TcRnMessage -naughtyRecordSel lbl - = TcRnUnknownMessage $ mkPlainError noHints $ - text "Cannot use record selector" <+> quotes (ppr lbl) <+> - text "as a function due to escaped type variables" $$ - text "Probable fix: use pattern-matching syntax instead" +notSelector = TcRnNotARecordSelector {- ********************************************************************* @@ -583,7 +908,7 @@ loc = getLocA (dropWildCards hs_ty) ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty) -tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcSigmaType) +tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType) 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 @@ -627,7 +952,7 @@ ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) ; let poly_wrap = wrap <.> mkWpTyLams qtvs - <.> mkWpLams givens + <.> mkWpEvLams givens <.> mkWpLet ev_binds ; return (mkLHsWrap poly_wrap expr', my_sigma) } @@ -635,7 +960,7 @@ {- Note [Partial expression signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Partial type signatures on expressions are easy to get wrong. But -here is a guiding principile +here is a guiding principle e :: ty should behave like let x :: ty @@ -755,8 +1080,7 @@ (tcTyThingTyCon_maybe -> Just tc) -> fail_tycon tc -- TyCon or TcTyCon ATyVar name _ -> fail_tyvar name - _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - ppr thing <+> text "used where a value identifier was expected" } + _ -> failWithTc $ TcRnExpectedValueId thing } where fail_tycon tc = do gre <- getGlobalRdrEnv @@ -779,9 +1103,8 @@ hint_msg = vcat $ map ppr hints import_err_msg = vcat $ map ppr import_errs info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg } - msg = TcRnMessageWithInfo unit_state - $ TcRnMessageDetailed info (TcRnIncorrectNameSpace nm False) - failWithTc msg + failWithTc $ TcRnMessageWithInfo unit_state ( + mkDetailedMessage info (TcRnIncorrectNameSpace nm False)) get_suggestions ns = do let occ = mkOccNameFS ns (occNameFS (occName id_name)) @@ -799,11 +1122,11 @@ check_local_id :: Id -> TcM () check_local_id id = do { checkThLocalId id - ; tcEmitBindingUsage $ unitUE (idName id) One } + ; tcEmitBindingUsage $ unitUE (idName id) OneTy } check_naughty :: OccName -> TcId -> TcM () check_naughty lbl id - | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) + | isNaughtyRecordSelector id = failWithTc (TcRnRecSelectorEscapedTyVar lbl) | otherwise = return () tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType) @@ -820,19 +1143,22 @@ ; let full_theta = stupid_theta ++ theta all_arg_tys = map unrestricted full_theta ++ scaled_arg_tys - -- stupid-theta must come first + -- 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 $ - mkVisFunTys scaled_arg_tys res ) } + 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 One ty) = do { mul_var <- newFlexiTyVarTy multiplicityTy - ; return (Scaled mul_var ty) } - linear_to_poly scaled_ty = return scaled_ty + 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 @@ -840,27 +1166,34 @@ Just (expr,ty) -> return (expr,ty) Nothing -> failWithTc (nonBidirectionalErr id_name) -nonBidirectionalErr :: Outputable name => name -> TcRnMessage -nonBidirectionalErr name = TcRnUnknownMessage $ mkPlainError noHints $ - text "non-bidirectional pattern synonym" - <+> quotes (ppr name) <+> text "used in an expression" +nonBidirectionalErr :: Name -> TcRnMessage +nonBidirectionalErr = TcRnPatSynNotBidirectional -{- Note [Typechecking data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- 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, -mostly in tcInferDataCon: +So at an occurrence of a data constructor we do the following: -1. Get its type, say - K :: forall (r :: RuntimeRep) (a :: TYPE r). a %1 -> T r a - Note the %1: it is linear +1. Typechecking, in tcInferDataCon. -2. We are going to return a ConLikeTc, thus: + 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. @@ -870,93 +1203,71 @@ the fresh multiplicity variable in the ConLikeTc; along with the type of the ConLikeTc. This is done by linear_to_poly. -3. If the argument is not linear (perhaps explicitly declared as + If the argument is not linear (perhaps explicitly declared as non-linear by the user), don't bother with this. -4. The (ConLikeTc K [r,a] [Scaled p a]) is later desugared by - GHC.HsToCore.Expr.dsConLike to: +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. -Wrinkles - -* Note that the [TcType] is strictly redundant anyway; 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. - -* 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# - - We then rely on the simple optimiser to beta reduce the lambda. - -* See Note [Instantiating stupid theta] for an extra wrinkle + 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. -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. +Wrinkles + [ConLikeTc arguments] -Note [Instantiating stupid theta] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a data type with a "stupid theta" (see -Note [The stupid context] in GHC.Core.DataCon): + 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! - data Ord a => T a = MkT (Maybe a) + 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. -We want to generate an Ord constraint for every use of MkT; but -we also want to allow visible type application, such as - MkT @Int + [Representation-polymorphic lambdas] -So we generate (ConLikeTc MkT [a] [Ord a, Maybe a]), with type - forall a. Ord a => Maybe a -> T a + 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: -Now visible type application will work fine. But we desugar the -ConLikeTc to - /\a \(d:Ord a) (x:Maybe a). MkT x -Notice that 'd' is dropped in this desugaring. We don't need it; -it was only there to generate a Wanted constraint. (That is why -it is stupid.) To achieve this: + A. Any arguments to such lambda abstractions are guaranteed to have + a fixed runtime representation. This is enforced in 'tcApp' by + 'matchActualFunTySigma'. -* We put the stupid-thata at the front of the list of argument - types in ConLikeTc + 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. -* GHC.HsToCore.Expr.dsConLike generates /lambdas/ for all the - arguments, but drops the stupid-theta arguments when building the - /application/. + ( /\r (a :: TYPE r). \ (x %p :: a). K @r @a x) @IntRep @Int# + :: Int# -> T IntRep Int# -Nice. + 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`. -} {- @@ -1007,7 +1318,7 @@ -- 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) (polySpliceErr 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 @@ -1026,7 +1337,7 @@ [getRuntimeRep id_ty, id_ty] -- Warning for implicit lift (#17804) - ; addDetailedDiagnostic (TcRnImplicitLift id) + ; addDetailedDiagnostic (TcRnImplicitLift $ idName id) -- Update the pending splices ; ps <- readMutVar ps_var @@ -1040,11 +1351,6 @@ id_name = idName id checkCrossStageLifting _ _ _ = return () - -polySpliceErr :: Id -> TcRnMessage -polySpliceErr id - = TcRnUnknownMessage $ mkPlainError noHints $ - text "Can't splice the polymorphic local variable" <+> quotes (ppr id) {- Note [Lifting strings] 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 @@ -1,6 +1,6 @@ - {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -76,14 +76,13 @@ funAppCtxt, addTyConFlavCtxt ) where -import GHC.Prelude +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.Core.Predicate import GHC.Tc.Types.Constraint import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType @@ -92,12 +91,16 @@ import GHC.IfaceToCore import GHC.Tc.Solver import GHC.Tc.Utils.Zonk -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN, - tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs ) + 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 @@ -125,12 +128,15 @@ 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 as NE( NonEmpty(..), nubBy ) +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 ) @@ -336,7 +342,7 @@ 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 -matavariable with level 2 would violate the (WantedInv) invariant of +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. @@ -631,11 +637,10 @@ tcHsDeriv hs_ty = do { ty <- tcTopLHsType DerivClauseCtxt hs_ty ; let (tvs, pred) = splitForAllTyCoVars ty - (kind_args, _) = splitFunTys (tcTypeKind pred) + (kind_args, _) = splitFunTys (typeKind pred) ; case getClassPredTys_maybe pred of Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args) - Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (text "Illegal deriving item" <+> quotes (ppr hs_ty)) } + 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. @@ -659,7 +664,9 @@ tc_deriv_strategy (NewtypeStrategy _) = boring_case (NewtypeStrategy noExtField) tc_deriv_strategy (ViaStrategy hs_sig) = do { ty <- tcTopLHsType DerivClauseCtxt hs_sig - ; rec { (via_tvs, via_pred) <- tcSkolemiseInvisibleBndrs (DerivSkol via_pred) ty} + -- 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]) @@ -1043,9 +1050,11 @@ -- splices or not. -- -- See Note [Delaying modFinalizers in untyped splices]. -tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty))) - = tc_infer_hs_type mode ty +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] @@ -1056,10 +1065,10 @@ subst_prs = [ (getUnique nm, tv) | ATyVar nm tv <- nonDetNameEnvElts (tcl_env env) ] subst = mkTvSubst - (mkInScopeSet $ mkVarSet $ map snd subst_prs) - (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs) + (mkInScopeSetList $ map snd subst_prs) + (listToUFM_Directly $ map (fmap mkTyVarTy) subst_prs) ty' = substTy subst ty - return (ty', tcTypeKind ty') + return (ty', typeKind ty') tc_infer_hs_type _ (HsExplicitListTy _ _ tys) | null tys -- this is so that we can use visible kind application with '[] @@ -1132,41 +1141,30 @@ -- 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) - = do { let bangError err = failWith $ TcRnUnknownMessage $ mkPlainError noHints $ - text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$ - text err <+> text "annotation cannot appear nested inside a type" - ; case bang of - HsSrcBang _ SrcUnpack _ -> bangError "UNPACK" - HsSrcBang _ SrcNoUnpack _ -> bangError "NOUNPACK" - HsSrcBang _ NoSrcUnpack SrcLazy -> bangError "laziness" - HsSrcBang _ _ _ -> bangError "strictness" } + = 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 $ TcRnUnknownMessage $ mkPlainError noHints $ - (text "Record syntax is illegal here:" <+> ppr ty) + = 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 _ (HsSpliced _ mod_finalizers (HsSplicedTy ty))) +tc_hs_type mode (HsSpliceTy (HsUntypedSpliceTop mod_finalizers ty) _) exp_kind = do addModFinalizersWithLclEnv mod_finalizers - tc_hs_type mode ty exp_kind + tc_lhs_type mode ty exp_kind --- This should never happen; type splices are expanded by the renamer -tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind - = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (text "Unexpected type splice:" <+> ppr ty) +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` funTyConKey + | op `hasKey` unrestrictedFunTyConKey = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind --------- Foralls @@ -1187,10 +1185,10 @@ = tc_lhs_type mode rn_ty exp_kind -- See Note [Body kind of a HsQualTy] - | tcIsConstraintKind exp_kind + | isConstraintLikeKind exp_kind = do { ctxt' <- tc_hs_context mode ctxt ; ty' <- tc_lhs_type mode rn_ty constraintKind - ; return (mkPhiTy ctxt' ty') } + ; return (tcMkDFunPhiTy ctxt' ty') } | otherwise = do { ctxt' <- tc_hs_context mode ctxt @@ -1198,7 +1196,7 @@ ; 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) (mkPhiTy ctxt' ty') + ; checkExpectedKind (unLoc rn_ty) (tcMkPhiTy ctxt' ty') liftedTypeKind exp_kind } --------- Lists, arrays, and tuples @@ -1284,8 +1282,8 @@ 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' and 'tcView'. + -- 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 @@ -1319,22 +1317,22 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 (ArgFlag) for each +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 ArgFlag +| 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 non-sensical and is thus rejected. +| This last form is nonsensical and is thus rejected. ---------------------------------------------------------------------------- -For more information regarding the interpretation of the resulting ArgFlag, see -Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep". +For more information regarding the interpretation of the resulting ForAllTyFlag, see +Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep". -} ------------------------------------------ @@ -1345,18 +1343,21 @@ -> TcM TcType tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of TypeLevel -> - do { arg_k <- newOpenTypeKind + do { traceTc "tc_fun_type" (ppr ty1 $$ ppr ty2) + ; arg_k <- newOpenTypeKind ; res_k <- newOpenTypeKind - ; ty1' <- tc_lhs_type mode ty1 arg_k - ; ty2' <- tc_lhs_type mode ty2 res_k + ; ty1' <- tc_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) (mkVisFunTy mult' ty1' ty2') + ; 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 + 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) (mkVisFunTy mult' ty1' ty2') + ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) + (tcMkVisFunTy mult' ty1' ty2') liftedTypeKind exp_kind } {- Note [Skolem escape and forall-types] @@ -1401,10 +1402,10 @@ tupKindSort_maybe :: TcKind -> Maybe TupleSort tupKindSort_maybe k | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k' - | Just k' <- tcView k = tupKindSort_maybe k' - | tcIsConstraintKind k = Just ConstraintTuple - | tcIsLiftedTypeKind k = Just BoxedTuple - | otherwise = Nothing + | 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 @@ -1508,7 +1509,7 @@ is_app :: HsType GhcRn -> Bool is_app (HsAppKindTy {}) = True is_app (HsAppTy {}) = True - is_app (HsOpTy _ _ _ (L _ op) _) = not (op `hasKey` funTyConKey) + 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 @@ -1574,30 +1575,30 @@ go_init n fun all_args = go n fun empty_subst fun_ki all_args where - fun_ki = tcTypeKind fun - -- We do (tcTypeKind fun) here, even though the caller + 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 tcTypeKind is fast + -- the 'fun' is just a TyCon, so typeKind is fast - empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + empty_subst = mkEmptySubst $ mkInScopeSet $ tyCoVarsOfType fun_ki go :: Int -- The # of the next argument -> TcType -- Function applied to some args - -> TCvSubst -- Applies to function kind + -> 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) - -- tcTypeKind fun = subst(fun_ki) + -- typeKind fun = subst(fun_ki) -- So the 'subst' and 'fun_ki' arguments are simply - -- there to avoid repeatedly calling tcTypeKind. + -- 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 - -- (tcTypeKind fun), because the next thing we are going to do + -- (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 @@ -1614,16 +1615,16 @@ case ki_binder of -- FunTy with PredTy on LHS, or ForAllTy with Inferred - Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki - Anon InvisArg _ -> instantiate ki_binder inner_ki + 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 (tyBinderType ki_binder) + , ppr (piTyBinderType ki_binder) , ppr subst ]) - ; let exp_kind = substTy subst $ tyBinderType ki_binder + ; 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) $ @@ -1645,8 +1646,8 @@ ---------------- HsValArg: a normal argument (fun ty) (HsValArg arg : args, Just (ki_binder, inner_ki)) -- next binder is invisible; need to instantiate it - | isInvisibleBinder ki_binder -- FunTy with InvisArg on LHS; - -- or ForAllTy with Inferred or Specified + | isInvisiblePiTyBinder ki_binder -- FunTy with constraint on LHS; + -- or ForAllTy with Inferred or Specified -> instantiate ki_binder inner_ki -- "normal" case @@ -1654,9 +1655,9 @@ -> do { traceTc "tcInferTyApps (vis normal app)" (vcat [ ppr ki_binder , ppr arg - , ppr (tyBinderType ki_binder) + , ppr (piTyBinderType ki_binder) , ppr subst ]) - ; let exp_kind = substTy subst $ tyBinderType ki_binder + ; 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) @@ -1669,7 +1670,7 @@ do { let arrows_needed = n_initial_val_args all_args ; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki - ; fun' <- zonkTcType (fun `mkTcCastTy` co) + ; fun' <- zonkTcType (fun `mkCastTy` co) -- This zonk is essential, to expose the fruits -- of matchExpectedFunKind to the 'go' loop @@ -1677,7 +1678,7 @@ vcat [ ppr fun <+> dcolon <+> ppr fun_ki , ppr arrows_needed , ppr co - , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')] + , ppr fun' <+> dcolon <+> ppr (typeKind fun')] ; go_init n fun' all_args } -- Use go_init to establish go's INVARIANT where @@ -1696,7 +1697,7 @@ | otherwise = fallthrough - zapped_subst = zapTCvSubst subst + zapped_subst = zapSubst subst substed_fun_ki = substTy subst fun_ki hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args) @@ -1707,20 +1708,17 @@ n_initial_val_args _ = 0 ty_app_err arg ty - = failWith $ TcRnUnknownMessage $ mkPlainError noHints $ - text "Cannot apply function of kind" <+> quotes (ppr ty) - $$ text "to visible kind argument" <+> quotes (ppr arg) - + = failWith $ TcRnInvalidVisibleKindArgument arg ty -mkAppTyM :: TCvSubst - -> TcType -> TyCoBinder -- fun, plus its top-level binder +mkAppTyM :: Subst + -> TcType -> PiTyBinder -- fun, plus its top-level binder -> TcType -- arg - -> TcM (TCvSubst, TcType) -- Extended subst, plus (fun 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) --- tcTypeKind fun = Pi bndr. body +-- typeKind fun = Pi bndr. body -- That is, fun always has a ForAllTy or FunTy at the top -- and 'bndr' is fun's pi-binder -- @@ -1728,7 +1726,7 @@ -- invariant, then so does the result type (fun arg) -- -- We do not require that --- tcTypeKind arg = tyVarKind (binderVar bndr) +-- 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 @@ -1763,7 +1761,7 @@ (ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg) $ mkAppTy fun arg where - fun_kind = tcTypeKind fun + fun_kind = typeKind fun isTrickyTvBinder :: TcTyVar -> Bool -- NB: isTrickyTvBinder is just an optimisation @@ -1774,14 +1772,14 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ During type inference, we maintain this invariant - (PKTI) It is legal to call 'tcTypeKind' on any Type ty, + (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 tcTypeKind" we mean "tcTypeKind will not crash". -The way in which tcTypeKind can crash is in applications +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.) @@ -1794,7 +1792,7 @@ a :: kappa then consider the type (a Int) -If we call tcTypeKind on that, we'll crash, because the (un-zonked) +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. @@ -1853,7 +1851,7 @@ saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind) -- Precondition for (saturateFamApp ty kind): --- tcTypeKind ty = kind +-- typeKind ty = kind -- -- If 'ty' is an unsaturated family application with trailing -- invisible arguments, instantiate them. @@ -1861,10 +1859,10 @@ saturateFamApp ty kind | Just (tc, args) <- tcSplitTyConApp_maybe ty - , mustBeSaturated tc + , tyConMustBeSaturated tc , let n_to_inst = tyConArity tc - length args = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind - ; return (ty `mkTcAppTys` extra_args, ki') } + ; return (ty `mkAppTys` extra_args, ki') } | otherwise = return (ty, kind) @@ -1932,7 +1930,7 @@ , text "act_kind':" <+> ppr act_kind' , text "exp_kind:" <+> ppr exp_kind ] - ; let res_ty = ty `mkTcAppTys` new_args + ; let res_ty = ty `mkAppTys` new_args ; if act_kind' `tcEqType` exp_kind then return res_ty -- This is very common @@ -1940,7 +1938,7 @@ ; traceTc "checkExpectedKind" (vcat [ ppr act_kind , ppr exp_kind , ppr co_k ]) - ; return (res_ty `mkTcCastTy` 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. @@ -2236,7 +2234,7 @@ -- 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 Nothing + = failWith $ TcRnIllegalWildcardInType Nothing reason where reason = case is_extra of @@ -2460,7 +2458,7 @@ kcInferDeclHeader name flav (HsQTvs { hsq_ext = kv_ns , hsq_explicit = hs_tvs }) kc_res_ki - -- No standalane kind signature and no CUSK. + -- 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)) @@ -2477,7 +2475,7 @@ -- recursive group. -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl - tc_binders = mkAnonTyConBinders VisArg tc_tvs + 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 @@ -2593,7 +2591,7 @@ -- 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) emptyTCvSubst all_tcbs + (subst, swizzled_tcbs) = mapAccumL (swizzleTcb swizzle_env) emptySubst all_tcbs swizzled_kind = substTy subst tycon_res_kind all_tv_prs = mkTyVarNamePairs (binderVars swizzled_tcbs) @@ -2629,11 +2627,11 @@ -- Argument is excess TyConBinders and tail kind -> TcM ( [TcTyConBinder] -- Skolemised binders, with TcTyVars , a ) --- See Note [Matching a kind sigature with a declaration] +-- 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 emptyTCvSubst sig_tcbs hs_bndrs + = go emptySubst sig_tcbs hs_bndrs where go subst tcbs [] = do { let (subst', tcbs') = substTyConBindersX subst tcbs @@ -2641,7 +2639,7 @@ ; return ([], res) } go _ [] hs_bndrs - = failWithTc (tooManyBindersErr sig_res_kind hs_bndrs) + = failWithTc (TcRnTooManyBinders sig_res_kind hs_bndrs) go subst (tcb : tcbs') hs_bndrs | Bndr tv vis <- tcb @@ -2675,16 +2673,16 @@ ; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind } -substTyConBinderX :: TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder) +substTyConBinderX :: Subst -> TyConBinder -> (Subst, TyConBinder) substTyConBinderX subst (Bndr tv vis) = (subst', Bndr tv' vis) where (subst', tv') = substTyVarBndr subst tv -substTyConBindersX :: TCvSubst -> [TyConBinder] -> (TCvSubst, [TyConBinder]) +substTyConBindersX :: Subst -> [TyConBinder] -> (Subst, [TyConBinder]) substTyConBindersX = mapAccumL substTyConBinderX -swizzleTcb :: VarEnv Name -> TCvSubst -> TyConBinder -> (TCvSubst, TyConBinder) +swizzleTcb :: VarEnv Name -> Subst -> TyConBinder -> (Subst, TyConBinder) swizzleTcb swizzle_env subst (Bndr tv vis) = (subst', Bndr tv2 vis) where @@ -2700,13 +2698,6 @@ -- See Note [Source locations for implicitly bound type variables] -- in GHC.Tc.Rename.HsType -tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> TcRnMessage -tooManyBindersErr ki bndrs = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Not a function kind:") - 4 (ppr ki) $$ - hang (text "but extra binders found:") - 4 (fsep (map ppr bndrs)) - {- See Note [kcCheckDeclHeader_sig] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given a kind signature 'sig_kind' and a declaration header, @@ -3022,15 +3013,7 @@ report_dup :: (Name,Name) -> TcM () report_dup (n1,n2) = setSrcSpan (getSrcSpan n2) $ - addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ - 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) ] + addErrTc $ TcRnDifferentNamesForTyVar n1 n2 {- ********************************************************************* @@ -3056,7 +3039,7 @@ , 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 ArgFlag] + -- but we want [VarBndr TyVar ForAllTyFlag] ; return (tyVarReqToBinders req_tv_bndrs, thing) } HsForAllInvis { hsf_invis_bndrs = bndrs } @@ -3065,7 +3048,7 @@ , 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 ArgFlag] + -- but we want [VarBndr TyVar ForAllTyFlag] ; return (tyVarSpecToBinders inv_tv_bndrs, thing) } -------------------------------------- @@ -3197,19 +3180,19 @@ -- 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 - | null bndrs - = do { res <- thing_inside +tcExplicitTKBndrsX skol_mode bndrs thing_inside = case nonEmpty bndrs of + Nothing -> do + { res <- thing_inside ; return ([], res) } - | otherwise - = do { (tclvl, wanted, (skol_tvs, 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 = head bndrs; bndr_n = last bndrs + ; 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 @@ -3254,14 +3237,14 @@ -> 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 - = liftFstM binderVars $ + = 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 - = liftFstM binderVars $ + = mapFst binderVars $ bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True , sm_tvtv = SMDTyVarTv, sm_kind = ctxt_kind }) hs_bndrs thing_inside @@ -3516,6 +3499,8 @@ 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 @@ -3533,7 +3518,7 @@ zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar] zonkAndScopedSort spec_tkvs = do { spec_tkvs <- zonkTcTyVarsToTcTyVars spec_tkvs - -- Zonk the kinds, to we can do the dependency analayis + -- 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 @@ -3631,7 +3616,7 @@ * 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 residiual constraint wrapped in an implication for g, + * Emit the residual constraint wrapped in an implication for g, thus forall g. WC All of this happens for types too. Consider @@ -3690,7 +3675,7 @@ = return ([], res_kind) where tyvars = binderVars tcbs - in_scope = mkInScopeSet (mkVarSet tyvars) + in_scope = mkInScopeSetList tyvars avoid_occs = map getOccName tyvars needsEtaExpansion :: TyConFlavour -> Bool @@ -3718,14 +3703,12 @@ ; uniqs <- newUniqueSupply ; rdr_env <- getLocalRdrEnv ; lvl <- getTcLevel - ; let new_occs = [ occ - | str <- allNameStrings - , let occ = mkOccName tvName str - , isNothing (lookupLocalRdrOcc rdr_env occ) - -- Note [Avoid name clashes for associated data types] - , not (occ `elem` avoid_occs) ] + ; 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 = mkEmptyTCvSubst in_scope + subst = mkEmptySubst in_scope details = SkolemTv skol_info (pushTcLevel lvl) False -- As always, allocate skolems one level in @@ -3733,16 +3716,16 @@ = case splitPiTy_maybe kind of Nothing -> (reverse acc, substTy subst kind) - Just (Anon af arg, 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' = extendTCvInScope subst tv - (uniq:uniqs') = uniqs - (occ:occs') = occs + subst' = extendSubstInScope subst tv + uniq:uniqs' = uniqs + Inf occ occs' = occs Just (Named (Bndr tv vis), kind') -> go occs uniqs subst' (tcb : acc) kind' @@ -3753,34 +3736,9 @@ ; return (go new_occs new_uniqs subst [] kind) } --- | 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 - --- | Local 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 - isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool -isAllowedDataResKind AnyTYPEKind kind = tcIsRuntimeTypeKind kind -isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind +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 @@ -3814,15 +3772,6 @@ -- Look for the result kind after -- peeling off any foralls and arrows - pp_dec :: SDoc - pp_dec = text $ - case data_sort of - DataDeclSort DataType -> "Data type" - DataDeclSort NewType -> "Newtype" - DataInstanceSort DataType -> "Data instance" - DataInstanceSort NewType -> "Newtype instance" - DataFamilySort -> "Data family" - is_newtype :: Bool is_newtype = case data_sort of @@ -3872,59 +3821,46 @@ -- 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 (tcGetCastedTyVar_maybe res_kind) + is_kind_var | is_data_family = isJust (getCastedTyVar_maybe res_kind) | otherwise = False - pp_allowed_kind dflags = - case allowed_kind dflags of - AnyTYPEKind -> ppr tYPETyCon - AnyBoxedKind -> ppr boxedRepDataConTyCon - LiftedKind -> ppr liftedTypeKind - err_msg :: DynFlags -> TcRnMessage - err_msg dflags = TcRnUnknownMessage $ mkPlainError noHints $ - sep [ sep [ pp_dec <+> - text "has non-" <> - pp_allowed_kind dflags - , (if is_data_family then text "and non-variable" else empty) <+> - text "return kind" <+> quotes (ppr kind) ] - , ext_hint dflags ] + err_msg dflags = + TcRnInvalidReturnKind data_sort (allowed_kind dflags) kind (ext_hint dflags) ext_hint dflags - | tcIsRuntimeTypeKind kind + | isTypeLikeKind kind , is_newtype , not (xopt LangExt.UnliftedNewtypes dflags) - = text "Perhaps you intended to use UnliftedNewtypes" + = Just SuggestUnliftedNewtypes | tcIsBoxedTypeKind kind , is_datatype , not (xopt LangExt.UnliftedDatatypes dflags) - = text "Perhaps you intended to use UnliftedDatatypes" + = Just SuggestUnliftedDatatypes | otherwise - = empty + = 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 (tcIsConstraintKind kind) err_msg +checkClassKindSig kind = checkTc (isConstraintKind kind) err_msg where err_msg :: TcRnMessage - err_msg = TcRnUnknownMessage $ mkPlainError noHints $ - text "Kind signature on a class must end with" <+> ppr constraintKind $$ - text "unobscured by type families" + 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 = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args)) + 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 + 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 @@ -4030,7 +3966,9 @@ (theta, wcx) <- tcPartialContext mode hs_ctxt ; ek <- newOpenTypeKind - ; tau <- addTypeCtxt hs_tau $ + ; 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) } @@ -4042,7 +3980,7 @@ -- No kind-generalization here: ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $ - mkPhiTy theta $ + tcMkPhiTy theta $ tau) -- Spit out the wildcards (including the extra-constraints one) @@ -4050,12 +3988,13 @@ -- See Note [Extra-constraint holes in partial type signatures] ; mapM_ emitNamedTypeHole wcs - -- Zonk, so that any nested foralls can "see" their occurrences - -- See Note [Checking partial type signatures], and in particular - -- Note [Levels for wildcards] - ; outer_tv_bndrs <- mapM zonkInvisTVBinder outer_tv_bndrs - ; theta <- mapM zonkTcType theta - ; tau <- zonkTcType tau + -- 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. @@ -4065,6 +4004,13 @@ 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 @@ -4117,7 +4063,7 @@ 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 + 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. @@ -4130,7 +4076,7 @@ * 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 occurrenceds + 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 @@ -4202,9 +4148,6 @@ * Because it is ill-kinded (unifying something of kind Constraint with something of kind Type), it should trip an assert in writeMetaTyVarRef. - However, writeMetaTyVarRef uses eqType, not tcEqType, to avoid falling - over in this scenario (and another scenario, as detailed in - Note [coreView vs tcView] in GHC.Core.Type). Result works fine, but it may eventually bite us. @@ -4378,22 +4321,7 @@ promotionErr :: Name -> PromotionErr -> TcM a promotionErr name err - = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (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 - - same_rec_group_msg = text "it is defined and used in the same recursive group" + = failWithTc $ TcRnUnpromotableThing name err {- ************************************************************************ 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 @@ -71,7 +71,6 @@ import GHC.Utils.Misc import GHC.Driver.Session ( getDynFlags ) -import GHC.Types.Error import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name import GHC.Types.Id @@ -79,6 +78,7 @@ import Control.Monad import Control.Arrow ( second ) +import qualified Data.List.NonEmpty as NE {- ************************************************************************ @@ -111,7 +111,7 @@ ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty -> -- NB: exp_type may be polymorphic, but -- matchExpectedFunTys can cope with that - tcScalingUsage Many $ + tcScalingUsage ManyTy $ -- toplevel bindings and let bindings are, at the -- moment, always unrestricted. The value being bound -- must, accordingly, be unrestricted. Hence them @@ -170,7 +170,7 @@ -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -- Used for pattern bindings tcGRHSsPat grhss res_ty - = tcScalingUsage Many $ + = 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 @@ -215,7 +215,7 @@ -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches - , mg_origin = origin }) + , 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, @@ -224,8 +224,8 @@ ; pat_tys <- mapM scaledExpTypeToType pat_tys ; rhs_ty <- expTypeToType rhs_ty ; return (MG { mg_alts = L l [] - , mg_ext = MatchGroupTc pat_tys rhs_ty - , mg_origin = origin }) } + , mg_ext = MatchGroupTc pat_tys rhs_ty origin + }) } | otherwise = do { umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches @@ -234,8 +234,8 @@ ; pat_tys <- mapM readScaledExpType pat_tys ; rhs_ty <- readExpType rhs_ty ; return (MG { mg_alts = L l matches' - , mg_ext = MatchGroupTc pat_tys rhs_ty - , mg_origin = origin }) } + , mg_ext = MatchGroupTc pat_tys rhs_ty origin + }) } ------------- tcMatch :: (AnnoBody body) => TcMatchCtxt body @@ -413,7 +413,7 @@ tcGuardStmt :: TcExprStmtChecker tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside - = do { guard' <- tcScalingUsage Many $ tcCheckMonoExpr guard boolTy + = do { guard' <- tcScalingUsage ManyTy $ tcCheckMonoExpr guard boolTy -- Scale the guard to Many (see #19120 and #19193) ; thing <- thing_inside res_ty ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } @@ -426,7 +426,7 @@ -- The multiplicity of x in u must be the same as the multiplicity at -- which the rhs has been consumed. When solving #18738, we want these -- two multiplicity to still be the same. - (rhs', rhs_ty) <- tcScalingUsage Many $ tcInferRhoNC rhs + (rhs', rhs_ty) <- tcScalingUsage ManyTy $ tcInferRhoNC rhs -- Stmt has a context already ; hasFixedRuntimeRep_syntactic FRRBindStmtGuard rhs_ty ; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) @@ -534,11 +534,11 @@ -- typically something like [(Int,Bool,Int)] -- We don't know what tuple_ty is yet, so we use a variable ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (n_app (idType bndr_id)) + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name ManyTy (n_app (idType bndr_id)) -- Ensure that every old binder of type `b` is linked up with its -- new binder which should have type `n b` - -- See Note [GroupStmt binder map] in GHC.Hs.Expr + -- See Note [TransStmt binder map] in GHC.Hs.Expr n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids bindersMap' = bndr_ids `zip` n_bndr_ids @@ -727,11 +727,11 @@ --------------- Building the bindersMap ---------------- ; let mk_n_bndr :: Name -> TcId -> TcId - mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (n_app (idType bndr_id)) + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name ManyTy (n_app (idType bndr_id)) -- Ensure that every old binder of type `b` is linked up with its -- new binder which should have type `n b` - -- See Note [GroupStmt binder map] in GHC.Hs.Expr + -- See Note [TransStmt binder map] in GHC.Hs.Expr n_bndr_ids = zipWithEqual "tcMcStmt" mk_n_bndr n_bndr_names bndr_ids bindersMap' = bndr_ids `zip` n_bndr_ids @@ -908,7 +908,7 @@ res_ty thing_inside = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind - ; let tup_ids = zipWith (\n t -> mkLocalId n Many t) tup_names tup_elt_tys + ; let tup_ids = zipWith (\n t -> mkLocalId n ManyTy t) tup_names tup_elt_tys -- Many because it's a recursive definition tup_ty = mkBigCoreTupTy tup_elt_tys @@ -997,7 +997,7 @@ the expected/inferred stuff is back to front (see #3613). Note [typechecking ApplicativeStmt] - +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en) fresh type variables: @@ -1138,18 +1138,14 @@ checkArgCounts _ (MG { mg_alts = L _ [] }) = return () checkArgCounts matchContext (MG { mg_alts = L _ (match1:matches) }) - | not (null bad_matches) - = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (vcat [ err_msg <+> - text "have different numbers of arguments" - , nest 2 (ppr (getLocA match1)) - , nest 2 (ppr (getLocA (head bad_matches)))]) + | Just bad_matches <- mb_bad_matches + = failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext + $ MatchArgMatches match1 bad_matches | otherwise = return () where n_args1 = args_in_match match1 - bad_matches = [m | m <- matches, args_in_match m /= n_args1] - err_msg = pprMatchContextNouns matchContext + mb_bad_matches = NE.nonEmpty [m | m <- matches, args_in_match m /= n_args1] args_in_match :: (LocatedA (Match GhcRn body1) -> Int) args_in_match (L _ (Match { m_pats = pats })) = length pats 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,4 +1,3 @@ - {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} @@ -21,7 +20,6 @@ , tcCheckPat, tcCheckPat_O, tcInferPat , tcPats , addDataConStupidTheta - , polyPatSig ) where @@ -37,7 +35,7 @@ import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate -import GHC.Types.Error +import GHC.Types.FieldLabel import GHC.Types.Id import GHC.Types.Var import GHC.Types.Name @@ -56,6 +54,7 @@ import GHC.Tc.Types.Origin import GHC.Core.TyCon import GHC.Core.Type +import GHC.Core.Coercion import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Core.ConLike @@ -71,8 +70,14 @@ import qualified GHC.LanguageExtensions as LangExt import Control.Arrow ( second ) import Control.Monad +import GHC.Data.FastString +import qualified Data.List.NonEmpty as NE + import GHC.Data.List.SetOps ( getNth ) +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import Data.List( partition ) + {- ************************************************************************ * * @@ -231,7 +236,7 @@ -- level, we'd be in checking mode (see tcConArg) -- hence this assertion do { bndr_ty <- inferResultToType infer_res - ; return (mkTcNomReflCo bndr_ty, bndr_ty) } + ; return (mkNomReflCo bndr_ty, bndr_ty) } ; let bndr_mult = scaledMult exp_pat_ty ; bndr_id <- newLetBndr no_gen bndr_name bndr_mult bndr_ty ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl @@ -313,6 +318,11 @@ , r -- Result of thing inside ) +tcMultiple_ :: Checker inp () -> PatEnv -> [inp] -> TcM r -> TcM r +tcMultiple_ tc_pat penv args thing_inside + = do { (_, res) <- tcMultiple tc_pat penv args thing_inside + ; return res } + tcMultiple :: Checker inp out -> Checker [inp] [out] tcMultiple tc_pat penv args thing_inside = do { err_ctxt <- getErrCtxt @@ -352,7 +362,7 @@ -------------------- -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. checkManyPattern :: Scaled a -> TcM HsWrapper -checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin Many (scaledMult pat_ty) +checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin ManyTy (scaledMult pat_ty) tc_pat :: Scaled ExpSigmaTypeFRR -- ^ Fully refined result type @@ -391,7 +401,7 @@ -- Check that the expected pattern type is itself lifted ; pat_ty <- readExpType (scaledThing pat_ty) - ; _ <- unifyType Nothing (tcTypeKind pat_ty) liftedTypeKind + ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind ; return (mkHsWrapPat mult_wrap (LazyPat x pat') pat_ty, res) } @@ -402,7 +412,7 @@ ; pat_ty <- expTypeToType (scaledThing pat_ty) ; return (mkHsWrapPat mult_wrap (WildPat pat_ty) pat_ty, res) } - AsPat x (L nm_loc name) pat -> do + 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. ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty) @@ -417,7 +427,7 @@ -- -- If you fix it, don't forget the bindInstsOfPatIds! ; pat_ty <- readExpType (scaledThing pat_ty) - ; return (mkHsWrapPat (wrap <.> mult_wrap) (AsPat x (L nm_loc bndr_id) pat') pat_ty, res) } + ; return (mkHsWrapPat (wrap <.> mult_wrap) (AsPat x (L nm_loc bndr_id) at pat') pat_ty, res) } ViewPat _ expr pat -> do { mult_wrap <- checkManyPattern pat_ty @@ -685,16 +695,14 @@ ge' minus'' ; return (mkHsWrapPat mult_wrap pat' pat_ty, res) } --- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSplicePat'. -- 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. - SplicePat _ splice -> case splice of - (HsSpliced _ mod_finalizers (HsSplicedPat pat)) -> do + SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do { addModFinalizersWithLclEnv mod_finalizers ; tc_pat pat_ty penv pat thing_inside } - _ -> panic "invalid splice in splice pat" + SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat" + XPat (HsPatExpanded lpat rpat) -> do { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside ; return (XPat $ ExpansionPat lpat rpat', res) } @@ -745,26 +753,29 @@ -- and not already in scope. These are the ones -- that should be brought into scope - ; if null sig_tvs then do { + ; case NE.nonEmpty sig_tvs of + Nothing -> do { -- Just do the subsumption check and return wrap <- addErrCtxtM (mk_msg sig_ty) $ tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty ; return (sig_ty, [], sig_wcs, wrap) - } else do + } + Just sig_tvs_ne -> do -- Type signature binds at least one scoped type variable -- A pattern binding cannot bind scoped type variables -- It is more convenient to make the test here -- than in the renamer - { when in_pat_bind (addErr (patBindSigErr sig_tvs)) + when in_pat_bind + (addErr (TcRnCannotBindScopedTyVarInPatSig sig_tvs_ne)) - -- Now do a subsumption check of the pattern signature against res_ty - ; wrap <- addErrCtxtM (mk_msg sig_ty) $ - tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty + -- Now do a subsumption check of the pattern signature against res_ty + wrap <- addErrCtxtM (mk_msg sig_ty) $ + tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty - -- Phew! - ; return (sig_ty, sig_tvs, sig_wcs, wrap) - } } + -- Phew! + return (sig_ty, sig_tvs, sig_wcs, wrap) + } where mk_msg sig_ty tidy_env = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty @@ -776,14 +787,7 @@ 2 (ppr res_ty)) ] ; return (tidy_env, msg) } -patBindSigErr :: [(Name,TcTyVar)] -> TcRnMessage -patBindSigErr sig_tvs - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "You cannot bind scoped type variable" <> plural sig_tvs - <+> pprQuotedList (map fst sig_tvs)) - 2 (text "in a pattern binding signature") - {- ********************************************************************* * * Most of the work for constructors is here @@ -865,10 +869,10 @@ tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside = do { con_like <- tcLookupConLike con_name ; case con_like of - RealDataCon data_con -> tcDataConPat penv con_lname data_con - pat_ty arg_pats thing_inside - PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn - pat_ty arg_pats thing_inside + RealDataCon data_con -> tcDataConPat con_lname data_con pat_ty + penv arg_pats thing_inside + PatSynCon pat_syn -> tcPatSynPat con_lname pat_syn pat_ty + penv arg_pats thing_inside } -- Warn when pattern matching on a GADT or a pattern synonym @@ -884,12 +888,11 @@ -- In #20485 this was made into a warning. } -tcDataConPat :: PatEnv -> LocatedN Name -> DataCon +tcDataConPat :: LocatedN Name -> DataCon -> Scaled ExpSigmaTypeFRR -- Type of the pattern - -> HsConPatDetails GhcRn -> TcM a - -> TcM (Pat GhcTc, a) -tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled - arg_pats thing_inside + -> Checker (HsConPatDetails GhcRn) (Pat GhcTc) +tcDataConPat (L con_span con_name) data_con pat_ty_scaled + penv arg_pats thing_inside = do { let tycon = dataConTyCon data_con -- For data families this is the representation tycon (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) @@ -925,21 +928,15 @@ -- Why "super"? See Note [Binding when looking up instances] -- in GHC.Core.InstEnv. - ; let arg_tys' = substScaledTys tenv arg_tys - pat_mult = scaledMult pat_ty_scaled + ; let arg_tys' = substScaledTys tenv arg_tys + pat_mult = scaledMult pat_ty_scaled arg_tys_scaled = map (scaleScaled pat_mult) arg_tys' + con_like = RealDataCon data_con -- This check is necessary to uphold the invariant that 'tcConArgs' -- is given argument types with a fixed runtime representation. -- See test case T20363. - ; zipWithM_ - ( \ i arg_sty -> - hasFixedRuntimeRep_syntactic - (FRRDataConArg Pattern data_con i) - (scaledThing arg_sty) - ) - [1..] - arg_tys' + ; checkFixedRuntimeRep data_con arg_tys' ; traceTc "tcConPat" (vcat [ text "con_name:" <+> ppr con_name , text "univ_tvs:" <+> pprTyVars univ_tvs @@ -951,11 +948,15 @@ , text "pat_ty:" <+> ppr pat_ty , text "arg_tys':" <+> ppr arg_tys' , text "arg_pats" <+> ppr arg_pats ]) + + ; (univ_ty_args, ex_ty_args) <- splitConTyArgs con_like 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) <- tcConArgs (RealDataCon data_con) arg_tys_scaled - tenv penv arg_pats thing_inside + (arg_pats', res) <- tcConTyArgs tenv penv univ_ty_args $ + tcConValArgs con_like arg_tys_scaled + penv arg_pats thing_inside ; let res_pat = ConPat { pat_con = header , pat_args = arg_pats' , pat_con_ext = ConPatTc @@ -978,8 +979,11 @@ ; given <- newEvVars theta' ; (ev_binds, (arg_pats', res)) - <- checkConstraints (getSkolemInfo skol_info) ex_tvs' given $ - tcConArgs (RealDataCon data_con) arg_tys_scaled tenv penv arg_pats thing_inside + <- -- See Note [Type applications in patterns] (W4) + 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 ; let res_pat = ConPat { pat_con = header @@ -995,11 +999,10 @@ ; return (mkHsWrapPat wrap res_pat pat_ty, res) } } -tcPatSynPat :: PatEnv -> LocatedN Name -> PatSyn +tcPatSynPat :: LocatedN Name -> PatSyn -> Scaled ExpSigmaType -- ^ Type of the pattern - -> HsConPatDetails GhcRn -> TcM a - -> TcM (Pat GhcTc, a) -tcPatSynPat penv (L con_span con_name) pat_syn pat_ty arg_pats thing_inside + -> Checker (HsConPatDetails GhcRn) (Pat GhcTc) +tcPatSynPat (L con_span con_name) pat_syn pat_ty penv arg_pats thing_inside = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn ; (subst, univ_tvs') <- newMetaTyVars univ_tvs @@ -1022,23 +1025,27 @@ arg_tys_scaled = map (scaleScaled pat_mult) arg_tys' prov_theta' = substTheta tenv prov_theta req_theta' = substTheta tenv req_theta + con_like = PatSynCon pat_syn ; when (any isEqPred prov_theta) warnMonoLocalBinds ; mult_wrap <- checkManyPattern pat_ty -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify. - ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty' - ; traceTc "tcPatSynPat" (ppr pat_syn $$ - ppr pat_ty $$ - ppr ty' $$ - ppr ex_tvs' $$ - ppr prov_theta' $$ - ppr req_theta' $$ - ppr arg_tys') + ; (univ_ty_args, ex_ty_args) <- splitConTyArgs con_like arg_pats - ; prov_dicts' <- newEvVars prov_theta' + ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty' + ; traceTc "tcPatSynPat" $ + vcat [ text "Pat syn:" <+> ppr pat_syn + , text "Expected type:" <+> ppr pat_ty + , text "Pat res ty:" <+> ppr ty' + , text "ex_tvs':" <+> pprTyVars ex_tvs' + , text "prov_theta':" <+> ppr prov_theta' + , text "req_theta':" <+> ppr req_theta' + , text "arg_tys':" <+> ppr arg_tys' + , text "univ_ty_args:" <+> ppr univ_ty_args + , text "ex_ty_args:" <+> ppr ex_ty_args ] ; req_wrap <- instCall (OccurrenceOf con_name) (mkTyVarTys univ_tvs') req_theta' -- Origin (OccurrenceOf con_name): @@ -1059,11 +1066,16 @@ , text "bad_arg_tys:" <+> ppr bad_arg_tys ] ; traceTc "checkConstraints {" Outputable.empty + ; prov_dicts' <- newEvVars prov_theta' ; (ev_binds, (arg_pats', res)) - <- checkConstraints (getSkolemInfo skol_info) ex_tvs' prov_dicts' $ - tcConArgs (PatSynCon pat_syn) arg_tys_scaled tenv penv arg_pats thing_inside - + <- -- 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 $ + thing_inside ; traceTc "checkConstraints }" (ppr ev_binds) + ; let res_pat = ConPat { pat_con = L con_span $ PatSynCon pat_syn , pat_args = arg_pats' , pat_con_ext = ConPatTc @@ -1077,6 +1089,14 @@ ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat (wrap <.> mult_wrap) res_pat pat_ty, res) } +checkFixedRuntimeRep :: DataCon -> [Scaled TcSigmaTypeFRR] -> TcM () +checkFixedRuntimeRep data_con arg_tys + = zipWithM_ check_one [1..] arg_tys + where + check_one i arg_ty = hasFixedRuntimeRep_syntactic + (FRRDataConPatArg data_con i) + (scaledThing arg_ty) + {- Note [Call-stack tracing of pattern synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -1111,7 +1131,7 @@ ; (wrap, pat_rho) <- topInstantiate orig pat_ty ; (co, res) <- inner_match pat_rho ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap) - ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) } + ; return (mkWpCastN (mkSymCo co) <.> wrap, res) } ---------------------------- matchExpectedConTy :: PatEnv @@ -1148,10 +1168,10 @@ -- for actual vs. expected in error messages. ; let tys' = mkTyVarTys tvs' - co2 = mkTcUnbranchedAxInstCo co_tc tys' [] + co2 = mkUnbranchedAxInstCo Representational co_tc tys' [] -- co2 : T (ty1,ty2) ~R T7 ty1 ty2 - full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2 + full_co = mkSubCo (mkSymCo co1) `mkTransCo` co2 -- full_co :: pat_rho ~R T7 ty1 ty2 ; return ( mkWpCastR full_co <.> wrap, tys') } @@ -1160,7 +1180,7 @@ = do { pat_ty <- expTypeToType (scaledThing exp_pat_ty) ; (wrap, pat_rho) <- topInstantiate orig pat_ty ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho - ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) } + ; return (mkWpCastN (mkSymCo coi) <.> wrap, tys) } {- Note [Matching constructor patterns] @@ -1191,84 +1211,128 @@ error messages; it's a purely internal thing -} -{- -Note [Typechecking type applications in patterns] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How should we typecheck type applications in patterns, such as +{- Note [Type applications in patterns] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type applications in patterns are enabled by -XTypeAbstractions. +For example: f :: Either (Maybe a) [b] -> blah f (Left @x @[y] (v::Maybe x)) = blah -It's quite straightforward, and very similar to the treatment of -pattern signatures. +How should we typecheck them? The basic plan is pretty simple, and is +all done in tcConTyArgs. For each type argument: -* Step 1: bind the newly-in-scope type variables x and y to fresh - unification variables, say x0 and y0. +* Step 1: + * bind the newly-in-scope type variables (here `x` or `y`) to + unification variables, say `x0` or `y0` -* Step 2: typecheck those type arguments, @x and @[y], to get the - types x0 and [y0]. + * typecheck the type argument, `@x` or `@[y]` to get the + types `x0` or `[y0]`. -* Step 3: Unify those types with the type arguments we expect, - in this case (Maybe a) and [b]. These unifications will - (perhaps after the constraint solver has done its work) + This step is done by `tcHsPatSigType`, similar to the way we + deal with pattern signatures. + +* Step 2: Unify those types with the type arguments we expect from + the context, in this case (Maybe a) and [b]. These unifications + will (perhaps after the constraint solver has done its work) unify x0 := Maybe a y0 := b Thus we learn that x stands for (Maybe a) and y for b. -Wrinkles: +* Step 3: Extend the lexical context to bind `x` to `x0` and + `y` to `y0`, and typecheck the body of the pattern match. -* Surprisingly, we can discard the coercions arising from - these unifications. The *only* thing the unification does is - to side-effect those unification variables, so that we know - what type x and y stand for; and cause an error if the equality - is not soluble. It's a bit like a constraint arising - from a functional dependency, where we don't use the evidence. +However there are several quite tricky wrinkles. -* Exactly the same works for existential arguments - data T where - MkT :: a -> a -> T - f :: T -> blah - f (MkT @x v w) = ... - Here we create a fresh unification variable x0 for x, and - unify it with the fresh existential variable bound by the pattern. +(W1) Surprisingly, we can discard the coercions arising from + these unifications. The *only* thing the unification does is + to side-effect those unification variables, so that we know + what type x and y stand for; and cause an error if the equality + is not soluble. It's a bit like a constraint arising + from a functional dependency, where we don't use the evidence. -* Note that both here and in pattern signatures the unification may - not even end up unifying the variable. For example - type S a b = a - f :: Maybe a -> Bool - f (Just @(S a b) x) = True :: b - In Step 3 we will unify (S a0 b0 ~ a), which succeeds, but has no - effect on the unification variable b0, to which 'b' is bound. - Later, in the RHS, we find that b0 must be Bool, and unify it there. - All is fine. +(W2) Note that both here and in pattern signatures the unification may + not even end up unifying the variable. For example + type S a b = a + f :: Maybe a -> Bool + f (Just @(S a b) x) = True :: b + In Step 2 we will unify (S a0 b0 ~ a), which succeeds, but has no + effect on the unification variable b0, to which 'b' is bound. + Later, in the RHS, we find that b0 must be Bool, and unify it there. + All is fine. + +(W3) The order of the arguments to the /data constructor/ may differ from + the order of the arguments to the /type constructor/. Example + data T a b where { MkT :: forall c d. (c,d) -> T d c } + f :: T Int Bool -> blah + f (MkT @x @y p) = ... + The /first/ type argument to `MkT`, namely `@x` corresponds to the + /second/ argument to `T` in the type `T Int Bool`. So `x` is bound + to `Bool` -- not to `Int`!. That is why splitConTyArgs uses + conLikeUserTyVarBinders to match up with the user-supplied type arguments + in the pattern, not dataConUnivTyVars/dataConExTyVars. + +(W4) A similar story works for existentials, but it is subtly different + (#19847). Consider + data T a where { MkT :: forall a b. a -> b -> T a } + f :: T Int -> blah + f (MkT @x @y v w) = blah + Here we create a fresh unification variables x0,y0 for x,y and + unify x0~Int, y0~b, where b is the fresh existential variable bound by + the pattern. But + * (x0~Int) must be /outside/ the implication constraint + * (y0~b) must be /inside/ it + (and hence x0 and y0 themselves must have different levels). + Thus: + x0[1]~Int, (forall[2] b. (y0[2]~b, ...constraints-from-blah...)) + + We need (x0~Int) /outside/ so that it can influence the type of the + pattern in an inferred setting, e.g. + g :: T _ -> blah + g (MkT @Int @y v w) = blah + Here we want to infer `g` to have type `T Int -> blah`. If the + (x0~Int) was inside the implication, and the the constructor bound + equality constraints, `x0` would be untouchable. This was the root + cause of #19847. + + We need (y0~b) to be /inside/ the implication, so that `b` is in + scope. In fact, we may actually /need/ equalities bound by the + implication to prove the equality constraint we generate. + Example data T a where + MkT :: forall p q. T (p,q) + f :: T (Int,Bool) -> blah + f (MkT @Int @Bool) = ... + We get the implication + forall[2] p q. (p,q)~(Int,Bool) => (p ~ Int, q ~ Bool, ...) + where the Given comes from the GADT match, while (p~Int, q~Bool) + comes from matching the type arguments. + + Wow. That's all quite subtle! See the long discussion on #19847. We + must treat universal and existential arguments separately, even though + they are all mixed up (W3). The function splitConTyArgs separates the + universals from existentials; and we build the implication between + typechecking the two sets: + tcConTyArgs ... univ_ty_args $ + checkConstraints ... $ + tcConTyArgs ... ex_ty_args $ + ..typecheck body.. + You can see this code shape in tcDataConPat and tcPatSynPat. + + Where pattern synonyms are involved, this two-level split may not be + enough. See #22328 for the story. -} -tcConArgs :: ConLike - -> [Scaled TcSigmaTypeFRR] - -> TCvSubst -- Instantiating substitution for constructor type - -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc) -tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of +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 + -- 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) - -- forgetting to filter out inferred binders led to #20443 - ; let con_spec_binders = filter ((== SpecifiedSpec) . binderArgFlag) $ - conLikeUserTyVarBinders con_like - ; checkTc (type_args `leLength` con_spec_binders) - (conTyArgArityErr con_like (length con_spec_binders) (length type_args)) - ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys - ; (type_args', (arg_pats', res)) - <- tcMultiple tcConTyArg penv type_args $ - tcMultiple tcConArg penv pats_w_tys thing_inside - - -- This unification is straight from Figure 7 of - -- "Type Variables in Patterns", Haskell'18 - ; _ <- zipWithM (unifyType Nothing) type_args' (substTyVars tenv $ - binderVars con_spec_binders) - -- OK to drop coercions here. These unifications are all about - -- guiding inference based on a user-written type annotation - -- See Note [Typechecking type applications in patterns] + ; (arg_pats', res) <- tcMultiple tcConArg penv pats_w_tys thing_inside ; return (PrefixCon type_args arg_pats', res) } where @@ -1302,7 +1366,7 @@ pun), res) } - find_field_ty :: Name -> FieldLabelString -> TcM (Scaled TcType) + find_field_ty :: Name -> FastString -> TcM (Scaled TcType) find_field_ty sel lbl = case [ty | (fl, ty) <- field_tys, flSelector fl == sel ] of @@ -1312,7 +1376,7 @@ -- f (R { foo = (a,b) }) = a+b -- If foo isn't one of R's fields, we don't want to crash when -- typechecking the "a+b". - [] -> failWith (badFieldConErr (getName con_like) lbl) + [] -> failWith (badFieldConErr (getName con_like) (FieldLabelString lbl)) -- The normal case, when the field comes from the right constructor (pat_ty : extras) -> do @@ -1325,23 +1389,73 @@ -- dataConFieldLabels will be empty (and each field in the pattern -- will generate an error below). -tcConTyArg :: Checker (HsPatSigType GhcRn) TcType -tcConTyArg penv rn_ty thing_inside + +splitConTyArgs :: ConLike -> HsConPatDetails GhcRn + -> TcM ( [(HsConPatTyArg GhcRn, TyVar)] -- Universals + , [(HsConPatTyArg GhcRn, TyVar)] ) -- Existentials +-- 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) } + 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_universal (_, tv) = not (tv `elem` ex_tvs) + -- See Note [DataCon user type variable binders] in GHC.Core.DataCon + -- especially INVARIANT(dataConTyVars). + +splitConTyArgs _ (RecCon {}) = return ([], []) -- No type args in RecCon +splitConTyArgs _ (InfixCon {}) = return ([], []) -- No type args in InfixCon + +tcConTyArgs :: Subst -> PatEnv -> [(HsConPatTyArg 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 in tcConArgs, which will also unify - -- kinds. - ; when (not (null sig_ibs) && inPatBind penv) $ - addErr (TcRnUnknownMessage $ mkPlainError noHints $ - text "Binding type variables is not allowed in pattern bindings") + -- by the calls to unifyType below which unifies kinds + + ; case NE.nonEmpty sig_ibs of + Just sig_ibs_ne | inPatBind penv -> + addErr (TcRnCannotBindTyVarsInPatBind sig_ibs_ne) + _ -> pure () + + -- This unification is straight from Figure 7 of + -- "Type Variables in Patterns", Haskell'18 + -- OK to drop coercions here. These unifications are all about + -- guiding inference based on a user-written type annotation + -- See Note [Type applications in patterns] (W1) + ; _ <- unifyType Nothing arg_ty (substTyVar tenv con_tv) + ; result <- tcExtendNameTyVarEnv sig_wcs $ tcExtendNameTyVarEnv sig_ibs $ thing_inside - ; return (arg_ty, result) } + -- NB: Because we call tConTyArgs twice, once for universals and + -- once for existentials; so this brings things into scope + -- "out of left-right order". But it doesn't matter; the renamer + -- has dealt with all that. + ; return ((), result) } + tcConArg :: Checker (LPat GhcRn, Scaled TcSigmaType) (LPat GhcTc) tcConArg penv (arg_pat, Scaled arg_mult arg_ty) = tc_lpat (Scaled arg_mult (mkCheckExpType arg_ty)) penv arg_pat @@ -1364,15 +1478,6 @@ -- because the constructor might have existentials inst_theta = substTheta tenv stupid_theta -conTyArgArityErr :: ConLike - -> Int -- expected # of arguments - -> Int -- actual # of arguments - -> TcRnMessage -conTyArgArityErr con_like expected_number actual_number - = TcRnUnknownMessage $ mkPlainError noHints $ - 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 - {- Note [Arrows and patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1402,12 +1507,8 @@ plan in general to bypass the constraint simplification step entirely when it's not needed. -************************************************************************ -* * - Note [Pattern coercions] -* * -************************************************************************ - +Note [Pattern coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ In principle, these program would be reasonable: f :: (forall a. a->a) -> Int @@ -1518,8 +1619,3 @@ where has_existentials :: Bool has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs - -polyPatSig :: TcType -> SDoc -polyPatSig sig_ty - = hang (text "Illegal polymorphic type signature in pattern:") - 2 (ppr sig_ty) diff --git a/GHC/Tc/Gen/Rule.hs b/GHC/Tc/Gen/Rule.hs --- a/GHC/Tc/Gen/Rule.hs +++ b/GHC/Tc/Gen/Rule.hs @@ -17,7 +17,6 @@ import GHC.Tc.Solver import GHC.Tc.Solver.Monad ( runTcS ) import GHC.Tc.Types.Constraint -import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType @@ -25,9 +24,12 @@ import GHC.Tc.Gen.Expr import GHC.Tc.Utils.Env import GHC.Tc.Utils.Unify( buildImplicationFor ) -import GHC.Tc.Types.Evidence( mkTcCoVarCo ) + 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 @@ -103,23 +105,22 @@ tcRules decls = mapM (wrapLocMA tcRuleDecls) decls tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc) -tcRuleDecls (HsRules { rds_src = src +tcRuleDecls (HsRules { rds_ext = src , rds_rules = decls }) = do { tc_decls <- mapM (wrapLocMA tcRule) decls - ; return $ HsRules { rds_ext = noExtField - , rds_src = src + ; 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_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 rname) + do { traceTc "---- Rule ------" (pprFullRuleName (snd ext) rname) ; skol_info <- mkSkolemInfo (RuleSkol name) -- Note [Typechecking rules] ; (tc_lvl, stuff) <- pushTcLevelM $ @@ -128,7 +129,7 @@ ; let (id_bndrs, lhs', lhs_wanted , rhs', rhs_wanted, rule_ty) = stuff - ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname + ; traceTc "tcRule 1" (vcat [ pprFullRuleName (snd ext) rname , ppr lhs_wanted , ppr rhs_wanted ]) @@ -157,7 +158,7 @@ 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 rname + ; 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 @@ -166,7 +167,8 @@ , text "rule_ty:" <+> ppr rule_ty , text "ty_bndrs:" <+> ppr ty_bndrs , text "qtkvs ++ tpl_ids:" <+> ppr (qtkvs ++ tpl_ids) - , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] + , text "tpl_id info:" <+> + vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ] ]) -- SimplfyRule Plan, step 5 @@ -230,7 +232,7 @@ tcRuleTmBndrs rule_name (L _ (RuleBndr _ (L _ name)) : rule_bndrs) = do { ty <- newOpenFlexiTyVarTy ; (tyvars, tmvars) <- tcRuleTmBndrs rule_name rule_bndrs - ; return (tyvars, mkLocalId name Many ty : tmvars) } + ; 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 @@ -239,7 +241,7 @@ -- 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 Many id_ty + ; 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 @@ -445,7 +447,7 @@ EvVarDest ev_id -> return ev_id HoleDest hole -> -- See Note [Quantifying over coercion holes] do { ev_id <- newEvVar pred - ; fillCoercionHole hole (mkTcCoVarCo ev_id) + ; fillCoercionHole hole (mkCoVarCo ev_id) ; return ev_id } mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct) 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 @@ -26,6 +26,7 @@ ) where import GHC.Prelude +import GHC.Data.FastString import GHC.Driver.Session import GHC.Driver.Backend @@ -51,9 +52,10 @@ 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 ) +import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars, invisArgTypeLike ) import GHC.Types.Id ( Id, idName, idType, setInlinePragma , mkLocalId, realIdUnfolding ) import GHC.Types.Basic @@ -68,9 +70,10 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Data.Maybe( orElse ) +import GHC.Data.Maybe( orElse, whenIsJust ) import Data.Maybe( mapMaybe ) +import qualified Data.List.NonEmpty as NE import Control.Monad( unless ) @@ -111,7 +114,7 @@ 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, raather + 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. @@ -188,7 +191,7 @@ ; return (poly_ids, lookupNameEnv env) } tcTySig :: LSig GhcRn -> TcM [TcSigInfo] -tcTySig (L _ (IdSig _ id)) +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! @@ -228,7 +231,7 @@ = do { sigma_ty <- tcHsSigWcType ctxt_no_rrc hs_sig_ty ; traceTc "tcuser" (ppr sigma_ty) ; return $ - CompleteSig { sig_bndr = mkLocalId name Many sigma_ty + 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 @@ -245,7 +248,7 @@ where name = case mb_name of Just n -> n - Nothing -> mkUnboundName (mkVarOcc "") + Nothing -> mkUnboundName (mkVarOccFS (fsLit "")) ctxt_rrc = ctxt_fn (lhsSigWcTypeContextSpan hs_sig_ty) ctxt_no_rrc = ctxt_fn NoRRC @@ -315,8 +318,8 @@ && go ty HsQualTy { hst_ctxt = ctxt , hst_body = ty } -> gos (unLoc ctxt) && go ty - HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpanA ty - HsSpliceTy{} -> True + HsSpliceTy (HsUntypedSpliceTop _ ty) _ -> go ty + HsSpliceTy (HsUntypedSpliceNested _) _ -> True HsTyLit{} -> True HsTyVar{} -> True HsStarTy{} -> True @@ -454,7 +457,7 @@ -- Neither argument types nor the return type may be representation polymorphic. -- This is because, when creating a matcher: - -- - the argument types become the the binder types (see test RepPolyPatySynArg), + -- - 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_ @@ -483,11 +486,19 @@ build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body = mkInvisForAllTys implicit_bndrs $ mkInvisForAllTys univ_bndrs $ - mkPhiTy req $ + mk_naked_phi_ty req $ mkInvisForAllTys ex_bndrs $ - mkPhiTy prov $ + 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]) @@ -504,7 +515,7 @@ -- 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 poly_id + do { (tv_prs, theta, tau) <- tcInstTypeBndrs (idType poly_id) -- See Note [Pattern bindings and complete signatures] ; return (TISI { sig_inst_sig = sig @@ -521,6 +532,7 @@ 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 @@ -579,7 +591,7 @@ 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 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 @@ -631,16 +643,10 @@ warn_multiple_inlines inl2 inls | otherwise = setSrcSpanA loc $ - let dia = TcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints $ - (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) - 2 (vcat (text "Ignoring all but the first" - : map pp_inl (inl1:inl2:inls)))) + let dia = TcRnMultipleInlinePragmas poly_id inl1 (inl2 NE.:| inls) in addDiagnosticTc dia - pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) - {- Note [Pattern synonym inline arity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -776,7 +782,7 @@ -- Reason: required by tcSubExp tcSpecPrags poly_id prag_sigs = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) - ; unless (null bad_sigs) warn_discarded_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 @@ -784,11 +790,8 @@ bad_sigs = filter is_bad_sig prag_sigs is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) - warn_discarded_sigs - = let dia = TcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints $ - (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) - 2 (vcat (map (ppr . getLoc) bad_sigs))) + warn_discarded_sigs bad_sigs_ne + = let dia = TcRnUnexpectedPragmas poly_id bad_sigs_ne in addDiagnosticTc dia -------------- @@ -803,9 +806,7 @@ -- what the user wrote (#8537) = addErrCtxt (spec_ctxt prag) $ do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) $ - TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints - (text "SPECIALISE pragma for non-overloaded function" - <+> quotes (ppr fun_name)) + 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))) @@ -858,12 +859,8 @@ -- 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) = True - | otherwise = case backend dflags of - NoBackend -> True - Interpreter -> True - _other -> False + not_specialising dflags = + not (gopt Opt_Specialise dflags) || not (backendRespectsSpecialise (backend dflags)) tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] tcImpSpec (name, prag) @@ -871,20 +868,9 @@ ; if hasSomeUnfolding (realIdUnfolding id) -- See Note [SPECIALISE pragmas for imported Ids] then tcSpecPrag id prag - else do { let dia = TcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints (impSpecErr name) + else do { let dia = TcRnSpecialiseNotVisible name ; addDiagnosticTc dia ; return [] } } - -impSpecErr :: Name -> SDoc -impSpecErr name - = hang (text "You cannot SPECIALISE" <+> quotes (ppr name)) - 2 (vcat [ text "because its definition is not visible in this module" - , text "Hint: make sure" <+> ppr mod <+> text "is compiled with -O" - , text " and that" <+> quotes (ppr name) - <+> text "has an INLINABLE pragma" ]) - where - mod = nameModule name {- Note [SPECIALISE pragmas for imported Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 @@ -20,2634 +20,2839 @@ -- | Template Haskell splices module GHC.Tc.Gen.Splice( - tcSpliceExpr, tcTypedBracket, tcUntypedBracket, --- runQuasiQuoteExpr, runQuasiQuotePat, --- runQuasiQuoteDecl, runQuasiQuoteType, - runAnnotation, - - runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, - tcTopSpliceExpr, lookupThName_maybe, - defaultRunMeta, runMeta', runRemoteModFinalizers, - finishTH, runTopSplice - ) where - -import GHC.Prelude - -import GHC.Driver.Errors -import GHC.Driver.Plugins -import GHC.Driver.Main -import GHC.Driver.Session -import GHC.Driver.Env -import GHC.Driver.Hooks -import GHC.Driver.Config.Diagnostic -import GHC.Driver.Config.Finder - -import GHC.Hs - -import GHC.Tc.Errors.Types -import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.TcType -import GHC.Tc.Gen.Expr -import GHC.Tc.Utils.Unify -import GHC.Tc.Utils.Env -import GHC.Tc.Types.Origin -import GHC.Tc.Types.Evidence -import GHC.Tc.Utils.Zonk -import GHC.Tc.Solver -import GHC.Tc.Utils.TcMType -import GHC.Tc.Gen.HsType -import GHC.Tc.Instance.Family -import GHC.Tc.Utils.Instantiate - -import GHC.Core.Multiplicity -import GHC.Core.Coercion( etaExpandCoAxBranch ) -import GHC.Core.Type as Type -import GHC.Core.TyCo.Rep as TyCoRep -import GHC.Core.FamInstEnv -import GHC.Core.InstEnv as InstEnv - -import GHC.Builtin.Names.TH -import GHC.Builtin.Names -import GHC.Builtin.Types - -import GHC.ThToHs -import GHC.HsToCore.Docs -import GHC.HsToCore.Expr -import GHC.HsToCore.Monad -import GHC.IfaceToCore -import GHC.Iface.Load - -import GHCi.Message -import GHCi.RemoteTypes -import GHC.Runtime.Interpreter - -import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) -import GHC.Rename.Expr -import GHC.Rename.Env -import GHC.Rename.Fixity ( lookupFixityRn_help ) -import GHC.Rename.HsType - -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Core.Coercion.Axiom -import GHC.Core.PatSyn -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 -import GHC.Types.Name.Reader -import GHC.Types.Name.Occurrence as OccName -import GHC.Types.Var -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Unique -import GHC.Types.Var.Set -import GHC.Types.Meta -import GHC.Types.Basic hiding( SuccessFlag(..) ) -import GHC.Types.Error -import GHC.Types.Fixity as Hs -import GHC.Types.Annotations -import GHC.Types.Name -import GHC.Types.Unique.Map -import GHC.Serialized - -import GHC.Unit.Finder -import GHC.Unit.Module -import GHC.Unit.Module.ModIface -import GHC.Unit.Module.Deps - -import GHC.Utils.Misc -import GHC.Utils.Panic as Panic -import GHC.Utils.Panic.Plain -import GHC.Utils.Lexeme -import GHC.Utils.Outputable -import GHC.Utils.Logger -import GHC.Utils.Exception (throwIO, ErrorCall(..)) - -import GHC.Utils.TmpFs ( newTempName, TempFileLifetime(..) ) - -import GHC.Data.FastString -import GHC.Data.Maybe( MaybeErr(..) ) -import qualified GHC.Data.EnumSet as EnumSet - -import qualified Language.Haskell.TH as TH --- THSyntax gives access to internal functions and data types -import qualified Language.Haskell.TH.Syntax as TH - -#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 ) -#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 -import Data.Dynamic ( fromDynamic, toDyn ) -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map -import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) -import Data.Data (Data) -import Data.Proxy ( Proxy (..) ) -import GHC.Parser.HaddockLex (lexHsDoc) -import GHC.Parser (parseIdentifier) -import GHC.Rename.Doc (rnHsDoc) - -{- -************************************************************************ -* * -\subsection{Main interface + stubs for the non-GHCI case -* * -************************************************************************ --} - -tcTypedBracket :: HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -tcUntypedBracket :: HsExpr GhcRn -> HsQuote GhcRn -> [PendingRnSplice] -> ExpRhoType - -> TcM (HsExpr GhcTc) -tcSpliceExpr :: HsSplice GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) - -- None of these functions add constraints to the LIE - --- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName) --- runQuasiQuotePat :: HsQuasiQuote RdrName -> RnM (LPat RdrName) --- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName) --- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName] - -runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation -{- -************************************************************************ -* * -\subsection{Quoting an expression} -* * -************************************************************************ --} - --- 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 [] - ; lie_var <- getConstraintVar -- Any constraints arising from nested splices - -- should get thrown into the constraint set - -- from outside the bracket - - -- Make a new type variable for the type of the overall quote - ; m_var <- mkTyVarTy <$> mkMetaTyVar - -- Make sure the type variable satisfies Quote - ; ev_var <- emitQuoteWanted m_var - -- 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, but we return it with its type. - -- (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)) $ - tcScalingUsage Many $ - -- 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 - ; codeco <- tcLookupId unsafeCodeCoerceName - ; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName - ; tcWrapResultO (Shouldn'tHappenOrigin "TH typed bracket expression") - rn_expr - (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper) - (nlHsTyApp codeco [rep, expr_ty])) - (noLocA (HsTypedBracket (HsBracketTc (ExpBr noExtField expr) bracket_ty (Just wrapper) ps') tc_expr)))) - meta_ty res_ty } - --- See Note [Typechecking Overloaded Quotes] -tcUntypedBracket rn_expr brack ps res_ty - = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) - - - -- Create the type m Exp for expression bracket, m Type for a type - -- bracket and so on. The brack_info is a Maybe because the - -- VarBracket ('a) isn't overloaded, but also shouldn't contain any - -- splices. - ; (brack_info, expected_type) <- brackTy brack - - -- 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 - Nothing -> assert (null ps) $ return [] - - ; traceTc "tc_bracket done untyped" (ppr expected_type) - - -- Unify the overall type of the bracket with the expected result - -- type - ; tcWrapResultO BracketOrigin rn_expr - (HsUntypedBracket (HsBracketTc brack expected_type brack_info ps') (XQuote noExtField)) - -- (XQuote noExtField): see Note [The life cycle of a TH quotation] in GHC.Hs.Expr - expected_type res_ty - - } - --- | A type variable with kind * -> * named "m" -mkMetaTyVar :: TcM TyVar -mkMetaTyVar = - newNamedFlexiTyVar (fsLit "m") (mkVisFunTyMany liftedTypeKind liftedTypeKind) - - --- | For a type 'm', emit the constraint 'Quote m'. -emitQuoteWanted :: Type -> TcM EvVar -emitQuoteWanted m_var = do - quote_con <- tcLookupTyCon quoteClassName - emitWantedEvVar BracketOrigin $ - mkTyConApp quote_con [m_var] - ---------------- --- | Compute the expected type of a quotation, and also the QuoteWrapper in --- the case where it is an overloaded quotation. All quotation forms are --- overloaded aprt from Variable quotations ('foo) -brackTy :: HsQuote GhcRn -> TcM (Maybe QuoteWrapper, Type) -brackTy b = - let mkTy n = do - -- New polymorphic type variable for the bracket - m_var <- mkTyVarTy <$> mkMetaTyVar - -- Emit a Quote constraint for the bracket - ev_var <- emitQuoteWanted m_var - -- Construct the final expected type of the quote, for example - -- m Exp or m Type - final_ty <- mkAppTy m_var <$> tcMetaTy n - -- Return the evidence variable and metavariable to be used during - -- desugaring. - let wrapper = QuoteWrapper ev_var m_var - return (Just wrapper, final_ty) - in - case b of - (VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName - -- Result type is Var (not Quote-monadic) - (ExpBr {}) -> mkTy expTyConName -- Result type is m Exp - (TypBr {}) -> mkTy typeTyConName -- Result type is m Type - (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec] - (PatBr {}) -> mkTy patTyConName -- Result type is m Pat - (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL" - ---------------- --- | Typechecking a pending splice from a untyped bracket -tcPendingSplice :: TcType -- Metavariable for the expected overall type of the - -- quotation. - -> PendingRnSplice - -> TcM PendingTcSplice -tcPendingSplice m_var (PendingRnSplice flavour splice_name 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 - ; expr' <- tcScalingUsage Many $ 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 - ---------------- --- 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 (err_msg exp_ty) - ; codeCon <- tcLookupTyCon codeTyConName - ; let rep = getRuntimeRep exp_ty - ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) } - where - err_msg ty - = TcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal polytype:" <+> ppr ty - , text "The type of a Typed Template Haskell expression must" <+> - text "not have any quantification." ] - -quotationCtxtDoc :: LHsExpr GhcRn -> SDoc -quotationCtxtDoc br_body - = hang (text "In the Template Haskell quotation") - 2 (thTyBrackets . ppr $ br_body) - - - -- The whole of the rest of the file is the else-branch (ie stage2 only) - -{- -Note [How top-level splices are handled] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Top-level splices (those not inside a [| .. |] quotation bracket) are handled -very straightforwardly: - - 1. tcTopSpliceExpr: typecheck the body e of the splice $(e) - - 2. runMetaT: desugar, compile, run it, and convert result back to - GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName, - HsExpr RdrName etc) - - 3. treat the result as if that's what you saw in the first place - e.g for HsType, rename and kind-check - for HsExpr, rename and type-check - - (The last step is different for decls, because they can *only* be - top-level: we return the result of step 2.) - -Note [How brackets and nested splices are handled] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Nested splices (those inside a [| .. |] quotation bracket), -are treated quite differently. - -Remember, there are two forms of bracket - typed [|| e ||] - and untyped [| e |] - -The life cycle of a typed bracket: - * Starts as HsTypedBracket - - * When renaming: - * Set the ThStage to (Brack s RnPendingTyped) - * Rename the body - * Result is a HsTypedBracket - - * When typechecking: - * Set the ThStage to (Brack s (TcPending ps_var lie_var)) - * Typecheck the body, and keep the elaborated result (despite never using it!) - * Nested splices (which must be typed) are typechecked, 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 - where rn_brack is the untyped renamed exp quote constructed from the typed renamed expression :: HsQuote GhcRn - -The life cycle of a un-typed bracket: - * Starts as HsUntypedBracket - - * When renaming: - * Set the ThStage to (Brack s (RnPendingUntyped ps_var)) - * Rename the body - * Nested splices (which must be untyped) are renamed, and the - results accumulated in ps_var - * Result is a HsUntypedBracket pending_splices rn_body - - * When typechecking: - * Typecheck the pending_splices individually - * Ignore the body of the bracket; just check that the context - expects a bracket of that type (e.g. a [p| pat |] bracket should - be in a context needing a (Q Pat) - * Result is a HsUntypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) (XQuote noExtField) - where rn_brack is the incoming renamed bracket :: HsQuote GhcRn - and (XQuote noExtField) stands for the removal of the `HsQuote GhcTc` field (since `HsQuote GhcTc` isn't possible) - -See the related Note [The life cycle of a TH quotation] - -In both cases, desugaring happens like this: - * Hs*Bracket is desugared by GHC.HsToCore.Quote.dsBracket using the renamed - expression held in `HsBracketTc` (`type instance X*Bracket GhcTc = HsBracketTc`). It - - a) Extends the ds_meta environment with the PendingSplices - attached to the bracket - - b) Converts the quoted (HsExpr Name) to a CoreExpr that, when - run, will produce a suitable TH expression/type/decl. This - is why we leave the *renamed* expression attached to the bracket: - the quoted expression should not be decorated with all the goop - added by the type checker - - * Each splice carries a unique Name, called a "splice point", thus - ${n}(e). The name is initialised to an (Unqual "splice") when the - splice is created; the renamer gives it a unique. - - * When GHC.HsToCore.Quote (used to desugar the body of the bracket) comes across - a splice, it looks up the splice's Name, n, in the ds_meta envt, - to find an (HsExpr Id) that should be substituted for the splice; - it just desugars it to get a CoreExpr (GHC.HsToCore.Quote.repSplice). - -Example: - Source: f = [| Just $(g 3) |] - The [| |] part is a HsUntypedBracket GhcPs - - Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3} - The [| |] part is a HsUntypedBracket GhcTc, containing *renamed* - (not typechecked) expression (see Note [The life cycle of a TH quotation]) - The "s7" is the "splice point"; the (g Int 3) part - is a typechecked expression - - Desugared: f = do { s7 <- g Int 3 - ; return (ConE "Data.Maybe.Just" s7) } - - -Note [Template Haskell state diagram] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Here are the ThStages, s, their corresponding level numbers -(the result of (thLevel s)), and their state transitions. -The top level of the program is stage Comp: - - Start here - | - V - ----------- $ ------------ $ - | Comp | ---------> | Splice | -----| - | 1 | | 0 | <----| - ----------- ------------ - ^ | ^ | - $ | | [||] $ | | [||] - | v | v - -------------- ---------------- - | Brack Comp | | Brack Splice | - | 2 | | 1 | - -------------- ---------------- - -* Normal top-level declarations start in state Comp - (which has level 1). - Annotations start in state Splice, since they are - treated very like a splice (only without a '$') - -* Code compiled in state Splice (and only such code) - 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) - -* However things at level 0 are not *necessarily* imported. - eg $( \b -> ... ) here b is bound at level 0 - -* In GHCi, variables bound by a previous command are treated - as impLevel, because we have bytecode for them. - -* Variables are bound at the "current level" - -* The current level starts off at outerLevel (= 1) - -* The level is decremented by splicing $(..) - incremented by brackets [| |] - incremented by name-quoting 'f - -* When a variable is used, checkWellStaged compares - bind: binding level, and - use: current level at usage site - - Generally - bind > use Always error (bound later than used) - [| \x -> $(f x) |] - - bind = use Always OK (bound same stage as used) - [| \x -> $(f [| x |]) |] - - bind < use Inside brackets, it depends - Inside splice, OK - Inside neither, OK - - For (bind < use) inside brackets, there are three cases: - - Imported things OK f = [| map |] - - Top-level things OK g = [| f |] - - Non-top-level Only if there is a liftable instance - h = \(x:Int) -> [| x |] - - To track top-level-ness we use the ThBindEnv in TcLclEnv - - For example: - f = ... - g1 = $(map ...) is OK - g2 = $(f ...) is not OK; because we haven't compiled f yet - -Note [Typechecking Overloaded Quotes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The main function for typechecking untyped quotations is `tcUntypedBracket`. - -Consider an expression quote, `[| e |]`, its type is `forall m . Quote m => m Exp`. -When we typecheck it we therefore create a template of a metavariable `m` applied to `Exp` and -emit a constraint `Quote m`. All this is done in the `brackTy` function. -`brackTy` also selects the correct contents type for the quotation (Exp, Type, Decs etc). - -The meta variable and the constraint evidence variable are -returned together in a `QuoteWrapper` and then passed along to two further places -during compilation: - -1. Typechecking nested splices (immediately in tcPendingSplice) -2. Desugaring quotations (see GHC.HsToCore.Quote) - -`tcPendingSplice` takes the `m` type variable as an argument and checks -each nested splice against this variable `m`. During this -process the variable `m` can either be fixed to a specific value or further constrained by the -nested splices. - -Once we have checked all the nested splices, the quote type is checked against -the expected return type. - -The process is very simple and like typechecking a list where the quotation is -like the container and the splices are the elements of the list which must have -a specific type. - -After the typechecking process is completed, the evidence variable for `Quote m` -and the type `m` is stored in a `QuoteWrapper` which is passed through the pipeline -and used when desugaring quotations. - -Typechecking typed quotations is a similar idea but the `QuoteWrapper` is stored -in the `PendingStuff` as the nested splices are gathered up in a different way -to untyped splices. Untyped splices are found in the renamer but typed splices are -not typechecked and extracted until during typechecking. - --} - --- | We only want to produce warnings for TH-splices if the user requests so. --- See Note [Warnings for TH splices]. -getThSpliceOrigin :: TcM Origin -getThSpliceOrigin = do - warn <- goptM Opt_EnableThSpliceWarnings - if warn then return FromSource else return Generated - -{- Note [Warnings for TH splices] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only produce warnings for TH splices when the user requests so -(-fenable-th-splice-warnings). There are multiple reasons: - - * It's not clear that the user that compiles a splice is the author of the code - that produces the warning. Think of the situation where they just splice in - code from a third-party library that produces incomplete pattern matches. - In this scenario, the user isn't even able to fix that warning. - * Gathering information for producing the warnings (pattern-match check - warnings in particular) is costly. There's no point in doing so if the user - is not interested in those warnings. - -That's why we store Origin flags in the Haskell AST. The functions from ThToHs -take such a flag and depending on whether TH splice warnings were enabled or -not, we pass FromSource (if the user requests warnings) or Generated -(otherwise). This is implemented in getThSpliceOrigin. - -For correct pattern-match warnings it's crucial that we annotate the Origin -consistently (#17270). In the future we could offer the Origin as part of the -TH AST. That would enable us to give quotes from the current module get -FromSource origin, and/or third library authors to tag certain parts of -generated code as FromSource to enable warnings. -That effort is tracked in #14838. --} - -{- -************************************************************************ -* * -\subsection{Splicing an expression} -* * -************************************************************************ --} - -tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty - = addErrCtxt (spliceCtxtDoc splice) $ - setSrcSpan (getLocA expr) $ do - { stage <- getStage - ; case stage of - Splice {} -> tcTopSplice expr res_ty - Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty - RunSplice _ -> - -- See Note [RunSplice ThLevel] in "GHC.Tc.Types". - pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++ - "running another splice") (ppr splice) - Comp -> tcTopSplice expr res_ty - } -tcSpliceExpr splice _ - = pprPanic "tcSpliceExpr" (ppr splice) - -{- Note [Collecting modFinalizers in typed splices] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local -environment (see Note [Delaying modFinalizers in untyped splices] in -GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the -finalizer list in the global environment and set them to use the current local -environment (with 'addModFinalizersWithLclEnv'). - --} - -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 - -- But we still return a plausible expression - -- (a) in case we print it in debug messages, and - -- (b) because we test whether it is tagToEnum in Tc.Gen.Expr.tcApp - ; return (HsSpliceE noAnn $ - HsSpliced noExtField (ThModFinalizers []) $ - HsSplicedExpr (unLoc expr'')) } - - -tcNestedSplice _ _ splice_name _ _ - = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name) - -tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -tcTopSplice expr res_ty - = do { -- Typecheck the expression, - -- making sure it has type Q (T res_ty) - 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 - ; q_expr <- tcTopSpliceExpr Typed $ - tcCheckMonoExpr expr meta_exp_ty - ; lcl_env <- getLclEnv - ; let delayed_splice - = DelayedSplice lcl_env expr res_ty q_expr - ; return (HsSpliceE noAnn (XSplice (HsSplicedT delayed_splice))) - - } - - --- 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 - ; zonked_q_expr <- zonkTopLExpr q_expr - -- See Note [Collecting modFinalizers in typed splices]. - ; modfinalizers_ref <- newTcRef [] - -- Run the expression - ; expr2 <- setStage (RunSplice modfinalizers_ref) $ - runMetaE zonked_q_expr - ; mod_finalizers <- readTcRef modfinalizers_ref - ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers - -- We use orig_expr here and not q_expr when tracing as a call to - -- unsafeCodeCoerce is added to the original expression by the - -- typechecker when typed quotes are type checked. - ; traceSplice (SpliceInfo { spliceDescription = "expression" - , spliceIsDecl = False - , spliceSource = Just orig_expr - , spliceGenerated = ppr expr2 }) - -- Rename and typecheck the spliced-in expression, - -- making sure it has type res_ty - -- These steps should never fail; this is a *typed* splice - ; (res, wcs) <- - captureConstraints $ - addErrCtxt (spliceResultDoc zonked_q_expr) $ do - { (exp3, _fvs) <- rnLExpr expr2 - ; tcCheckMonoExpr exp3 zonked_ty } - ; ev <- simplifyTop wcs - ; return $ unLoc (mkHsDictLet (EvBinds ev) res) - } - - -{- -************************************************************************ -* * -\subsection{Error messages} -* * -************************************************************************ --} - -spliceCtxtDoc :: HsSplice GhcRn -> SDoc -spliceCtxtDoc splice - = hang (text "In the Template Haskell splice") - 2 (pprSplice 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"] - -------------------- -tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) --- Note [How top-level splices are handled] --- Type check an expression that is the body of a top-level splice --- (the caller will compile and run it) --- Note that set the level to Splice, regardless of the original level, --- before typechecking the expression. For example: --- f x = $( ...$(g 3) ... ) --- The recursive call to tcCheckPolyExpr will simply expand the --- inner escape before dealing with the outer one - -tcTopSpliceExpr isTypedSplice tc_action - = checkNoErrs $ -- checkNoErrs: must not try to run the thing - -- if the type checker fails! - unsetGOptM Opt_DeferTypeErrors $ - -- Don't defer type errors. Not only are we - -- going to run this code, but we do an unsafe - -- coerce, so we get a seg-fault if, say we - -- splice a type into a place where an expression - -- is expected (#7276) - setStage (Splice isTypedSplice) $ - do { -- Typecheck the expression - (mb_expr', wanted) <- tryCaptureConstraints tc_action - -- If tc_action fails (perhaps because of insoluble constraints) - -- we want to capture and report those constraints, else we may - -- just get a silent failure (#20179). Hence the 'try' part. - - ; const_binds <- simplifyTop wanted - - ; case mb_expr' of - Nothing -> failM -- In this case simplifyTop should have - -- reported some errors - Just expr' -> return $ mkHsDictLet (EvBinds const_binds) expr' } - -{- -************************************************************************ -* * - Annotations -* * -************************************************************************ --} - -runAnnotation target expr = do - -- Find the classes we want instances for in order to call toAnnotationWrapper - loc <- getSrcSpanM - data_class <- tcLookupClass dataClassName - to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName - - -- Check the instances we require live in another module (we want to execute it..) - -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr - -- also resolves the LIE constraints to detect e.g. instance ambiguity - zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped ( - do { (expr', expr_ty) <- tcInferRhoNC expr - -- We manually wrap the typechecked expression in a call to toAnnotationWrapper - -- By instantiating the call >here< it gets registered in the - -- LIE consulted by tcTopSpliceExpr - -- and hence ensures the appropriate dictionary is bound by const_binds - ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] - ; 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 - specialised_to_annotation_wrapper_expr expr')) - }) - - -- Run the appropriately wrapped expression to get the value of - -- the annotation and its dictionaries. The return value is of - -- type AnnotationWrapper by construction, so this conversion is - -- safe - serialized <- runMetaAW zonked_wrapped_expr' - return Annotation { - ann_target = target, - ann_value = serialized - } - -convertAnnotationWrapper :: ForeignHValue -> TcM (Either SDoc Serialized) -convertAnnotationWrapper fhv = do - interp <- tcGetInterp - case interpInstance interp of - ExternalInterp {} -> Right <$> runTH THAnnWrapper fhv -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> do - annotation_wrapper <- liftIO $ wormhole interp fhv - return $ Right $ - case unsafeCoerce annotation_wrapper of - AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> - -- Got the value and dictionaries: build the serialized value and - -- call it a day. We ensure that we seq the entire serialized value - -- in order that any errors in the user-written code for the - -- 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` () - -#endif - -{- -************************************************************************ -* * -\subsection{Running an expression} -* * -************************************************************************ --} - -runQuasi :: TH.Q a -> TcM a -runQuasi act = TH.runQ act - -runRemoteModFinalizers :: ThModFinalizers -> TcM () -runRemoteModFinalizers (ThModFinalizers finRefs) = do - let withForeignRefs [] f = f [] - 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 - qs <- liftIO (withForeignRefs finRefs $ mapM localRef) - runQuasi $ sequence_ qs -#endif - - ExternalInterp conf iserv -> withIServ_ conf iserv $ \i -> 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 -> - withForeignRefs finRefs $ \qrefs -> - writeIServ i (putMessage (RunModFinalizers st qrefs)) - () <- runRemoteTH i [] - readQResult i - -runQResult - :: (a -> String) - -> (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 - ; th_origin <- getThSpliceOrigin - ; traceTc "Got TH result:" (text (show_th th_result)) - ; return (f th_origin expr_span th_result) } - - ------------------ -runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn) - -> LHsExpr GhcTc - -> TcM hs_syn -runMeta unwrap e = do - hooks <- getHooks - case runMetaHook hooks of - Nothing -> unwrap defaultRunMeta e - Just h -> unwrap h e - -defaultRunMeta :: MetaHook TcM -defaultRunMeta (MetaE r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp) -defaultRunMeta (MetaP r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat) -defaultRunMeta (MetaT r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType) -defaultRunMeta (MetaD r) - = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec) -defaultRunMeta (MetaAW r) - = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper) - -- We turn off showing the code in meta-level exceptions because doing so exposes - -- the toAnnotationWrapper function that we slap around the user's code - ----------------- -runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper - -> TcM Serialized -runMetaAW = runMeta metaRequestAW - -runMetaE :: LHsExpr GhcTc -- Of type (Q Exp) - -> TcM (LHsExpr GhcPs) -runMetaE = runMeta metaRequestE - -runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) - -> TcM (LPat GhcPs) -runMetaP = runMeta metaRequestP - -runMetaT :: LHsExpr GhcTc -- Of type (Q Type) - -> TcM (LHsType GhcPs) -runMetaT = runMeta metaRequestT - -runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] - -> TcM [LHsDecl GhcPs] -runMetaD = runMeta metaRequestD - -{- Note [Errors in desugaring a splice] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What should we do if there are errors when desugaring a splice? We should -abort. There are several cases to consider: - -(a) The desugarer hits an unrecoverable error and fails in the monad. -(b) The desugarer hits a recoverable error, reports it, and continues. -(c) The desugarer reports a fatal warning (with -Werror), reports it, and continues. -(d) The desugarer reports a non-fatal warning, and continues. - -Each case is tested in th/T19709[abcd]. - -General principle: we wish to report all messages from dealing with a splice -eagerly, as these messages arise during an earlier stage than type-checking -generally. It's also likely that a compile-time warning from spliced code -will be easier to understand then an error that arises from processing the -code the splice produces. (Rationale: the warning will be about the code the -user actually wrote, not what is generated.) - -Case (a): We have no choice but to abort here, but we must make sure that -the messages are printed or logged before aborting. Logging them is annoying, -because we're in the type-checker, and the messages are DsMessages, from the -desugarer. So we report and then fail in the monad. This case is detected -by the fact that initDsTc returns Nothing. - -Case (b): We detect this case by looking for errors in the messages returned -from initDsTc and aborting if we spot any (after printing, of course). Note -that initDsTc will return a Just ds_expr in this case, but we don't wish to -use the (likely very bogus) expression. - -Case (c): This is functionally the same as (b), except that the expression -isn't bogus. We still don't wish to use it, as the user's request for -Werror -tells us not to. - -Case (d): We report the warnings and then carry on with the expression. -This might result in warnings printed out of source order, but this is -appropriate, as the warnings from the splice arise from an earlier stage -of compilation. - -Previously, we failed to abort in cases (b) and (c), leading to #19709. --} - ---------------- -runMeta' :: Bool -- Whether code should be printed in the exception message - -> (hs_syn -> SDoc) -- how to print the code - -> (SrcSpan -> ForeignHValue -> TcM (Either SDoc hs_syn)) -- How to run x - -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or - -- something like that - -> 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 - -- recovered giving it type f :: forall a.a, it'd be very dodgy - -- to carry on. Mind you, the staging restrictions mean we won't - -- actually run f, but it still seems wrong. And, more concretely, - -- see #5358 for an example that fell over when trying to - -- reify a function with an unlifted kind in it. (These don't occur - -- in type-correct programs.) - ; failIfErrsM - - -- run plugins - ; hsc_env <- getTopEnv - ; expr' <- withPlugins (hsc_plugins hsc_env) spliceRunAction expr - - -- Desugar - ; (ds_msgs, mb_ds_expr) <- initDsTc (dsLExpr expr') - - -- Print any messages (even warnings) eagerly: they might be helpful if anything - -- goes wrong. See Note [Errors in desugaring a splice]. This happens in all - -- cases. - ; logger <- getLogger - ; diag_opts <- initDiagOpts <$> getDynFlags - ; liftIO $ printMessages logger diag_opts ds_msgs - - ; ds_expr <- case mb_ds_expr of - Nothing -> failM -- Case (a) from Note [Errors in desugaring a splice] - Just ds_expr -> -- There still might be a fatal warning or recoverable - -- Cases (b) and (c) from Note [Errors in desugaring a splice] - do { when (errorsOrFatalWarningsFound ds_msgs) - failM - ; return ds_expr } - - -- Compile and link it; might fail if linking fails - ; src_span <- getSrcSpanM - ; traceTc "About to run (desugared)" (ppr ds_expr) - ; either_hval <- tryM $ liftIO $ - GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr - ; case either_hval of { - Left exn -> fail_with_exn "compile and link" exn ; - Right (hval, needed_mods, needed_pkgs) -> do - - { -- Coerce it to Q t, and run it - - -- Running might fail if it throws an exception of any kind (hence tryAllM) - -- including, say, a pattern-match exception in the code we are running - -- - -- We also do the TH -> HS syntax conversion inside the same - -- exception-catching thing so that if there are any lurking - -- exceptions in the data structure returned by hval, we'll - -- encounter them inside the try - -- - -- See Note [Exceptions in TH] - let expr_span = getLocA expr - ; recordThNeededRuntimeDeps needed_mods needed_pkgs - ; either_tval <- tryAllM $ - setSrcSpan expr_span $ -- Set the span so that qLocation can - -- see where this splice is - do { mb_result <- run_and_convert expr_span hval - ; case mb_result of - Left err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) - Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) - ; return $! result } } - - ; case either_tval of - Right v -> return v - Left se -> case fromException se of - Just IOEnvFailure -> failM -- Error already in Tc monad - _ -> fail_with_exn "run" se -- Exception - }}} - where - -- see Note [Concealed TH exceptions] - fail_with_exn :: Exception e => String -> e -> TcM a - fail_with_exn phase exn = do - exn_msg <- liftIO $ Panic.safeShowException exn - let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", - nest 2 (text exn_msg), - if show_code then text "Code:" <+> ppr expr else empty] - failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) - -{- -Note [Running typed splices in the zonker] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -See #15471 for the full discussion. - -For many years typed splices were run immediately after they were type checked -however, this is too early as it means to zonk some type variables before -they can be unified with type variables in the surrounding context. - -For example, - -``` -module A where - -test_foo :: forall a . Q (TExp (a -> a)) -test_foo = [|| id ||] - -module B where - -import A - -qux = $$(test_foo) -``` - -We would expect `qux` to have inferred type `forall a . a -> a` but if -we run the splices too early the unified variables are zonked to `Any`. The -inferred type is the unusable `Any -> Any`. - -To run the splice, we must compile `test_foo` all the way to byte code. -But at the moment when the type checker is looking at the splice, test_foo -has type `Q (TExp (alpha -> alpha))` and we -certainly can't compile code involving unification variables! - -We could default `alpha` to `Any` but then we infer `qux :: Any -> Any` -which definitely is not what we want. Moreover, if we had - qux = [$$(test_foo), (\x -> x +1::Int)] -then `alpha` would have to be `Int`. - -Conclusion: we must defer taking decisions about `alpha` until the -typechecker is done; and *then* we can run the splice. It's fine to do it -later, because we know it'll produce type-correct code. - -Deferring running the splice until later, in the zonker, means that the -unification variables propagate upwards from the splice into the surrounding -context and are unified correctly. - -This is implemented by storing the arguments we need for running the splice -in a `DelayedSplice`. In the zonker, the arguments are passed to -`GHC.Tc.Gen.Splice.runTopSplice` and the expression inserted into the AST as normal. - - - -Note [Exceptions in TH] -~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we have something like this - $( f 4 ) -where - f :: Int -> Q [Dec] - f n | n>3 = fail "Too many declarations" - | otherwise = ... - -The 'fail' is a user-generated failure, and should be displayed as a -perfectly ordinary compiler error message, not a panic or anything -like that. Here's how it's processed: - - * 'fail' is the monad fail. The monad instance for Q in TH.Syntax - effectively transforms (fail s) to - qReport True s >> fail - where 'qReport' comes from the Quasi class and fail from its monad - superclass. - - * The TcM monad is an instance of Quasi (see GHC.Tc.Gen.Splice), and it implements - (qReport True s) by using addErr to add an error message to the bag of errors. - The 'fail' in TcM raises an IOEnvFailure exception - - * 'qReport' forces the message to ensure any exception hidden in unevaluated - thunk doesn't get into the bag of errors. Otherwise the following splice - will trigger panic (#8987): - $(fail undefined) - See also Note [Concealed TH exceptions] - - * So, when running a splice, we catch all exceptions; then for - - an IOEnvFailure exception, we assume the error is already - in the error-bag (above) - - other errors, we add an error to the bag - and then fail - -Note [Concealed TH exceptions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When displaying the error message contained in an exception originated from TH -code, we need to make sure that the error message itself does not contain an -exception. For example, when executing the following splice: - - $( error ("foo " ++ error "bar") ) - -the message for the outer exception is a thunk which will throw the inner -exception when evaluated. - -For this reason, we display the message of a TH exception using the -'safeShowException' function, which recursively catches any exception thrown -when showing an error message. - - -To call runQ in the Tc monad, we need to make TcM an instance of Quasi: --} - -instance TH.Quasi TcM where - qNewName s = do { u <- newUnique - ; let i = toInteger (getKey u) - ; return (TH.mkNameU s i) } - - -- 'msg' is forced to ensure exceptions don't escape, - -- see Note [Exceptions in TH] - qReport True msg = seqList msg $ addErr $ TcRnUnknownMessage $ mkPlainError noHints (text msg) - qReport False msg = seqList msg $ addDiagnostic $ TcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints (text msg) - - qLocation = do { m <- getModule - ; l <- getSrcSpanM - ; r <- case l of - UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" - (ppr l) - RealSrcSpan s _ -> return s - ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) - , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = unitString (moduleUnit m) - , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) - , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } - - qLookupName = lookupName - qReify = reify - qReifyFixity nm = lookupThName nm >>= reifyFixity - qReifyType = reifyTypeOfThing - qReifyInstances = reifyInstances - qReifyRoles = reifyRoles - qReifyAnnotations = reifyAnnotations - qReifyModule = reifyModule - qReifyConStrictness nm = do { nm' <- lookupThName nm - ; dc <- tcLookupDataCon nm' - ; let bangs = dataConImplBangs dc - ; return (map reifyDecidedStrictness bangs) } - - -- For qRecover, discard error messages if - -- the recovery action is chosen. Otherwise - -- we'll only fail higher up. - qRecover recover main = tryTcDiscardingErrs recover main - - qGetPackageRoot = do - dflags <- getDynFlags - return $ fromMaybe "." (workingDirectory dflags) - - qAddDependentFile fp = do - ref <- fmap tcg_dependent_files getGblEnv - dep_files <- readTcRef ref - writeTcRef ref (fp:dep_files) - - qAddTempFile suffix = do - dflags <- getDynFlags - logger <- getLogger - tmpfs <- hsc_tmpfs <$> getTopEnv - liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix - - qAddTopDecls thds = do - l <- getSrcSpanM - th_origin <- getThSpliceOrigin - let either_hval = convertToHsDecls th_origin l thds - ds <- case either_hval of - Left exn -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "Error in a declaration passed to addTopDecls:") - 2 exn - Right ds -> return ds - mapM_ (checkTopDecl . unLoc) ds - th_topdecls_var <- fmap tcg_th_topdecls getGblEnv - updTcRef th_topdecls_var (\topds -> ds ++ topds) - where - checkTopDecl :: HsDecl GhcPs -> TcM () - checkTopDecl (ValD _ binds) - = mapM_ bindName (collectHsBindBinders CollNoDictBinders binds) - checkTopDecl (SigD _ _) - = return () - checkTopDecl (AnnD _ _) - = return () - checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) - = bindName name - checkTopDecl _ - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ - text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl" - - bindName :: RdrName -> TcM () - bindName (Exact n) - = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv - ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) - } - - bindName name = - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ - 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.") - - qAddForeignFilePath lang fp = do - var <- fmap tcg_th_foreign_files getGblEnv - updTcRef var ((lang, fp) :) - - qAddModFinalizer fin = do - r <- liftIO $ mkRemoteRef fin - fref <- liftIO $ mkForeignRef r (freeRemoteRef r) - addModFinalizerRef fref - - qAddCorePlugin plugin = do - hsc_env <- getTopEnv - let fc = hsc_FC hsc_env - let home_unit = hsc_home_unit hsc_env - let dflags = hsc_dflags hsc_env - let fopts = initFinderOpts dflags - r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) - let err = hang - (text "addCorePlugin: invalid plugin module " - <+> text (show plugin) - ) - 2 - (text "Plugins in the current package can't be specified.") - case r of - Found {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err - FoundMultiple {} -> addErr $ TcRnUnknownMessage $ mkPlainError noHints err - _ -> return () - th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv - updTcRef th_coreplugins_var (plugin:) - - qGetQ :: forall a. Typeable a => TcM (Maybe a) - qGetQ = do - th_state_var <- fmap tcg_th_state getGblEnv - th_state <- readTcRef th_state_var - -- See #10596 for why we use a scoped type variable here. - return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) - - qPutQ x = do - th_state_var <- fmap tcg_th_state getGblEnv - updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) - - qIsExtEnabled = xoptM - - qExtsEnabled = - EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv - - qPutDoc doc_loc s = do - th_doc_var <- tcg_th_docs <$> getGblEnv - resolved_doc_loc <- resolve_loc doc_loc - is_local <- checkLocalName resolved_doc_loc - unless is_local $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text - "Can't add documentation to" <+> ppr_loc doc_loc <+> - text "as it isn't inside the current module" - let ds = mkGeneratedHsDocString s - hd = lexHsDoc parseIdentifier ds - hd' <- rnHsDoc hd - updTcRef th_doc_var (Map.insert resolved_doc_loc hd') - where - resolve_loc (TH.DeclDoc n) = DeclDoc <$> lookupThName n - resolve_loc (TH.ArgDoc n i) = ArgDoc <$> lookupThName n <*> pure i - resolve_loc (TH.InstDoc t) = InstDoc <$> fmap getName (lookupThInstName t) - resolve_loc TH.ModuleDoc = pure ModuleDoc - - ppr_loc (TH.DeclDoc n) = ppr_th n - ppr_loc (TH.ArgDoc n _) = ppr_th n - ppr_loc (TH.InstDoc t) = ppr_th t - ppr_loc TH.ModuleDoc = text "the module header" - - -- It doesn't make sense to add documentation to something not inside - -- the current module. So check for it! - checkLocalName (DeclDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n - checkLocalName (ArgDoc n _) = nameIsLocalOrFrom <$> getModule <*> pure n - checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n - checkLocalName ModuleDoc = pure True - - - qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc - qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc - qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i - qGetDoc TH.ModuleDoc = do - df <- getDynFlags - docs <- getGblEnv >>= extractDocs df - return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs)) - --- | Looks up documentation for a declaration in first the current module, --- otherwise tries to find it in another module via 'hscGetModuleInterface'. -lookupDeclDoc :: Name -> TcM (Maybe String) -lookupDeclDoc nm = do - df <- getDynFlags - Docs{docs_decls} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df - case lookupUniqMap docs_decls nm of - Just doc -> pure $ Just (renderHsDocStrings $ map hsDocString doc) - Nothing -> do - -- 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} } -> - pure $ renderHsDocStrings . map hsDocString <$> lookupUniqMap dmap nm - _ -> pure Nothing - --- | Like 'lookupDeclDoc', looks up documentation for a function argument. If --- it can't find any documentation for a function in this module, it tries to --- find it in another module. -lookupArgDoc :: Int -> Name -> TcM (Maybe String) -lookupArgDoc i nm = do - df <- getDynFlags - Docs{docs_args = argDocs} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df - case lookupUniqMap argDocs nm of - Just m -> pure $ renderHsDocString . hsDocString <$> IntMap.lookup i m - Nothing -> do - mIface <- getExternalModIface nm - case mIface of - Just ModIface { mi_docs = Just Docs{docs_args = amap} } -> - pure $ renderHsDocString . hsDocString <$> (lookupUniqMap amap nm >>= IntMap.lookup i) - _ -> pure Nothing - --- | Returns the module a Name belongs to, if it is isn't local. -getExternalModIface :: Name -> TcM (Maybe ModIface) -getExternalModIface nm = do - isLocal <- nameIsLocalOrFrom <$> getModule <*> pure nm - if isLocal - then pure Nothing - else case nameModule_maybe nm of - Nothing -> pure Nothing - Just modNm -> do - hsc_env <- getTopEnv - iface <- liftIO $ hscGetModuleInterface hsc_env modNm - pure (Just iface) - --- | Find the GHC name of the first instance that matches the TH type -lookupThInstName :: TH.Type -> TcM Name -lookupThInstName th_type = do - cls_name <- inst_cls_name th_type - insts <- reifyInstances' cls_name (inst_arg_types th_type) - case insts of -- This expands any type synonyms - Left (_, (inst:_)) -> return $ getName inst - Left (_, []) -> noMatches - Right (_, (inst:_)) -> return $ getName inst - Right (_, []) -> noMatches - where - noMatches = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - text "Couldn't find any instances of" - <+> ppr_th th_type - <+> text "to add documentation to" - - -- Get the name of the class for the instance we are documenting - -- > inst_cls_name (Monad Maybe) == Monad - -- > inst_cls_name C = C - inst_cls_name :: TH.Type -> TcM TH.Name - inst_cls_name (TH.AppT t _) = inst_cls_name t - inst_cls_name (TH.SigT n _) = inst_cls_name n - inst_cls_name (TH.VarT n) = pure n - inst_cls_name (TH.ConT n) = pure n - inst_cls_name (TH.PromotedT n) = pure n - inst_cls_name (TH.InfixT _ n _) = pure n - inst_cls_name (TH.UInfixT _ n _) = pure n - inst_cls_name (TH.PromotedInfixT _ n _) = pure n - inst_cls_name (TH.PromotedUInfixT _ n _) = pure n - inst_cls_name (TH.ParensT t) = inst_cls_name t - - inst_cls_name (TH.ForallT _ _ _) = inst_cls_name_err - inst_cls_name (TH.ForallVisT _ _) = inst_cls_name_err - inst_cls_name (TH.AppKindT _ _) = inst_cls_name_err - inst_cls_name (TH.TupleT _) = inst_cls_name_err - inst_cls_name (TH.UnboxedTupleT _) = inst_cls_name_err - inst_cls_name (TH.UnboxedSumT _) = inst_cls_name_err - inst_cls_name TH.ArrowT = inst_cls_name_err - inst_cls_name TH.MulArrowT = inst_cls_name_err - inst_cls_name TH.EqualityT = inst_cls_name_err - inst_cls_name TH.ListT = inst_cls_name_err - inst_cls_name (TH.PromotedTupleT _) = inst_cls_name_err - inst_cls_name TH.PromotedNilT = inst_cls_name_err - inst_cls_name TH.PromotedConsT = inst_cls_name_err - inst_cls_name TH.StarT = inst_cls_name_err - inst_cls_name TH.ConstraintT = inst_cls_name_err - inst_cls_name (TH.LitT _) = inst_cls_name_err - inst_cls_name TH.WildCardT = inst_cls_name_err - inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err - - inst_cls_name_err = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - text "Couldn't work out what instance" - <+> ppr_th th_type - <+> text "is supposed to be" - - -- Basically does the opposite of 'mkThAppTs' - -- > inst_arg_types (Monad Maybe) == [Maybe] - -- > inst_arg_types C == [] - inst_arg_types :: TH.Type -> [TH.Type] - inst_arg_types (TH.AppT _ args) = - let go (TH.AppT t ts) = t:go ts - go t = [t] - in go args - inst_arg_types _ = [] - --- | Adds a mod finalizer reference to the local environment. -addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () -addModFinalizerRef finRef = do - th_stage <- getStage - case th_stage 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. - -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. - _ -> - pprPanic "addModFinalizer was called when no finalizers were collected" - (ppr th_stage) - --- | Releases the external interpreter state. -finishTH :: TcM () -finishTH = do - hsc_env <- getTopEnv - case interpInstance <$> hsc_interp hsc_env of - Nothing -> pure () -#if defined(HAVE_INTERNAL_INTERPRETER) - Just InternalInterp -> pure () -#endif - Just (ExternalInterp {}) -> do - tcg <- getGblEnv - writeTcRef (tcg_th_remote_state tcg) Nothing - - -runTHExp :: ForeignHValue -> TcM TH.Exp -runTHExp = runTH THExp - -runTHPat :: ForeignHValue -> TcM TH.Pat -runTHPat = runTH THPat - -runTHType :: ForeignHValue -> TcM TH.Type -runTHType = runTH THType - -runTHDec :: ForeignHValue -> TcM [TH.Dec] -runTHDec = runTH THDec - -runTH :: Binary a => THResultType -> ForeignHValue -> TcM a -runTH ty fhv = do - interp <- tcGetInterp - case interpInstance interp of -#if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> do - -- Run it in the local TcM - hv <- liftIO $ wormhole interp fhv - r <- runQuasi (unsafeCoerce hv :: TH.Q a) - return r -#endif - - ExternalInterp conf iserv -> - -- 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) - - --- | communicate with a remotely-running TH computation until it finishes. --- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. -runRemoteTH - :: IServInstance - -> [Messages TcRnMessage] -- saved from nested calls to qRecover - -> TcM () -runRemoteTH iserv recovers = do - THMsg msg <- liftIO $ readIServ iserv getTHMessage - 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) - EndRecover caught_error -> do - let (prev_msgs, rest) = case recovers of - [] -> panic "EndRecover" - a : b -> (a,b) - v <- getErrsVar - warn_msgs <- getWarningMessages <$> readTcRef v - -- keep the warnings only if there were no errors - writeTcRef v $ if caught_error - then prev_msgs - else mkMessages warn_msgs `unionMessages` prev_msgs - runRemoteTH iserv rest - _other -> do - r <- handleTHMessage msg - liftIO $ writeIServ iserv (put r) - runRemoteTH iserv recovers - --- | Read a value of type QResult from the iserv -readQResult :: Binary a => IServInstance -> TcM a -readQResult i = do - qr <- liftIO $ readIServ i get - case qr of - QDone a -> return a - QException str -> liftIO $ throwIO (ErrorCall str) - QFail str -> fail str - -{- Note [TH recover with -fexternal-interpreter] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Recover is slightly tricky to implement. - -The meaning of "recover a b" is - - Do a - - If it finished with no errors, then keep the warnings it generated - - If it failed, discard any messages it generated, and do b - -Note that "failed" here can mean either - (1) threw an exception (failTc) - (2) generated an error message (addErrTcM) - -The messages are managed by GHC in the TcM monad, whereas the -exception-handling is done in the ghc-iserv process, so we have to -coordinate between the two. - -On the server: - - emit a StartRecover message - - run "a; FailIfErrs" inside a try - - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed - - if "a; FailIfErrs" failed, run "b" - -Back in GHC, when we receive: - - FailIfErrrs - failTc if there are any error messages (= failIfErrsM) - StartRecover - save the current messages and start with an empty set. - EndRecover caught_error - Restore the previous messages, - and merge in the new messages if caught_error is false. --} - --- | Retrieve (or create, if it hasn't been created already), the --- remote TH state. The TH state is a remote reference to an IORef --- QState living on the server, and we have to pass this to each RunTH --- call we make. --- --- 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 - -wrapTHResult :: TcM a -> TcM (THResult a) -wrapTHResult tcm = do - e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic - case e of - Left e -> return (THException (show e)) - Right a -> return (THComplete a) - -handleTHMessage :: THMessage a -> TcM a -handleTHMessage msg = case msg of - NewName a -> wrapTHResult $ TH.qNewName a - Report b str -> wrapTHResult $ TH.qReport b str - LookupName b str -> wrapTHResult $ TH.qLookupName b str - Reify n -> wrapTHResult $ TH.qReify n - ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n - ReifyType n -> wrapTHResult $ TH.qReifyType n - ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts - ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n - ReifyAnnotations lookup tyrep -> - wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) - ReifyModule m -> wrapTHResult $ TH.qReifyModule m - ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm - GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot - AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f - AddTempFile s -> wrapTHResult $ TH.qAddTempFile s - AddModFinalizer r -> do - interp <- hscInterp <$> getTopEnv - wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef - AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str - AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs - AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str - IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext - ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled - PutDoc l s -> wrapTHResult $ TH.qPutDoc l s - GetDoc l -> wrapTHResult $ TH.qGetDoc l - FailIfErrs -> wrapTHResult failIfErrsM - _ -> panic ("handleTHMessage: unexpected message " ++ show msg) - -getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]] -getAnnotationsByTypeRep th_name tyrep - = do { name <- lookupThAnnLookup th_name - ; topEnv <- getTopEnv - ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing - ; tcg <- getGblEnv - ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep - ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep - ; return (selectedEpsHptAnns ++ selectedTcgAnns) } - -{- -************************************************************************ -* * - Instance Testing -* * -************************************************************************ --} - -reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] -reifyInstances th_nm th_tys - = do { insts <- reifyInstances' th_nm th_tys - ; case insts of - Left (cls, cls_insts) -> - reifyClassInstances cls cls_insts - Right (tc, fam_insts) -> - reifyFamilyInstances tc fam_insts } - -reifyInstances' :: TH.Name - -> [TH.Type] - -> TcM (Either (Class, [ClsInst]) (TyCon, [FamInst])) - -- ^ 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 - ; th_origin <- getThSpliceOrigin - ; rdr_ty <- cvt 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 - -- Rename to HsType Name - ; ((tv_names, rn_ty), _fvs) - <- checkNoErrs $ -- If there are out-of-scope Names here, then we - -- must error before proceeding to typecheck the - -- renamed type, as that will result in GHC - -- internal errors (#13837). - rnImplicitTvOccs Nothing tv_rdrs $ \ tv_names -> - do { (rn_ty, fvs) <- rnLHsType doc rdr_ty - ; return ((tv_names, rn_ty), fvs) } - ; skol_info <- mkSkolemInfo ReifySkol - ; (tclvl, wanted, (tvs, ty)) - <- pushLevelAndSolveEqualitiesX "reifyInstances" $ - bindImplicitTKBndrs_Skol skol_info tv_names $ - tcInferLHsType rn_ty - - ; tvs <- zonkAndScopedSort tvs - - -- Avoid error cascade if there are unsolved - ; reportUnsolvedEqualities skol_info tvs tclvl wanted - - ; ty <- zonkTcTypeToType ty - -- Substitute out the meta type variables - -- In particular, the type might have kind - -- variables inside it (#7477) - - ; traceTc "reifyInstances'" (ppr ty $$ ppr (tcTypeKind ty)) - ; case splitTyConApp_maybe ty of -- This expands any type synonyms - Just (tc, tys) -- See #7910 - | Just cls <- tyConClass_maybe tc - -> 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) } - | 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 $ TcRnUnknownMessage $ mkPlainError noHints $ - (hang (text "reifyInstances:" <+> quotes (ppr ty)) - 2 (text "is not a class constraint or type family application")) } - where - doc = ClassInstanceCtx - 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 (TcRnUnknownMessage $ mkPlainError noHints msg) - Right ty -> return ty - -{- -************************************************************************ -* * - Reification -* * -************************************************************************ --} - -lookupName :: Bool -- True <=> type namespace - -- False <=> value namespace - -> String -> TcM (Maybe TH.Name) -lookupName is_type_name s - = do { mb_nm <- lookupOccRn_maybe rdr_name - ; return (fmap reifyName mb_nm) } - where - th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M' - - occ_fs :: FastString - occ_fs = mkFastString (TH.nameBase th_name) - - occ :: OccName - occ | is_type_name - = if isLexVarSym occ_fs || isLexCon occ_fs - then mkTcOccFS occ_fs - else mkTyVarOccFS occ_fs - | otherwise - = if isLexCon occ_fs then mkDataOccFS occ_fs - else mkVarOccFS occ_fs - - rdr_name = case TH.nameModule th_name of - Nothing -> mkRdrUnqual occ - Just mod -> mkRdrQual (mkModuleName mod) occ - -getThing :: TH.Name -> TcM TcTyThing -getThing th_name - = do { name <- lookupThName th_name - ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name) - ; tcLookupTh name } - -- 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 _ = panic "reify/ppr_ns" - -reify :: TH.Name -> TcM TH.Info -reify th_name - = do { traceTc "reify 1" (text (TH.showName th_name)) - ; thing <- getThing th_name - ; traceTc "reify 2" (ppr thing) - ; reifyThing thing } - -lookupThName :: TH.Name -> TcM Name -lookupThName th_name = do - mb_name <- lookupThName_maybe th_name - case mb_name of - Nothing -> failWithTc (notInScope th_name) - Just name -> return name - -lookupThName_maybe :: TH.Name -> TcM (Maybe Name) -lookupThName_maybe th_name - = do { names <- mapMaybeM lookupOccRn_maybe (thRdrNameGuesses th_name) - -- 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) } - -tcLookupTh :: Name -> TcM TcTyThing --- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that --- it gives a reify-related error message on failure, whereas in the normal --- tcLookup, failure is a bug. -tcLookupTh name - = do { (gbl_env, lcl_env) <- getEnvs - ; case lookupNameEnv (tcl_env lcl_env) name of { - Just thing -> return thing; - Nothing -> - - case lookupNameEnv (tcg_type_env gbl_env) name of { - Just thing -> return (AGlobal thing); - Nothing -> - - -- EZY: I don't think this choice matters, no TH in signatures! - if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name - then -- It's defined in this module - failWithTc (notInEnv name) - - else - do { mb_thing <- tcLookupImported_maybe name - ; case mb_thing of - Succeeded thing -> return (AGlobal thing) - Failed msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) - }}}} - -notInScope :: TH.Name -> TcRnMessage -notInScope th_name = TcRnUnknownMessage $ mkPlainError noHints $ - quotes (text (TH.pprint th_name)) <+> - text "is not in scope at a reify" - -- Ugh! Rather an indirect way to display the name - -notInEnv :: Name -> TcRnMessage -notInEnv name = TcRnUnknownMessage $ mkPlainError noHints $ - quotes (ppr name) <+> text "is not in the type environment at a reify" - ------------------------------- -reifyRoles :: TH.Name -> TcM [TH.Role] -reifyRoles th_name - = do { thing <- getThing th_name - ; case thing of - AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) - _ -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing)) - } - where - reify_role Nominal = TH.NominalR - reify_role Representational = TH.RepresentationalR - reify_role Phantom = TH.PhantomR - ------------------------------- -reifyThing :: TcTyThing -> TcM TH.Info --- The only reason this is monadic is for error reporting, --- which in turn is mainly for the case when TH can't express --- some random GHC extension - -reifyThing (AGlobal (AnId id)) - = 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) - } - -reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc -reifyThing (AGlobal (AConLike (RealDataCon dc))) - = do { let name = dataConName dc - ; ty <- reifyType (idType (dataConWrapId dc)) - ; return (TH.DataConI (reifyName name) ty - (reifyName (dataConOrigTyCon dc))) - } - -reifyThing (AGlobal (AConLike (PatSynCon ps))) - = do { let name = reifyName ps - ; ty <- reifyPatSynType (patSynSigBndr ps) - ; return (TH.PatSynI name ty) } - -reifyThing (ATcId {tct_id = id}) - = do { ty1 <- 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 - ; ty2 <- reifyType ty1 - ; return (TH.TyVarI (reifyName tv) ty2) } - -reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) - -------------------------------------------- -reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn -reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs - , cab_lhs = lhs - , cab_rhs = rhs }) - -- remove kind patterns (#8884) - = do { tvs' <- reifyTyVarsToMaybe tvs - ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs - ; lhs' <- reifyTypes lhs_types_only - ; annot_th_lhs <- zipWith3M annotThType (tyConArgsPolyKinded fam_tc) - lhs_types_only lhs' - ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs - ; rhs' <- reifyType rhs - ; return (TH.TySynEqn tvs' lhs_type rhs') } - -reifyTyCon :: TyCon -> TcM TH.Info -reifyTyCon tc - | Just cls <- tyConClass_maybe tc - = reifyClass cls - - | isFunTyCon tc - = return (TH.PrimTyConI (reifyName tc) 2 False) - - | isPrimTyCon tc - = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc)) - (isUnliftedTypeKind (tyConResKind tc))) - - | isTypeFamilyTyCon tc - = do { let tvs = tyConTyVars tc - res_kind = tyConResKind tc - resVar = famTcResVar tc - - ; kind' <- reifyKind res_kind - ; let (resultSig, injectivity) = - case resVar of - Nothing -> (TH.KindSig kind', Nothing) - Just name -> - let thName = reifyName name - injAnnot = tyConInjectivityInfo tc - sig = TH.TyVarSig (TH.KindedTV thName () kind') - inj = case injAnnot of - NotInjective -> Nothing - Injective ms -> - Just (TH.InjectivityAnn thName injRHS) - where - injRHS = map (reifyName . tyVarName) - (filterByList ms tvs) - in (sig, inj) - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) - ; let tfHead = - TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity - ; if isOpenTypeFamilyTyCon tc - then do { fam_envs <- tcGetFamInstEnvs - ; instances <- reifyFamilyInstances tc - (familyInstances fam_envs tc) - ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) } - else do { eqns <- - case isClosedSynFamilyTyConWithAxiom_maybe tc of - Just ax -> mapM (reifyAxBranch tc) $ - fromBranches $ coAxiomBranches ax - Nothing -> return [] - ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns) - []) } } - - | isDataFamilyTyCon tc - = do { let res_kind = tyConResKind tc - - ; kind' <- fmap Just (reifyKind res_kind) - - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) - ; fam_envs <- tcGetFamInstEnvs - ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc) - ; return (TH.FamilyI - (TH.DataFamilyD (reifyName tc) tvs' kind') instances) } - - | Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym - = do { rhs' <- reifyType rhs - ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) - ; return (TH.TyConI - (TH.TySynD (reifyName tc) tvs' rhs')) - } - - | otherwise - = do { cxt <- reifyCxt (tyConStupidTheta tc) - ; let tvs = tyConTyVars tc - dataCons = tyConDataCons tc - isGadt = isGadtSyntaxTyCon tc - ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons - ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc) - ; let name = reifyName tc - deriv = [] -- Don't know about deriving - decl | isNewTyCon tc = - TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv - | otherwise = - TH.DataD cxt name r_tvs Nothing cons deriv - ; return (TH.TyConI decl) } - -reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con -reifyDataCon isGadtDataCon tys dc - = do { let -- used for H98 data constructors - (ex_tvs, theta, arg_tys) - = dataConInstSig dc tys - -- used for GADTs data constructors - g_user_tvs' = dataConUserTyVarBinders dc - (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty') - = dataConFullSig dc - (srcUnpks, srcStricts) - = mapAndUnzip reifySourceBang (dataConSrcBangs dc) - dcdBangs = zipWith TH.Bang srcUnpks srcStricts - fields = dataConFieldLabels dc - name = reifyName dc - -- Universal tvs present in eq_spec need to be filtered out, as - -- they will not appear anywhere in the type. - eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec) - - ; (univ_subst, _) - -- See Note [Freshen reified GADT constructors' universal tyvars] - <- freshenTyVarBndrs $ - filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs - ; let (tvb_subst, g_user_tvs) = subst_tv_binders univ_subst g_user_tvs' - g_theta = substTys tvb_subst g_theta' - g_arg_tys = substTys tvb_subst (map scaledThing g_arg_tys') - g_res_ty = substTy tvb_subst g_res_ty' - - ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys) - - ; main_con <- - if | not (null fields) && not isGadtDataCon -> - return $ TH.RecC name (zip3 (map reifyFieldLabel fields) - dcdBangs r_arg_tys) - | not (null fields) -> do - { res_ty <- reifyType g_res_ty - ; return $ TH.RecGadtC [name] - (zip3 (map (reifyName . flSelector) fields) - dcdBangs r_arg_tys) res_ty } - -- We need to check not isGadtDataCon here because GADT - -- constructors can be declared infix. - -- See Note [Infix GADT constructors] in GHC.Tc.TyCl. - | dataConIsInfix dc && not isGadtDataCon -> - assert (r_arg_tys `lengthIs` 2) $ do - { let [r_a1, r_a2] = r_arg_tys - [s1, s2] = dcdBangs - ; 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 } - | otherwise -> - return $ TH.NormalC name (dcdBangs `zip` r_arg_tys) - - ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta) - | otherwise = assert (all isTyVar ex_tvs) - -- no covars for haskell syntax - (map mk_specified ex_tvs, theta) - ret_con | null ex_tvs' && null theta' = return main_con - | otherwise = do - { cxt <- reifyCxt theta' - ; ex_tvs'' <- reifyTyVarBndrs ex_tvs' - ; return (TH.ForallC ex_tvs'' cxt main_con) } - ; assert (r_arg_tys `equalLength` dcdBangs) - ret_con } - where - mk_specified tv = Bndr tv SpecifiedSpec - - subst_tv_binders subst tv_bndrs = - let tvs = binderVars tv_bndrs - flags = map binderArgFlag tv_bndrs - (subst', tvs') = substTyVarBndrs subst tvs - tv_bndrs' = map (\(tv,fl) -> Bndr tv fl) (zip tvs' flags) - in (subst', tv_bndrs') - -{- -Note [Freshen reified GADT constructors' universal tyvars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose one were to reify this GADT: - - data a :~: b where - Refl :: forall a b. (a ~ b) => a :~: b - -We ought to be careful here about the uniques we give to the occurrences of `a` -and `b` in this definition. That is because in the original DataCon, all uses -of `a` and `b` have the same unique, since `a` and `b` are both universally -quantified type variables--that is, they are used in both the (:~:) tycon as -well as in the constructor type signature. But when we turn the DataCon -definition into the reified one, the `a` and `b` in the constructor type -signature becomes differently scoped than the `a` and `b` in `data a :~: b`. - -While it wouldn't technically be *wrong* per se to re-use the same uniques for -`a` and `b` across these two different scopes, it's somewhat annoying for end -users of Template Haskell, since they wouldn't be able to rely on the -assumption that all TH names have globally distinct uniques (#13885). For this -reason, we freshen the universally quantified tyvars that go into the reified -GADT constructor type signature to give them distinct uniques from their -counterparts in the tycon. --} - ------------------------------- -reifyClass :: Class -> TcM TH.Info -reifyClass cls - = do { cxt <- reifyCxt theta - ; inst_envs <- tcGetInstEnvs - ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) - ; assocTys <- concatMapM reifyAT ats - ; ops <- concatMapM reify_op op_stuff - ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls)) - ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops) - ; return (TH.ClassI dec insts) } - where - (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls - fds' = map reifyFunDep fds - reify_op (op, def_meth) - = do { let (_, _, ty) = tcSplitMethodTy (idType op) - -- Use tcSplitMethodTy to get rid of the extraneous class - -- variables and predicates at the beginning of op's type - -- (see #15551). - ; ty' <- reifyType ty - ; let nm' = reifyName op - ; case def_meth of - Just (_, GenericDM gdm_ty) -> - do { gdm_ty' <- reifyType gdm_ty - ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] } - _ -> return [TH.SigD nm' ty'] } - - reifyAT :: ClassATItem -> TcM [TH.Dec] - reifyAT (ATI tycon def) = do - tycon' <- reifyTyCon tycon - case tycon' of - TH.FamilyI dec _ -> do - let (tyName, tyArgs) = tfNames dec - (dec :) <$> maybe (return []) - (fmap (:[]) . reifyDefImpl tyName tyArgs . fst) - def - _ -> pprPanic "reifyAT" (text (show tycon')) - - reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec - reifyDefImpl n args ty = - TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args)) - <$> reifyType ty - - tfNames :: TH.Dec -> (TH.Name, [TH.Name]) - tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _)) - = (n, map bndrName args) - tfNames d = pprPanic "tfNames" (text (show d)) - - bndrName :: TH.TyVarBndr flag -> TH.Name - bndrName (TH.PlainTV n _) = n - bndrName (TH.KindedTV n _ _) = n - ------------------------------- --- | Annotate (with TH.SigT) a type if the first parameter is True --- and if the type contains a free variable. --- This is used to annotate type patterns for poly-kinded tyvars in --- reifying class and type instances. --- See @Note [Reified instances and explicit kind signatures]@. -annotThType :: Bool -- True <=> annotate - -> TyCoRep.Type -> TH.Type -> TcM TH.Type - -- tiny optimization: if the type is annotated, don't annotate again. -annotThType _ _ th_ty@(TH.SigT {}) = return th_ty -annotThType True ty th_ty - | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty - = do { let ki = tcTypeKind ty - ; th_ki <- reifyKind ki - ; return (TH.SigT th_ty th_ki) } -annotThType _ _ th_ty = return th_ty - --- | For every argument type that a type constructor accepts, --- report whether or not the argument is poly-kinded. This is used to --- eventually feed into 'annotThType'. --- See @Note [Reified instances and explicit kind signatures]@. -tyConArgsPolyKinded :: TyCon -> [Bool] -tyConArgsPolyKinded tc = - map (is_poly_ty . tyVarKind) tc_vis_tvs - -- See "Wrinkle: Oversaturated data family instances" in - -- @Note [Reified instances and explicit kind signatures]@ - ++ map (is_poly_ty . tyCoBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle - ++ repeat True -- (2) in Wrinkle - where - is_poly_ty :: Type -> Bool - is_poly_ty ty = not $ - isEmptyVarSet $ - filterVarSet isTyVar $ - tyCoVarsOfType ty - - tc_vis_tvs :: [TyVar] - tc_vis_tvs = tyConVisibleTyVars tc - - tc_res_kind_vis_bndrs :: [TyCoBinder] - tc_res_kind_vis_bndrs = filter isVisibleBinder $ fst $ splitPiTys $ tyConResKind tc - -{- -Note [Reified instances and explicit kind signatures] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Reified class instances and type family instances often include extra kind -information to disambiguate instances. Here is one such example that -illustrates this (#8953): - - type family Poly (a :: k) :: Type - type instance Poly (x :: Bool) = Int - type instance Poly (x :: Maybe k) = Double - -If you're not careful, reifying these instances might yield this: - - type instance Poly x = Int - type instance Poly x = Double - -To avoid this, we go through some care to annotate things with extra kind -information. Some functions which accomplish this feat include: - -* annotThType: This annotates a type with a kind signature if the type contains - a free variable. -* tyConArgsPolyKinded: This checks every argument that a type constructor can - accept and reports if the type of the argument is poly-kinded. This - information is ultimately fed into annotThType. - ------ --- Wrinkle: Oversaturated data family instances ------ - -What constitutes an argument to a type constructor in the definition of -tyConArgsPolyKinded? For most type constructors, it's simply the visible -type variable binders (i.e., tyConVisibleTyVars). There is one corner case -we must keep in mind, however: data family instances can appear oversaturated -(#17296). For instance: - - data family Foo :: Type -> Type - data instance Foo x - - data family Bar :: k - data family Bar x - -For these sorts of data family instances, tyConVisibleTyVars isn't enough, -as they won't give you the kinds of the oversaturated arguments. We must -also consult: - -1. The kinds of the arguments in the result kind (i.e., the tyConResKind). - This will tell us, e.g., the kind of `x` in `Foo x` above. -2. If we go beyond the number of arguments in the result kind (like the - `x` in `Bar x`), then we conservatively assume that the argument's - kind is poly-kinded. - ------ --- Wrinkle: data family instances with return kinds ------ - -Another squirrelly corner case is this: - - data family Foo (a :: k) - data instance Foo :: Bool -> Type - data instance Foo :: Char -> Type - -If you're not careful, reifying these instances might yield this: - - data instance Foo - data instance Foo - -We can fix this ambiguity by reifying the instances' explicit return kinds. We -should only do this if necessary (see -Note [When does a tycon application need an explicit kind signature?] in GHC.Core.Type), -but more importantly, we *only* do this if either of the following are true: - -1. The data family instance has no constructors. -2. The data family instance is declared with GADT syntax. - -If neither of these are true, then reifying the return kind would yield -something like this: - - data instance (Bar a :: Type) = MkBar a - -Which is not valid syntax. --} - ------------------------------- -reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec] -reifyClassInstances cls insts - = mapM (reifyClassInstance (tyConArgsPolyKinded (classTyCon cls))) insts - -reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded - -- includes only *visible* tvs - -> ClsInst -> TcM TH.Dec -reifyClassInstance is_poly_tvs i - = do { cxt <- reifyCxt theta - ; let vis_types = filterOutInvisibleTypes cls_tc types - ; thtypes <- reifyTypes vis_types - ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes - ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes - ; return $ (TH.InstanceD over cxt head_ty []) } - where - (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun) - cls_tc = classTyCon cls - dfun = instanceDFunId i - over = case overlapMode (is_flag i) of - NoOverlap _ -> Nothing - Overlappable _ -> Just TH.Overlappable - Overlapping _ -> Just TH.Overlapping - Overlaps _ -> Just TH.Overlaps - Incoherent _ -> Just TH.Incoherent - ------------------------------- -reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] -reifyFamilyInstances fam_tc fam_insts - = mapM (reifyFamilyInstance (tyConArgsPolyKinded fam_tc)) fam_insts - -reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded - -- includes only *visible* tvs - -> FamInst -> TcM TH.Dec -reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor - , fi_axiom = ax - , fi_fam = fam }) - | let fam_tc = coAxiomTyCon ax - branch = coAxiomSingleBranch ax - , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch - = case flavor of - SynFamilyInst -> - -- remove kind patterns (#8884) - do { th_tvs <- reifyTyVarsToMaybe tvs - ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs - ; th_lhs <- reifyTypes lhs_types_only - ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only - th_lhs - ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs - ; th_rhs <- reifyType rhs - ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) } - - DataFamilyInst rep_tc -> - do { let -- eta-expand lhs types, because sometimes data/newtype - -- instances are eta-reduced; See #9692 - -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom - (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch - fam' = reifyName fam - dataCons = tyConDataCons rep_tc - isGadt = isGadtSyntaxTyCon rep_tc - ; th_tvs <- reifyTyVarsToMaybe ee_tvs - ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons - ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs - ; th_tys <- reifyTypes types_only - ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys - ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys - ; mb_sig <- - -- See "Wrinkle: data family instances with return kinds" in - -- Note [Reified instances and explicit kind signatures] - if (null cons || isGadtSyntaxTyCon rep_tc) - && tyConAppNeedsKindSig False fam_tc (length ee_lhs) - then do { let full_kind = tcTypeKind (mkTyConApp fam_tc ee_lhs) - ; th_full_kind <- reifyKind full_kind - ; pure $ Just th_full_kind } - else pure Nothing - ; return $ - if isNewTyCon rep_tc - then TH.NewtypeInstD [] th_tvs lhs_type mb_sig (head cons) [] - else TH.DataInstD [] th_tvs lhs_type mb_sig cons [] - } - ------------------------------- -reifyType :: TyCoRep.Type -> TcM TH.Type --- Monadic only because of failure -reifyType ty | tcIsLiftedTypeKind ty = return TH.StarT - -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it - -- with Constraint (#14869). -reifyType ty@(ForAllTy (Bndr _ argf) _) - = reify_for_all argf ty -reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } -reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) -reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here -reifyType ty@(AppTy {}) = do - let (ty_head, ty_args) = splitAppTys ty - ty_head' <- reifyType ty_head - ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args) - pure $ mkThAppTs ty_head' ty_args' - where - -- Make sure to filter out any invisible arguments. For instance, if you - -- reify the following: - -- - -- newtype T (f :: forall a. a -> Type) = MkT (f Bool) - -- - -- Then you should receive back `f Bool`, not `f Type Bool`, since the - -- `Type` argument is invisible (#15792). - filter_out_invisible_args :: Type -> [Type] -> [Type] - filter_out_invisible_args ty_head ty_args = - filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args) - ty_args -reifyType ty@(FunTy { ft_af = af, ft_mult = Many, ft_arg = t1, ft_res = t2 }) - | InvisArg <- af = reify_for_all Inferred ty -- Types like ((?x::Int) => Char -> Char) - | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] - ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } -reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 }) - | InvisArg <- af = noTH (text "linear invisible argument") (ppr ty) - | otherwise = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2] - ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) } -reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH -reifyType ty@(CoercionTy {})= noTH (text "coercions in types") (ppr ty) - -reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type --- Arg of reify_for_all is always ForAllTy or a predicate FunTy -reify_for_all argf ty - | isVisibleArgFlag argf - = do let (req_bndrs, phi) = tcSplitForAllReqTVBinders ty - tvbndrs' <- reifyTyVarBndrs req_bndrs - phi' <- reifyType phi - pure $ TH.ForallVisT tvbndrs' phi' - | otherwise - = do let (inv_bndrs, phi) = tcSplitForAllInvisTVBinders ty - tvbndrs' <- reifyTyVarBndrs inv_bndrs - let (cxt, tau) = tcSplitPhiTy phi - cxt' <- reifyCxt cxt - tau' <- reifyType tau - pure $ TH.ForallT tvbndrs' cxt' tau' - -reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit -reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) -reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) -reifyTyLit (CharTyLit c) = return (TH.CharTyLit c) - -reifyTypes :: [Type] -> TcM [TH.Type] -reifyTypes = mapM reifyType - -reifyPatSynType - :: ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Scaled Type], Type) -> TcM TH.Type --- reifies a pattern synonym's type and returns its *complete* type --- signature; see NOTE [Pattern synonym signatures and Template --- Haskell] -reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy) - = do { univTyVars' <- reifyTyVarBndrs univTyVars - ; req' <- reifyCxt req - ; exTyVars' <- reifyTyVarBndrs exTyVars - ; prov' <- reifyCxt prov - ; tau' <- reifyType (mkVisFunTys argTys resTy) - ; return $ TH.ForallT univTyVars' req' - $ TH.ForallT exTyVars' prov' tau' } - -reifyKind :: Kind -> TcM TH.Kind -reifyKind = reifyType - -reifyCxt :: [PredType] -> TcM [TH.Pred] -reifyCxt = mapM reifyType - -reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep -reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) - -class ReifyFlag flag flag' | flag -> flag' where - reifyFlag :: flag -> flag' - -instance ReifyFlag () () where - reifyFlag () = () - -instance ReifyFlag Specificity TH.Specificity where - reifyFlag SpecifiedSpec = TH.SpecifiedSpec - reifyFlag InferredSpec = TH.InferredSpec - -reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr ()] -reifyTyVars = reifyTyVarBndrs . map mk_bndr - where - mk_bndr tv = Bndr tv () - -reifyTyVarBndrs :: ReifyFlag flag flag' - => [VarBndr TyVar flag] -> TcM [TH.TyVarBndr flag'] -reifyTyVarBndrs = mapM reify_tvbndr - where - -- even if the kind is *, we need to include a kind annotation, - -- in case a poly-kind would be inferred without the annotation. - -- See #8953 or test th/T8953 - reify_tvbndr (Bndr tv fl) = TH.KindedTV (reifyName tv) - (reifyFlag fl) - <$> reifyKind (tyVarKind tv) - -reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr ()]) -reifyTyVarsToMaybe [] = pure Nothing -reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys - -reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type -reify_tc_app tc tys - = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys) - ; maybe_sig_t (mkThAppTs r_tc tys') } - where - arity = tyConArity tc - - r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2) - | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2) - | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2) - -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon - | isTupleTyCon tc = if isPromotedDataCon tc - then TH.PromotedTupleT arity - else TH.TupleT arity - | tc `hasKey` constraintKindTyConKey - = TH.ConstraintT - | tc `hasKey` unrestrictedFunTyConKey = TH.ArrowT - | tc `hasKey` listTyConKey = TH.ListT - | tc `hasKey` nilDataConKey = TH.PromotedNilT - | tc `hasKey` consDataConKey = TH.PromotedConsT - | tc `hasKey` heqTyConKey = TH.EqualityT - | tc `hasKey` eqPrimTyConKey = TH.EqualityT - | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon) - | isPromotedDataCon tc = TH.PromotedT (reifyName tc) - | otherwise = TH.ConT (reifyName tc) - - -- See Note [When does a tycon application need an explicit kind - -- signature?] in GHC.Core.TyCo.Rep - maybe_sig_t th_type - | tyConAppNeedsKindSig - False -- We don't reify types using visible kind applications, so - -- don't count specified binders as contributing towards - -- injective positions in the kind of the tycon. - tc (length tys) - = do { let full_kind = tcTypeKind (mkTyConApp tc tys) - ; th_full_kind <- reifyKind full_kind - ; return (TH.SigT th_type th_full_kind) } - | otherwise - = return th_type - ------------------------------- -reifyName :: NamedThing n => n -> TH.Name -reifyName thing - | isExternalName name - = mk_varg pkg_str mod_str occ_str - | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name)) - -- Many of the things we reify have local bindings, and - -- NameL's aren't supposed to appear in binding positions, so - -- we use NameU. When/if we start to reify nested things, that - -- have free variables, we may need to generate NameL's for them. - where - name = getName thing - mod = assert (isExternalName name) $ nameModule name - pkg_str = unitString (moduleUnit mod) - mod_str = moduleNameString (moduleName mod) - occ_str = occNameString occ - occ = nameOccName name - mk_varg | OccName.isDataOcc occ = TH.mkNameG_d - | OccName.isVarOcc occ = TH.mkNameG_v - | OccName.isTcOcc occ = TH.mkNameG_tc - | 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 (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) - ------------------------------- -reifyFixity :: Name -> TcM (Maybe TH.Fixity) -reifyFixity name - = 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_dir Hs.InfixR = TH.InfixR - conv_dir Hs.InfixL = TH.InfixL - conv_dir Hs.InfixN = TH.InfixN - -reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness -reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness -reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack -reifyUnpackedness SrcUnpack = TH.SourceUnpack - -reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness -reifyStrictness NoSrcStrict = TH.NoSourceStrictness -reifyStrictness SrcStrict = TH.SourceStrict -reifyStrictness SrcLazy = TH.SourceLazy - -reifySourceBang :: DataCon.HsSrcBang - -> (TH.SourceUnpackedness, TH.SourceStrictness) -reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s) - -reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness -reifyDecidedStrictness HsLazy = TH.DecidedLazy -reifyDecidedStrictness HsStrict = TH.DecidedStrict -reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack - -reifyTypeOfThing :: TH.Name -> TcM TH.Type -reifyTypeOfThing th_name = do - thing <- getThing th_name - case thing of - AGlobal (AnId id) -> reifyType (idType id) - AGlobal (ATyCon tc) -> reifyKind (tyConKind tc) - AGlobal (AConLike (RealDataCon dc)) -> - reifyType (idType (dataConWrapId dc)) - AGlobal (AConLike (PatSynCon ps)) -> - reifyPatSynType (patSynSigBndr ps) - ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType - ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType - -- Impossible cases, supposedly: - AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom" - ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon" - APromotionErr _ -> panic "reifyTypeOfThing: APromotionErr" - ------------------------------- -lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget -lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm) -lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) - = return $ ModuleTarget $ - mkModule (stringToUnit $ TH.pkgString pn) (mkModuleName $ TH.modString mn) - -reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a] -reifyAnnotations th_name - = do { name <- lookupThAnnLookup th_name - ; topEnv <- getTopEnv - ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing - ; tcg <- getGblEnv - ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name - ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name - ; return (selectedEpsHptAnns ++ selectedTcgAnns) } - ------------------------------- -modToTHMod :: Module -> TH.Module -modToTHMod m = TH.Module (TH.PkgName $ unitString $ moduleUnit m) - (TH.ModName $ moduleNameString $ moduleName m) - -reifyModule :: TH.Module -> TcM TH.ModuleInfo -reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do - this_mod <- getModule - let reifMod = mkModule (stringToUnit pkgString) (mkModuleName mString) - if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod - where - reifyThisModule = do - usages <- fmap (map modToTHMod . moduleEnvKeys . 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] ] - 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 :: SDoc -> SDoc -> TcM a -noTH s d = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (hsep [text "Can't represent" <+> s <+> - text "in Template Haskell:", - nest 2 d]) + tcTypedSplice, tcTypedBracket, tcUntypedBracket, + runAnnotation, + + runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, + tcTopSpliceExpr, lookupThName_maybe, + defaultRunMeta, runMeta', runRemoteModFinalizers, + finishTH, runTopSplice + ) where + +import GHC.Prelude + +import GHC.Driver.Errors +import GHC.Driver.Plugins +import GHC.Driver.Main +import GHC.Driver.Session +import GHC.Driver.Env +import GHC.Driver.Hooks +import GHC.Driver.Config.Diagnostic +import GHC.Driver.Config.Finder + +import GHC.Hs + +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.TcType +import GHC.Tc.Gen.Expr +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.Env +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Zonk +import GHC.Tc.Solver +import GHC.Tc.Utils.TcMType +import GHC.Tc.Gen.HsType +import GHC.Tc.Instance.Family +import GHC.Tc.Utils.Instantiate + +import GHC.Core.Multiplicity +import GHC.Core.Coercion( etaExpandCoAxBranch ) +import GHC.Core.Type as Type +import GHC.Core.TyCo.Rep as TyCoRep +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv as InstEnv + +import GHC.Builtin.Names.TH +import GHC.Builtin.Names +import GHC.Builtin.Types + +import GHC.ThToHs +import GHC.HsToCore.Docs +import GHC.HsToCore.Expr +import GHC.HsToCore.Monad +import GHC.IfaceToCore +import GHC.Iface.Load + +import GHCi.Message +import GHCi.RemoteTypes +import GHC.Runtime.Interpreter + +import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) +import GHC.Rename.Expr +import GHC.Rename.Env +import GHC.Rename.Fixity ( lookupFixityRn_help ) +import GHC.Rename.HsType + +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.PatSyn +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 +import GHC.Types.Name.Reader +import GHC.Types.Name.Occurrence as OccName +import GHC.Types.Var +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Unique +import GHC.Types.Var.Set +import GHC.Types.Meta +import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Types.Error +import GHC.Types.Fixity as Hs +import GHC.Types.Annotations +import GHC.Types.Name +import GHC.Types.Unique.Map +import GHC.Serialized + +import GHC.Unit.Finder +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Deps + +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.TmpFs ( newTempName, TempFileLifetime(..) ) + +import GHC.Data.FastString +import GHC.Data.Maybe( MaybeErr(..) ) +import qualified GHC.Data.EnumSet as EnumSet + +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 + +#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 ) +#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 +import Data.Dynamic ( fromDynamic, toDyn ) +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) +import Data.Data (Data) +import Data.Proxy ( Proxy (..) ) +import GHC.Parser.HaddockLex (lexHsDoc) +import GHC.Parser (parseIdentifier) +import GHC.Rename.Doc (rnHsDoc) + + + +{- +Note [Template Haskell state diagram] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here are the ThStages, s, their corresponding level numbers +(the result of (thLevel s)), and their state transitions. +The top level of the program is stage Comp: + + Start here + | + V + ----------- $ ------------ $ + | Comp | ---------> | Splice | -----| + | 1 | | 0 | <----| + ----------- ------------ + ^ | ^ | + $ | | [||] $ | | [||] + | v | v + -------------- ---------------- + | Brack Comp | | Brack Splice | + | 2 | | 1 | + -------------- ---------------- + +* Normal top-level declarations start in state Comp + (which has level 1). + Annotations start in state Splice, since they are + treated very like a splice (only without a '$') + +* Code compiled in state Splice (and only such code) + 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) + +* However things at level 0 are not *necessarily* imported. + eg $( \b -> ... ) here b is bound at level 0 + +* In GHCi, variables bound by a previous command are treated + as impLevel, because we have bytecode for them. + +* Variables are bound at the "current level" + +* The current level starts off at outerLevel (= 1) + +* The level is decremented by splicing $(..) + incremented by brackets [| |] + incremented by name-quoting 'f + +* When a variable is used, checkWellStaged compares + bind: binding level, and + use: current level at usage site + + Generally + bind > use Always error (bound later than used) + [| \x -> $(f x) |] + + bind = use Always OK (bound same stage as used) + [| \x -> $(f [| x |]) |] + + bind < use Inside brackets, it depends + Inside splice, OK + Inside neither, OK + + For (bind < use) inside brackets, there are three cases: + - Imported things OK f = [| map |] + - Top-level things OK g = [| f |] + - Non-top-level Only if there is a liftable instance + h = \(x:Int) -> [| x |] + + To track top-level-ness we use the ThBindEnv in TcLclEnv + + For example: + f = ... + g1 = $(map ...) is OK + g2 = $(f ...) is not OK; because we haven't compiled f yet + + +Note [How top-level splices are handled] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Top-level splices (those not inside a [| .. |] quotation bracket) are handled +very straightforwardly: + + 1. tcTopSpliceExpr: typecheck the body e of the splice $(e) + + 2. runMetaT: desugar, compile, run it, and convert result back to + GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName, + HsExpr RdrName etc) + + 3. treat the result as if that's what you saw in the first place + e.g for HsType, rename and kind-check + for HsExpr, rename and type-check + + (The last step is different for decls, because they can *only* be + top-level: we return the result of step 2.) + +Note [Warnings for TH splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only produce warnings for TH splices when the user requests so +(-fenable-th-splice-warnings). There are multiple reasons: + + * It's not clear that the user that compiles a splice is the author of the code + that produces the warning. Think of the situation where they just splice in + code from a third-party library that produces incomplete pattern matches. + In this scenario, the user isn't even able to fix that warning. + * Gathering information for producing the warnings (pattern-match check + warnings in particular) is costly. There's no point in doing so if the user + is not interested in those warnings. + +That's why we store Origin flags in the Haskell AST. The functions from ThToHs +take such a flag and depending on whether TH splice warnings were enabled or +not, we pass FromSource (if the user requests warnings) or Generated +(otherwise). This is implemented in getThSpliceOrigin. + +For correct pattern-match warnings it's crucial that we annotate the Origin +consistently (#17270). In the future we could offer the Origin as part of the +TH AST. That would enable us to give quotes from the current module get +FromSource origin, and/or third library authors to tag certain parts of +generated code as FromSource to enable warnings. +That effort is tracked in #14838. + +Note [The life cycle of a TH quotation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When desugaring a bracket (aka quotation), we want to produce Core +code that, when run, will produce the TH syntax tree for the quotation. +To that end, we want to desugar /renamed/ but not /typechecked/ code; +the latter is cluttered with the typechecker's elaboration that should +not appear in the TH syntax tree. So in (HsExpr GhcTc) tree, we must +have a (HsExpr GhcRn) for the quotation itself. + +As such, when typechecking both typed and untyped brackets, +we keep a /renamed/ bracket in the extension field. + +The HsBracketTc, the GhcTc ext field for both typed and untyped +brackets, contains: + - The renamed quote :: HsQuote GhcRn -- for the desugarer + - [PendingTcSplice] + - The type of the quote + - Maybe QuoteWrapper + +Note that HsBracketTc stores the untyped (HsQuote GhcRn) for both typed and +untyped brackets. They are treated uniformly by the desugarer, and we can +easily construct untyped brackets from typed ones (with ExpBr). + +See Note [Desugaring of brackets]. + +------------ +Typed quotes +------------ +Here is the life cycle of a /typed/ quote [|| e ||], whose datacon is + HsTypedBracket (XTypedBracket p) (LHsExpr p) + + In pass p (XTypedBracket p) (LHsExpr p) + ------------------------------------------- + GhcPs Annotations only LHsExpr GhcPs + GhcRn Annotations only LHsExpr GhcRn + GhcTc HsBracketTc LHsExpr GhcTc: unused! + +Note that in the GhcTc tree, the second field (HsExpr GhcTc) +is entirely unused; the desugarer uses the (HsExpr GhcRn) from the +first field. + +-------------- +Untyped quotes +-------------- +Here is the life cycle of an /untyped/ quote, whose datacon is + HsUntypedBracket (XUntypedBracket p) (HsQuote p) + +Here HsQuote is a sum-type of expressions [| e |], patterns [| p |], +types [| t |] etc. + + In pass p (XUntypedBracket p) (HsQuote p) + ------------------------------------------------------- + GhcPs Annotations only HsQuote GhcPs + GhcRn Annotations, [PendingRnSplice] HsQuote GhcRn + GhcTc HsBracketTc HsQuote GhcTc: unused! + +The difficulty is: the typechecker does not typecheck the body of an +untyped quote, so how do we make a (HsQuote GhcTc) to put in the +second field? + +Answer: we use the extension constructor of HsQuote, namely XQuote, +and make all the other constructors into DataConCantHappen. That is, +the only non-bottom value of type (HsQuote GhcTc) is (XQuote noExtField). +Hence the instances + + type instance XExpBr GhcTc = DataConCantHappen + ...etc... + +See the related Note [How brackets and nested splices are handled] + +Note [Typechecking Overloaded Quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The main function for typechecking untyped quotations is `tcUntypedBracket`. + +Consider an expression quote, `[| e |]`, its type is `forall m . Quote m => m Exp`. +Note carefully that this is overloaded: its type is not `Q Exp` for some fixed Q. + +When we typecheck it we therefore create a template of a metavariable +`m` applied to `Exp` and emit a constraint `Quote m`. All this is done +in the `brackTy` function. `brackTy` also selects the correct +contents type for the quotation (Exp, Type, Decs etc). + +The meta variable and the constraint evidence variable are +returned together in a `QuoteWrapper` and then passed along to two further places +during compilation: + +1. Typechecking nested splices (immediately in tcPendingSplice) +2. Desugaring quotations (see GHC.HsToCore.Quote) + +`tcPendingSplice` takes the `m` type variable as an argument and +checks each nested splice against this variable `m`. During this +process the variable `m` can either be fixed to a specific value or +further constrained by the nested splices. + +Once we have checked all the nested splices, the quote type is checked against +the expected return type. + +The process is very simple and like typechecking a list where the quotation is +like the container and the splices are the elements of the list which must have +a specific type. + +After the typechecking process is completed, the evidence variable for `Quote m` +and the type `m` is stored in a `QuoteWrapper` which is passed through the pipeline +and used when desugaring quotations. + +Typechecking typed quotations is a similar idea but the `QuoteWrapper` is stored +in the `PendingStuff` as the nested splices are gathered up in a different way +to untyped splices. Untyped splices are found in the renamer but typed splices are +not typechecked and extracted until during typechecking. + +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]). + +The type structure is + + data HsExpr p = ... + | HsUntypedSplice (XUntypedSplice p) (HsUntypedSplice p) + + data HsUntypedSplice p + = HsUntypedSpliceExpr (XUntypedSpliceExpr p) (LHsExpr p) + | HsQuasiQuote (XQuasiQuote p) (IdP id) (XRec p FastString) + +Remember that 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 + + type instance XUntypedSplice GhcTc = DataConCantHappen + +Top-level and nested splices are handled differently. + +------------------------------------- +Nested untyped splices/quasiquotes +---------------------------------- +When we rename an /untyped/ bracket, such as + [| f $(g x) |] +we name and lift out all the nested splices, so that when the +typechecker hits the bracket, it can typecheck those nested splices +without having to walk over the untyped bracket code. Our example +[| f $(g x) |] parses as + + HsUntypedBracket _ + (HsApp (HsVar "f") + (HsUntypedSplice _ (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcPs))) + +RENAMER (rnUntypedBracket): + +* Set the ThStage to (Brack s (RnPendingUntyped ps_var)) + +* Rename the body + +* Nested splices (which must be untyped) are renamed (rnUntypedSplice), + and the results accumulated in ps_var. Each gets a fresh + SplicePointName, 'spn' + +* The SplicePointName connects the `PendingRnSplice` with the particular point + in the syntax tree where that expression should be spliced in. That point + in the tree is identified by `(HsUntypedSpliceNested spn)`. It is used by + the desugarer, so that we ultimately generate something like + let spn = g x + in App (Var "f") spn + +The result is + HsUntypedBracket + [PendingRnSplice UntypedExpSplice spn (g x :: LHsExpr GHcRn)] + (HsApp (HsVar f) (HsUntypedSplice (HsUntypedSpliceNested spn) + (HsUntypedSpliceExpr _ (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 + - In the HsUntypedSpliceExpr in the body of the bracket. This copy is used + only for pretty printing. + +NB: a single untyped bracket can contain many splices, each of a different +`UntypedSpliceFlavour`. For example + + [| 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. + +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. + +* Ignore the body of the bracket; just check that the context + expects a bracket of that type (e.g. a [p| pat |] bracket should + be in a context needing a (m Pat) + +* Stash the whole lot inside a HsBracketTc + +Result is: + HsUntypedBracket + (HsBracketTc { hsb_splices = [PendingTcSplice spn (g x :: LHsExpr GHcTc)] + , hsb_quote = HsApp (HsVar f) + (HsUntypedSplice (HsUntypedSpliceNested spn) + (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcRn))) + }) + (XQuote noExtField) + +NB in the typechecker output, the original payload (which would now +have type (HsQuote GhcTc) is stubbed off with (XQuote noExtField). The payload +is now in the hsb_quote field of the HsBracketTc. + + +------------------------------------- +Top-level untyped splices/quasiquotes +------------------------------------- +A top-level splice (not inside a bracket) does not need a SpliceName, +nor does a top-level splice ever end up inside a PendingRnSplice; +hence HsUntypedSpliceTop does not have a SplicePointName field. + +Example $(g x). This is parsed as + + HsUntypedSplice _ (HsUntypedSpliceExpr _ ((g x) :: LHsExpr GhcPs)) + +Renamer: the renamer runs the splice, so the output of the renamer looks like + + HsUntypedSplice (HsUntypedSpliceTop fins (e2 :: LHsExpr GhcRn)) + (HsUntypedSpliceExpr ((g x) :: LHsExpr GhcRn)) + +where 'e2' is the result of running (g x) to + produce the syntax tree for 'e2' + 'fins' is a bunch of TH finalisers, to be run later. + +Typechecker: the typechecker simply adds the finalisers, and +typechecks e2, discarding the HsUntypedSplice altogether. + + +Note [Lifecycle of an typed splice, and PendingTcSplice] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +---------------------- +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 +the splice expression with the point in the syntax tree where it is +used. Example: + [|| f $$(g 2)||] + +Parser: this is parsed as + + HsTypedBracket _ (HsApp (HsVar "f") + (HsTypedSplice _ (g 2 :: LHsExpr GhcPs))) + +RENAMER (rnTypedSplice): the renamer adds a SplicePointName, spn: + + HsTypedBracket _ (HsApp (HsVar "f") + (HsTypedSplice spn (g x :: LHsExpr GhcRn))) + +TYPECHECKER (tcTypedBracket): + +* Set the ThStage to (Brack s (TcPending ps_var lie_var)) + +* Typecheck the body, and keep the elaborated result (despite never using it!) + +* Nested splices (which must be typed) are typechecked by tcNestedSplice, 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 + where rn_brack is the untyped renamed exp quote constructed from the typed renamed expression :: HsQuote GhcRn + +Just like untyped brackets, dump the output into a HsBracketTc. + + HsTypedBracket + (HsBracketTc { hsb_splices = [PendingTcSplice spn (g x :: LHsExpr GHcTc)] + , hsb_quote = HsApp (HsVar f) + (HsUntypedSplice (HsUntypedSpliceNested spn) + (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcRn))) + }) + (panic "should never be looked at") + +NB: we never need to represent typed /nested/ splices in phase GhcTc. + +There are only typed expression splices so `PendingTcSplice` doesn't have a +flavour field. + + +-------------------------------- +Top-level, typed splices $$(f x) +-------------------------------- +Typed splices are renamed and typechecked, but only actually run in +the zonker, after typechecking. See Note [Running typed splices in the zonker] + +* Output of parser: + HsTypedSplice _ (e :: HsExpr GhcPs) + +* Output of renamer: + HsTypedSplice (n :: SplicePointName) (e :: HsExpr GhcRn) + +* Output of typechecker: (top-level splices only) + HsTypedSplice (del_splice :: DelayedSplice) (e :: HsExpr GhcTc) + where 'del_splice' is something the zonker can run to produce + the syntax tree to splice in. + See Note [Running typed splices in the zonker] + +Note [Desugaring of brackets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In both cases, desugaring happens like this: + * Hs*Bracket is desugared by GHC.HsToCore.Quote.dsBracket using the renamed + expression held in `HsBracketTc` (`type instance X*Bracket GhcTc = HsBracketTc`). It + + a) Extends the ds_meta environment with the PendingSplices + attached to the bracket + + b) Converts the quoted (HsExpr Name) to a CoreExpr that, when + run, will produce a suitable TH expression/type/decl. This + is why we leave the *renamed* expression attached to the bracket: + the quoted expression should not be decorated with all the goop + added by the type checker + + * Each splice carries a unique Name, called a "splice point", thus + ${n}(e). The name is initialised to an (Unqual "splice") when the + splice is created; the renamer gives it a unique. + + * When GHC.HsToCore.Quote (used to desugar the body of the bracket) comes across + a splice, it looks up the splice's Name, n, in the ds_meta envt, + to find an (HsExpr Id) that should be substituted for the splice; + it just desugars it to get a CoreExpr (GHC.HsToCore.Quote.repSplice). + +Example: + Source: f = [| Just $(g 3) |] + The [| |] part is a HsUntypedBracket GhcPs + + Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3} + The [| |] part is a HsUntypedBracket GhcTc, containing *renamed* + (not typechecked) expression (see Note [The life cycle of a TH quotation]) + The "s7" is the "splice point"; the (g Int 3) part + is a typechecked expression + + Desugared: f = do { s7 <- g Int 3 + ; return (ConE "Data.Maybe.Just" s7) } + +-} + +{- +************************************************************************ +* * +\subsection{Main interface + stubs for the non-GHCI case +* * +************************************************************************ +-} + +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 + +runAnnotation :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation +{- +************************************************************************ +* * +\subsection{Quoting an expression} +* * +************************************************************************ +-} + +-- 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 [] + ; lie_var <- getConstraintVar -- Any constraints arising from nested splices + -- should get thrown into the constraint set + -- from outside the bracket + + -- Make a new type variable for the type of the overall quote + ; m_var <- mkTyVarTy <$> mkMetaTyVar + -- Make sure the type variable satisfies Quote + ; ev_var <- emitQuoteWanted m_var + -- 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)) $ + 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 + ; codeco <- tcLookupId unsafeCodeCoerceName + ; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName + ; let brack_tc = HsBracketTc { hsb_quote = ExpBr noExtField expr, hsb_ty = bracket_ty + , hsb_wrap = Just wrapper, hsb_splices = ps' } + -- The tc_expr is stored here so that the expression can be used in HIE files. + brack_expr = HsTypedBracket brack_tc tc_expr + ; tcWrapResultO (Shouldn'tHappenOrigin "TH typed bracket expression") + rn_expr + (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper) + (nlHsTyApp codeco [rep, expr_ty])) + (noLocA brack_expr))) + meta_ty res_ty } + +-- See Note [Typechecking Overloaded Quotes] +tcUntypedBracket rn_expr brack ps res_ty + = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps) + + -- Create the type m Exp for expression bracket, m Type for a type + -- bracket and so on. The brack_info is a Maybe because the + -- VarBracket ('a) isn't overloaded, but also shouldn't contain any + -- splices. + ; (brack_info, expected_type) <- brackTy brack + + -- 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 + Nothing -> assert (null ps) $ return [] + + -- Notice that we don't attempt to typecheck the body + -- of the bracket, which is in brack. + ; traceTc "tc_bracket done untyped" (ppr expected_type) + + -- Unify the overall type of the bracket with the expected result type + ; tcWrapResultO BracketOrigin rn_expr + (HsUntypedBracket (HsBracketTc { hsb_quote = brack, hsb_ty = expected_type + , hsb_wrap = brack_info, hsb_splices = ps' }) + (XQuote noExtField)) + -- (XQuote noExtField): see Note [The life cycle of a TH quotation] in GHC.Hs.Expr + expected_type res_ty + + } + +-- | A type variable with kind * -> * named "m" +mkMetaTyVar :: TcM TyVar +mkMetaTyVar = + newNamedFlexiTyVar (fsLit "m") (mkVisFunTyMany liftedTypeKind liftedTypeKind) + + +-- | For a type 'm', emit the constraint 'Quote m'. +emitQuoteWanted :: Type -> TcM EvVar +emitQuoteWanted m_var = do + quote_con <- tcLookupTyCon quoteClassName + emitWantedEvVar BracketOrigin $ + mkTyConApp quote_con [m_var] + +--------------- +-- | Compute the expected type of a quotation, and also the QuoteWrapper in +-- the case where it is an overloaded quotation. All quotation forms are +-- overloaded aprt from Variable quotations ('foo) +brackTy :: HsQuote GhcRn -> TcM (Maybe QuoteWrapper, Type) +brackTy b = + let mkTy n = do + -- New polymorphic type variable for the bracket + m_var <- mkTyVarTy <$> mkMetaTyVar + -- Emit a Quote constraint for the bracket + ev_var <- emitQuoteWanted m_var + -- Construct the final expected type of the quote, for example + -- m Exp or m Type + final_ty <- mkAppTy m_var <$> tcMetaTy n + -- Return the evidence variable and metavariable to be used during + -- desugaring. + let wrapper = QuoteWrapper ev_var m_var + return (Just wrapper, final_ty) + in + case b of + (VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName + -- Result type is Var (not Quote-monadic) + (ExpBr {}) -> mkTy expTyConName -- Result type is m Exp + (TypBr {}) -> mkTy typeTyConName -- Result type is m Type + (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec] + (PatBr {}) -> mkTy patTyConName -- Result type is m Pat + (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL" + +--------------- +-- | Typechecking a pending splice from a untyped bracket +tcPendingSplice :: TcType -- Metavariable for the expected overall type of the + -- quotation. + -> PendingRnSplice + -> TcM PendingTcSplice +tcPendingSplice m_var (PendingRnSplice flavour splice_name 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 + ; 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 + +--------------- +-- 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) + ; 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) + + + -- The whole of the rest of the file is the else-branch (ie stage2 only) + + +{- +************************************************************************ +* * +\subsection{Splicing an expression} +* * +************************************************************************ +-} + +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 + } + +{- Note [Collecting modFinalizers in typed splices] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local +environment (see Note [Delaying modFinalizers in untyped splices] in +GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the +finalizer list in the global environment and set them to use the current local +environment (with 'addModFinalizersWithLclEnv'). + +-} + +------------------ +tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcTopSplice expr res_ty + = do { -- Typecheck the expression, + -- making sure it has type Q (T res_ty) + 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 + ; 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) + + } + +------------------- +tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) +-- Note [How top-level splices are handled] +-- Type check an expression that is the body of a top-level splice +-- (the caller will compile and run it) +-- Note that set the level to Splice, regardless of the original level, +-- before typechecking the expression. For example: +-- f x = $( ...$(g 3) ... ) +-- The recursive call to tcCheckPolyExpr will simply expand the +-- inner escape before dealing with the outer one + +tcTopSpliceExpr isTypedSplice tc_action + = checkNoErrs $ -- checkNoErrs: must not try to run the thing + -- if the type checker fails! + setStage (Splice isTypedSplice) $ + do { -- Typecheck the expression + (mb_expr', wanted) <- tryCaptureConstraints tc_action + -- If tc_action fails (perhaps because of insoluble constraints) + -- we want to capture and report those constraints, else we may + -- just get a silent failure (#20179). Hence the 'try' part. + + ; const_binds <- simplifyTop wanted + + ; case mb_expr' of + Nothing -> failM -- In this case simplifyTop should have + -- reported some errors + 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 + ; zonked_q_expr <- zonkTopLExpr q_expr + -- See Note [Collecting modFinalizers in typed splices]. + ; modfinalizers_ref <- newTcRef [] + -- Run the expression + ; expr2 <- setStage (RunSplice modfinalizers_ref) $ + runMetaE zonked_q_expr + ; mod_finalizers <- readTcRef modfinalizers_ref + ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers + -- We use orig_expr here and not q_expr when tracing as a call to + -- unsafeCodeCoerce is added to the original expression by the + -- typechecker when typed quotes are type checked. + ; traceSplice (SpliceInfo { spliceDescription = "expression" + , spliceIsDecl = False + , spliceSource = Just orig_expr + , spliceGenerated = ppr expr2 }) + -- Rename and typecheck the spliced-in expression, + -- making sure it has type res_ty + -- These steps should never fail; this is a *typed* splice + ; (res, wcs) <- + captureConstraints $ + addErrCtxt (spliceResultDoc zonked_q_expr) $ do + { (exp3, _fvs) <- rnLExpr expr2 + ; tcCheckMonoExpr exp3 zonked_ty } + ; ev <- simplifyTop wcs + ; return $ unLoc (mkHsDictLet (EvBinds ev) res) + } + + +{- +************************************************************************ +* * + +* * +************************************************************************ +-} + +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") + + +{- +************************************************************************ +* * + Annotations +* * +************************************************************************ +-} + +runAnnotation target expr = do + -- Find the classes we want instances for in order to call toAnnotationWrapper + loc <- getSrcSpanM + data_class <- tcLookupClass dataClassName + to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName + + -- Check the instances we require live in another module (we want to execute it..) + -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr + -- also resolves the LIE constraints to detect e.g. instance ambiguity + zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped ( + do { (expr', expr_ty) <- tcInferRhoNC expr + -- We manually wrap the typechecked expression in a call to toAnnotationWrapper + -- By instantiating the call >here< it gets registered in the + -- LIE consulted by tcTopSpliceExpr + -- and hence ensures the appropriate dictionary is bound by const_binds + ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] + ; 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 + specialised_to_annotation_wrapper_expr expr')) + }) + + -- Run the appropriately wrapped expression to get the value of + -- the annotation and its dictionaries. The return value is of + -- type AnnotationWrapper by construction, so this conversion is + -- safe + serialized <- runMetaAW zonked_wrapped_expr' + return Annotation { + ann_target = target, + ann_value = serialized + } + +convertAnnotationWrapper :: ForeignHValue -> TcM Serialized +convertAnnotationWrapper fhv = do + interp <- tcGetInterp + case interpInstance interp of + ExternalInterp {} -> runTH THAnnWrapper fhv +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do + annotation_wrapper <- liftIO $ wormhole interp fhv + return $ + case unsafeCoerce annotation_wrapper of + AnnotationWrapper value | let serialized = toSerialized serializeWithData value -> + -- Got the value and dictionaries: build the serialized value and + -- call it a day. We ensure that we seq the entire serialized value + -- in order that any errors in the user-written code for the + -- 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` () + +#endif + +{- +************************************************************************ +* * +\subsection{Running an expression} +* * +************************************************************************ +-} + +runQuasi :: TH.Q a -> TcM a +runQuasi act = TH.runQ act + +runRemoteModFinalizers :: ThModFinalizers -> TcM () +runRemoteModFinalizers (ThModFinalizers finRefs) = do + let withForeignRefs [] f = f [] + 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 + qs <- liftIO (withForeignRefs finRefs $ mapM localRef) + runQuasi $ sequence_ qs +#endif + + ExternalInterp conf iserv -> withIServ_ conf iserv $ \i -> 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 -> + withForeignRefs finRefs $ \qrefs -> + writeIServ i (putMessage (RunModFinalizers st qrefs)) + () <- runRemoteTH i [] + readQResult i + +runQResult + :: (a -> String) + -> (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 + ; th_origin <- getThSpliceOrigin + ; traceTc "Got TH result:" (text (show_th th_result)) + ; return (f th_origin expr_span th_result) } + + +----------------- +runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn) + -> LHsExpr GhcTc + -> TcM hs_syn +runMeta unwrap e = do + hooks <- getHooks + case runMetaHook hooks of + Nothing -> unwrap defaultRunMeta e + Just h -> unwrap h e + +defaultRunMeta :: MetaHook TcM +defaultRunMeta (MetaE r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp) +defaultRunMeta (MetaP r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat) +defaultRunMeta (MetaT r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType) +defaultRunMeta (MetaD r) + = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec) +defaultRunMeta (MetaAW r) + = fmap r . runMeta' False (const empty) (const $ fmap Right . convertAnnotationWrapper) + -- We turn off showing the code in meta-level exceptions because doing so exposes + -- the toAnnotationWrapper function that we slap around the user's code + +---------------- +runMetaAW :: LHsExpr GhcTc -- Of type AnnotationWrapper + -> TcM Serialized +runMetaAW = runMeta metaRequestAW + +runMetaE :: LHsExpr GhcTc -- Of type (Q Exp) + -> TcM (LHsExpr GhcPs) +runMetaE = runMeta metaRequestE + +runMetaP :: LHsExpr GhcTc -- Of type (Q Pat) + -> TcM (LPat GhcPs) +runMetaP = runMeta metaRequestP + +runMetaT :: LHsExpr GhcTc -- Of type (Q Type) + -> TcM (LHsType GhcPs) +runMetaT = runMeta metaRequestT + +runMetaD :: LHsExpr GhcTc -- Of type Q [Dec] + -> TcM [LHsDecl GhcPs] +runMetaD = runMeta metaRequestD + +{- Note [Errors in desugaring a splice] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should we do if there are errors when desugaring a splice? We should +abort. There are several cases to consider: + +(a) The desugarer hits an unrecoverable error and fails in the monad. +(b) The desugarer hits a recoverable error, reports it, and continues. +(c) The desugarer reports a fatal warning (with -Werror), reports it, and continues. +(d) The desugarer reports a non-fatal warning, and continues. + +Each case is tested in th/T19709[abcd]. + +General principle: we wish to report all messages from dealing with a splice +eagerly, as these messages arise during an earlier stage than type-checking +generally. It's also likely that a compile-time warning from spliced code +will be easier to understand then an error that arises from processing the +code the splice produces. (Rationale: the warning will be about the code the +user actually wrote, not what is generated.) + +Case (a): We have no choice but to abort here, but we must make sure that +the messages are printed or logged before aborting. Logging them is annoying, +because we're in the type-checker, and the messages are DsMessages, from the +desugarer. So we report and then fail in the monad. This case is detected +by the fact that initDsTc returns Nothing. + +Case (b): We detect this case by looking for errors in the messages returned +from initDsTc and aborting if we spot any (after printing, of course). Note +that initDsTc will return a Just ds_expr in this case, but we don't wish to +use the (likely very bogus) expression. + +Case (c): This is functionally the same as (b), except that the expression +isn't bogus. We still don't wish to use it, as the user's request for -Werror +tells us not to. + +Case (d): We report the warnings and then carry on with the expression. +This might result in warnings printed out of source order, but this is +appropriate, as the warnings from the splice arise from an earlier stage +of compilation. + +Previously, we failed to abort in cases (b) and (c), leading to #19709. +-} + +--------------- +runMeta' :: Bool -- Whether code should be printed in the exception message + -> (hs_syn -> SDoc) -- how to print the code + -> (SrcSpan -> ForeignHValue -> TcM (Either RunSpliceFailReason hs_syn)) -- How to run x + -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or + -- something like that + -> 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 + -- recovered giving it type f :: forall a.a, it'd be very dodgy + -- to carry on. Mind you, the staging restrictions mean we won't + -- actually run f, but it still seems wrong. And, more concretely, + -- see #5358 for an example that fell over when trying to + -- reify a function with an unlifted kind in it. (These don't occur + -- in type-correct programs.) + ; failIfErrsM + + -- run plugins + ; hsc_env <- getTopEnv + ; expr' <- withPlugins (hsc_plugins hsc_env) spliceRunAction expr + + -- Desugar + ; (ds_msgs, mb_ds_expr) <- initDsTc (dsLExpr expr') + + -- Print any messages (even warnings) eagerly: they might be helpful if anything + -- goes wrong. See Note [Errors in desugaring a splice]. This happens in all + -- cases. + ; logger <- getLogger + ; diag_opts <- initDiagOpts <$> getDynFlags + ; print_config <- initDsMessageOpts <$> getDynFlags + ; liftIO $ printMessages logger print_config diag_opts ds_msgs + + ; ds_expr <- case mb_ds_expr of + Nothing -> failM -- Case (a) from Note [Errors in desugaring a splice] + Just ds_expr -> -- There still might be a fatal warning or recoverable + -- Cases (b) and (c) from Note [Errors in desugaring a splice] + do { when (errorsOrFatalWarningsFound ds_msgs) + failM + ; return ds_expr } + + -- Compile and link it; might fail if linking fails + ; src_span <- getSrcSpanM + ; traceTc "About to run (desugared)" (ppr ds_expr) + ; either_hval <- tryM $ liftIO $ + GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr + ; case either_hval of { + Left exn -> fail_with_exn SplicePhase_CompileAndLink exn ; + Right (hval, needed_mods, needed_pkgs) -> do + + { -- Coerce it to Q t, and run it + + -- Running might fail if it throws an exception of any kind (hence tryAllM) + -- including, say, a pattern-match exception in the code we are running + -- + -- We also do the TH -> HS syntax conversion inside the same + -- exception-catching thing so that if there are any lurking + -- exceptions in the data structure returned by hval, we'll + -- encounter them inside the try + -- + -- See Note [Exceptions in TH] + let expr_span = getLocA expr + ; recordThNeededRuntimeDeps needed_mods needed_pkgs + ; either_tval <- tryAllM $ + setSrcSpan expr_span $ -- Set the span so that qLocation can + -- see where this splice is + do { mb_result <- run_and_convert expr_span hval + ; case mb_result of + Left err -> failWithTc (TcRnRunSpliceFailure Nothing err) + Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result) + ; return $! result } } + + ; case either_tval of + Right v -> return v + Left se -> case fromException se of + Just IOEnvFailure -> failM -- Error already in Tc monad + _ -> fail_with_exn SplicePhase_Run se -- Exception + }}} + where + -- see Note [Concealed TH exceptions] + 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 + +{- +Note [Running typed splices in the zonker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +See #15471 for the full discussion. + +For many years typed splices were run immediately after they were type checked +however, this is too early as it means to zonk some type variables before +they can be unified with type variables in the surrounding context. + +For example, + +``` +module A where + +test_foo :: forall a . Q (TExp (a -> a)) +test_foo = [|| id ||] + +module B where + +import A + +qux = $$(test_foo) +``` + +We would expect `qux` to have inferred type `forall a . a -> a` but if +we run the splices too early the unified variables are zonked to `Any`. The +inferred type is the unusable `Any -> Any`. + +To run the splice, we must compile `test_foo` all the way to byte code. +But at the moment when the type checker is looking at the splice, test_foo +has type `Q (TExp (alpha -> alpha))` and we +certainly can't compile code involving unification variables! + +We could default `alpha` to `Any` but then we infer `qux :: Any -> Any` +which definitely is not what we want. Moreover, if we had + qux = [$$(test_foo), (\x -> x +1::Int)] +then `alpha` would have to be `Int`. + +Conclusion: we must defer taking decisions about `alpha` until the +typechecker is done; and *then* we can run the splice. It's fine to do it +later, because we know it'll produce type-correct code. + +Deferring running the splice until later, in the zonker, means that the +unification variables propagate upwards from the splice into the surrounding +context and are unified correctly. + +This is implemented by storing the arguments we need for running the splice +in a `DelayedSplice`. In the zonker, the arguments are passed to +`GHC.Tc.Gen.Splice.runTopSplice` and the expression inserted into the AST as normal. + + + +Note [Exceptions in TH] +~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have something like this + $( f 4 ) +where + f :: Int -> Q [Dec] + f n | n>3 = fail "Too many declarations" + | otherwise = ... + +The 'fail' is a user-generated failure, and should be displayed as a +perfectly ordinary compiler error message, not a panic or anything +like that. Here's how it's processed: + + * 'fail' is the monad fail. The monad instance for Q in TH.Syntax + effectively transforms (fail s) to + qReport True s >> fail + where 'qReport' comes from the Quasi class and fail from its monad + superclass. + + * The TcM monad is an instance of Quasi (see GHC.Tc.Gen.Splice), and it implements + (qReport True s) by using addErr to add an error message to the bag of errors. + The 'fail' in TcM raises an IOEnvFailure exception + + * 'qReport' forces the message to ensure any exception hidden in unevaluated + thunk doesn't get into the bag of errors. Otherwise the following splice + will trigger panic (#8987): + $(fail undefined) + See also Note [Concealed TH exceptions] + + * So, when running a splice, we catch all exceptions; then for + - an IOEnvFailure exception, we assume the error is already + in the error-bag (above) + - other errors, we add an error to the bag + and then fail + +Note [Concealed TH exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When displaying the error message contained in an exception originated from TH +code, we need to make sure that the error message itself does not contain an +exception. For example, when executing the following splice: + + $( error ("foo " ++ error "bar") ) + +the message for the outer exception is a thunk which will throw the inner +exception when evaluated. + +For this reason, we display the message of a TH exception using the +'safeShowException' function, which recursively catches any exception thrown +when showing an error message. + + +To call runQ in the Tc monad, we need to make TcM an instance of Quasi: +-} + +instance TH.Quasi TcM where + qNewName s = do { u <- newUnique + ; let i = toInteger (getKey u) + ; return (TH.mkNameU s i) } + + -- '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 + + qLocation :: TcM TH.Loc + qLocation = do { m <- getModule + ; l <- getSrcSpanM + ; r <- case l of + UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" + (ppr l) + RealSrcSpan s _ -> return s + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = unitString (moduleUnit m) + , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) + , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } + + qLookupName = lookupName + qReify = reify + qReifyFixity nm = lookupThName nm >>= reifyFixity + qReifyType = reifyTypeOfThing + qReifyInstances = reifyInstances + qReifyRoles = reifyRoles + qReifyAnnotations = reifyAnnotations + qReifyModule = reifyModule + qReifyConStrictness nm = do { nm' <- lookupThName nm + ; dc <- tcLookupDataCon nm' + ; let bangs = dataConImplBangs dc + ; return (map reifyDecidedStrictness bangs) } + + -- For qRecover, discard error messages if + -- the recovery action is chosen. Otherwise + -- we'll only fail higher up. + qRecover recover main = tryTcDiscardingErrs recover main + + qGetPackageRoot = do + dflags <- getDynFlags + return $ fromMaybe "." (workingDirectory dflags) + + qAddDependentFile fp = do + ref <- fmap tcg_dependent_files getGblEnv + dep_files <- readTcRef ref + writeTcRef ref (fp:dep_files) + + qAddTempFile suffix = do + dflags <- getDynFlags + logger <- getLogger + tmpfs <- hsc_tmpfs <$> getTopEnv + liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix + + qAddTopDecls thds = do + l <- getSrcSpanM + th_origin <- getThSpliceOrigin + let either_hval = convertToHsDecls th_origin l thds + ds <- case either_hval of + Left exn -> failWithTc + $ TcRnRunSpliceFailure (Just "addTopDecls") exn + Right ds -> return ds + mapM_ (checkTopDecl . unLoc) ds + th_topdecls_var <- fmap tcg_th_topdecls getGblEnv + updTcRef th_topdecls_var (\topds -> ds ++ topds) + where + checkTopDecl :: HsDecl GhcPs -> TcM () + checkTopDecl (ValD _ binds) + = mapM_ bindName (collectHsBindBinders CollNoDictBinders binds) + checkTopDecl (SigD _ _) + = return () + checkTopDecl (AnnD _ _) + = return () + checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name })) + = bindName name + checkTopDecl d + = addErr $ TcRnInvalidTopDecl d + + bindName :: RdrName -> TcM () + bindName (Exact n) + = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv + ; updTcRef th_topnames_var (\ns -> extendNameSet ns n) + } + + bindName name = addErr $ TcRnNonExactName name + + qAddForeignFilePath lang fp = do + var <- fmap tcg_th_foreign_files getGblEnv + updTcRef var ((lang, fp) :) + + qAddModFinalizer fin = do + r <- liftIO $ mkRemoteRef fin + fref <- liftIO $ mkForeignRef r (freeRemoteRef r) + addModFinalizerRef fref + + qAddCorePlugin plugin = do + hsc_env <- getTopEnv + let fc = hsc_FC hsc_env + let home_unit = hsc_home_unit hsc_env + let dflags = hsc_dflags hsc_env + let fopts = initFinderOpts dflags + r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin) + let err = TcRnAddInvalidCorePlugin plugin + case r of + Found {} -> addErr err + FoundMultiple {} -> addErr err + _ -> return () + th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv + updTcRef th_coreplugins_var (plugin:) + + qGetQ :: forall a. Typeable a => TcM (Maybe a) + qGetQ = do + th_state_var <- fmap tcg_th_state getGblEnv + th_state <- readTcRef th_state_var + -- See #10596 for why we use a scoped type variable here. + return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic) + + qPutQ x = do + th_state_var <- fmap tcg_th_state getGblEnv + updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m) + + qIsExtEnabled = xoptM + + qExtsEnabled = + EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv + + qPutDoc doc_loc s = do + 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 + let ds = mkGeneratedHsDocString s + hd = lexHsDoc parseIdentifier ds + hd' <- rnHsDoc hd + updTcRef th_doc_var (Map.insert resolved_doc_loc hd') + where + resolve_loc (TH.DeclDoc n) = DeclDoc <$> lookupThName n + resolve_loc (TH.ArgDoc n i) = ArgDoc <$> lookupThName n <*> pure i + resolve_loc (TH.InstDoc t) = InstDoc <$> fmap getName (lookupThInstName t) + resolve_loc TH.ModuleDoc = pure ModuleDoc + + -- It doesn't make sense to add documentation to something not inside + -- the current module. So check for it! + checkLocalName (DeclDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n + checkLocalName (ArgDoc n _) = nameIsLocalOrFrom <$> getModule <*> pure n + checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n + checkLocalName ModuleDoc = pure True + + + qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc + qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc + qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i + qGetDoc TH.ModuleDoc = do + df <- getDynFlags + docs <- getGblEnv >>= extractDocs df + return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs)) + +-- | Looks up documentation for a declaration in first the current module, +-- otherwise tries to find it in another module via 'hscGetModuleInterface'. +lookupDeclDoc :: Name -> TcM (Maybe String) +lookupDeclDoc nm = do + df <- getDynFlags + Docs{docs_decls} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df + case lookupUniqMap docs_decls nm of + Just doc -> pure $ Just (renderHsDocStrings $ map hsDocString doc) + Nothing -> do + -- 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} } -> + pure $ renderHsDocStrings . map hsDocString <$> lookupUniqMap dmap nm + _ -> pure Nothing + +-- | Like 'lookupDeclDoc', looks up documentation for a function argument. If +-- it can't find any documentation for a function in this module, it tries to +-- find it in another module. +lookupArgDoc :: Int -> Name -> TcM (Maybe String) +lookupArgDoc i nm = do + df <- getDynFlags + Docs{docs_args = argDocs} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df + case lookupUniqMap argDocs nm of + Just m -> pure $ renderHsDocString . hsDocString <$> IntMap.lookup i m + Nothing -> do + mIface <- getExternalModIface nm + case mIface of + Just ModIface { mi_docs = Just Docs{docs_args = amap} } -> + pure $ renderHsDocString . hsDocString <$> (lookupUniqMap amap nm >>= IntMap.lookup i) + _ -> pure Nothing + +-- | Returns the module a Name belongs to, if it is isn't local. +getExternalModIface :: Name -> TcM (Maybe ModIface) +getExternalModIface nm = do + isLocal <- nameIsLocalOrFrom <$> getModule <*> pure nm + if isLocal + then pure Nothing + else case nameModule_maybe nm of + Nothing -> pure Nothing + Just modNm -> do + hsc_env <- getTopEnv + iface <- liftIO $ hscGetModuleInterface hsc_env modNm + pure (Just iface) + +-- | Find the GHC name of the first instance that matches the TH type +lookupThInstName :: TH.Type -> TcM Name +lookupThInstName th_type = do + cls_name <- inst_cls_name th_type + insts <- reifyInstances' cls_name (inst_arg_types th_type) + case insts of -- This expands any type synonyms + Left (_, (inst:_)) -> return $ getName inst + Left (_, []) -> noMatches + Right (_, (inst:_)) -> return $ getName inst + Right (_, []) -> noMatches + where + noMatches = failWithTc $ + TcRnFailedToLookupThInstName th_type NoMatchesFound + + -- Get the name of the class for the instance we are documenting + -- > inst_cls_name (Monad Maybe) == Monad + -- > inst_cls_name C = C + inst_cls_name :: TH.Type -> TcM TH.Name + inst_cls_name (TH.AppT t _) = inst_cls_name t + inst_cls_name (TH.SigT n _) = inst_cls_name n + inst_cls_name (TH.VarT n) = pure n + inst_cls_name (TH.ConT n) = pure n + inst_cls_name (TH.PromotedT n) = pure n + inst_cls_name (TH.InfixT _ n _) = pure n + inst_cls_name (TH.UInfixT _ n _) = pure n + inst_cls_name (TH.PromotedInfixT _ n _) = pure n + inst_cls_name (TH.PromotedUInfixT _ n _) = pure n + inst_cls_name (TH.ParensT t) = inst_cls_name t + + inst_cls_name (TH.ForallT _ _ _) = inst_cls_name_err + inst_cls_name (TH.ForallVisT _ _) = inst_cls_name_err + inst_cls_name (TH.AppKindT _ _) = inst_cls_name_err + inst_cls_name (TH.TupleT _) = inst_cls_name_err + inst_cls_name (TH.UnboxedTupleT _) = inst_cls_name_err + inst_cls_name (TH.UnboxedSumT _) = inst_cls_name_err + inst_cls_name TH.ArrowT = inst_cls_name_err + inst_cls_name TH.MulArrowT = inst_cls_name_err + inst_cls_name TH.EqualityT = inst_cls_name_err + inst_cls_name TH.ListT = inst_cls_name_err + inst_cls_name (TH.PromotedTupleT _) = inst_cls_name_err + inst_cls_name TH.PromotedNilT = inst_cls_name_err + inst_cls_name TH.PromotedConsT = inst_cls_name_err + inst_cls_name TH.StarT = inst_cls_name_err + inst_cls_name TH.ConstraintT = inst_cls_name_err + inst_cls_name (TH.LitT _) = inst_cls_name_err + inst_cls_name TH.WildCardT = inst_cls_name_err + inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err + + inst_cls_name_err = failWithTc $ + TcRnFailedToLookupThInstName th_type CouldNotDetermineInstance + + -- Basically does the opposite of 'mkThAppTs' + -- > inst_arg_types (Monad Maybe) == [Maybe] + -- > inst_arg_types C == [] + inst_arg_types :: TH.Type -> [TH.Type] + inst_arg_types (TH.AppT _ args) = + let go (TH.AppT t ts) = t:go ts + go t = [t] + in go args + inst_arg_types _ = [] + +-- | Adds a mod finalizer reference to the local environment. +addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () +addModFinalizerRef finRef = do + th_stage <- getStage + case th_stage 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. + -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. + _ -> + pprPanic "addModFinalizer was called when no finalizers were collected" + (ppr th_stage) + +-- | Releases the external interpreter state. +finishTH :: TcM () +finishTH = do + hsc_env <- getTopEnv + case interpInstance <$> hsc_interp hsc_env of + Nothing -> pure () +#if defined(HAVE_INTERNAL_INTERPRETER) + Just InternalInterp -> pure () +#endif + Just (ExternalInterp {}) -> do + tcg <- getGblEnv + writeTcRef (tcg_th_remote_state tcg) Nothing + + +runTHExp :: ForeignHValue -> TcM TH.Exp +runTHExp = runTH THExp + +runTHPat :: ForeignHValue -> TcM TH.Pat +runTHPat = runTH THPat + +runTHType :: ForeignHValue -> TcM TH.Type +runTHType = runTH THType + +runTHDec :: ForeignHValue -> TcM [TH.Dec] +runTHDec = runTH THDec + +runTH :: Binary a => THResultType -> ForeignHValue -> TcM a +runTH ty fhv = do + interp <- tcGetInterp + case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> do + -- Run it in the local TcM + hv <- liftIO $ wormhole interp fhv + r <- runQuasi (unsafeCoerce hv :: TH.Q a) + return r +#endif + + ExternalInterp conf iserv -> + -- 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) + + +-- | communicate with a remotely-running TH computation until it finishes. +-- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. +runRemoteTH + :: IServInstance + -> [Messages TcRnMessage] -- saved from nested calls to qRecover + -> TcM () +runRemoteTH iserv recovers = do + THMsg msg <- liftIO $ readIServ iserv getTHMessage + 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) + EndRecover caught_error -> do + let (prev_msgs, rest) = case recovers of + [] -> panic "EndRecover" + a : b -> (a,b) + v <- getErrsVar + warn_msgs <- getWarningMessages <$> readTcRef v + -- keep the warnings only if there were no errors + writeTcRef v $ if caught_error + then prev_msgs + else mkMessages warn_msgs `unionMessages` prev_msgs + runRemoteTH iserv rest + _other -> do + r <- handleTHMessage msg + liftIO $ writeIServ iserv (put r) + runRemoteTH iserv recovers + +-- | Read a value of type QResult from the iserv +readQResult :: Binary a => IServInstance -> TcM a +readQResult i = do + qr <- liftIO $ readIServ i get + case qr of + QDone a -> return a + QException str -> liftIO $ throwIO (ErrorCall str) + QFail str -> fail str + +{- Note [TH recover with -fexternal-interpreter] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recover is slightly tricky to implement. + +The meaning of "recover a b" is + - Do a + - If it finished with no errors, then keep the warnings it generated + - If it failed, discard any messages it generated, and do b + +Note that "failed" here can mean either + (1) threw an exception (failTc) + (2) generated an error message (addErrTcM) + +The messages are managed by GHC in the TcM monad, whereas the +exception-handling is done in the ghc-iserv process, so we have to +coordinate between the two. + +On the server: + - emit a StartRecover message + - run "a; FailIfErrs" inside a try + - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed + - if "a; FailIfErrs" failed, run "b" + +Back in GHC, when we receive: + + FailIfErrrs + failTc if there are any error messages (= failIfErrsM) + StartRecover + save the current messages and start with an empty set. + EndRecover caught_error + Restore the previous messages, + and merge in the new messages if caught_error is false. +-} + +-- | Retrieve (or create, if it hasn't been created already), the +-- remote TH state. The TH state is a remote reference to an IORef +-- QState living on the server, and we have to pass this to each RunTH +-- call we make. +-- +-- 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 + +wrapTHResult :: TcM a -> TcM (THResult a) +wrapTHResult tcm = do + e <- tryM tcm -- only catch 'fail', treat everything else as catastrophic + case e of + Left e -> return (THException (show e)) + Right a -> return (THComplete a) + +handleTHMessage :: THMessage a -> TcM a +handleTHMessage msg = case msg of + NewName a -> wrapTHResult $ TH.qNewName a + Report b str -> wrapTHResult $ TH.qReport b str + LookupName b str -> wrapTHResult $ TH.qLookupName b str + Reify n -> wrapTHResult $ TH.qReify n + ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n + ReifyType n -> wrapTHResult $ TH.qReifyType n + ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts + ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n + ReifyAnnotations lookup tyrep -> + wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep) + ReifyModule m -> wrapTHResult $ TH.qReifyModule m + ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm + GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot + AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f + AddTempFile s -> wrapTHResult $ TH.qAddTempFile s + AddModFinalizer r -> do + interp <- hscInterp <$> getTopEnv + wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef + AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str + AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs + AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str + IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext + ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled + PutDoc l s -> wrapTHResult $ TH.qPutDoc l s + GetDoc l -> wrapTHResult $ TH.qGetDoc l + FailIfErrs -> wrapTHResult failIfErrsM + _ -> panic ("handleTHMessage: unexpected message " ++ show msg) + +getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]] +getAnnotationsByTypeRep th_name tyrep + = do { name <- lookupThAnnLookup th_name + ; topEnv <- getTopEnv + ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing + ; tcg <- getGblEnv + ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep + ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep + ; return (selectedEpsHptAnns ++ selectedTcgAnns) } + +{- +************************************************************************ +* * + Instance Testing +* * +************************************************************************ +-} + +reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] +reifyInstances th_nm th_tys + = do { insts <- reifyInstances' th_nm th_tys + ; case insts of + Left (cls, cls_insts) -> + reifyClassInstances cls cls_insts + Right (tc, fam_insts) -> + reifyFamilyInstances tc fam_insts } + +reifyInstances' :: TH.Name + -> [TH.Type] + -> TcM (Either (Class, [ClsInst]) (TyCon, [FamInst])) + -- ^ 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 + ; th_origin <- getThSpliceOrigin + ; rdr_ty <- cvt 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 + -- Rename to HsType Name + ; ((tv_names, rn_ty), _fvs) + <- checkNoErrs $ -- If there are out-of-scope Names here, then we + -- must error before proceeding to typecheck the + -- renamed type, as that will result in GHC + -- internal errors (#13837). + rnImplicitTvOccs Nothing tv_rdrs $ \ tv_names -> + do { (rn_ty, fvs) <- rnLHsType doc rdr_ty + ; return ((tv_names, rn_ty), fvs) } + ; skol_info <- mkSkolemInfo ReifySkol + ; (tclvl, wanted, (tvs, ty)) + <- pushLevelAndSolveEqualitiesX "reifyInstances" $ + bindImplicitTKBndrs_Skol skol_info tv_names $ + tcInferLHsType rn_ty + + ; tvs <- zonkAndScopedSort tvs + + -- Avoid error cascade if there are unsolved + ; reportUnsolvedEqualities skol_info tvs tclvl wanted + + ; ty <- zonkTcTypeToType ty + -- Substitute out the meta type variables + -- In particular, the type might have kind + -- variables inside it (#7477) + + ; traceTc "reifyInstances'" (ppr ty $$ ppr (typeKind ty)) + ; case splitTyConApp_maybe ty of -- This expands any type synonyms + Just (tc, tys) -- See #7910 + | Just cls <- tyConClass_maybe tc + -> 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) } + | 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 } + where + doc = ClassInstanceCtx + 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) + Right ty -> return ty + +{- +************************************************************************ +* * + Reification +* * +************************************************************************ +-} + +lookupName :: Bool -- True <=> type namespace + -- False <=> value namespace + -> String -> TcM (Maybe TH.Name) +lookupName is_type_name s + = do { mb_nm <- lookupOccRn_maybe rdr_name + ; return (fmap reifyName mb_nm) } + where + th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M' + + occ_fs :: FastString + occ_fs = mkFastString (TH.nameBase th_name) + + occ :: OccName + occ | is_type_name + = if isLexVarSym occ_fs || isLexCon occ_fs + then mkTcOccFS occ_fs + else mkTyVarOccFS occ_fs + | otherwise + = if isLexCon occ_fs then mkDataOccFS occ_fs + else mkVarOccFS occ_fs + + rdr_name = case TH.nameModule th_name of + Nothing -> mkRdrUnqual occ + Just mod -> mkRdrQual (mkModuleName mod) occ + +-- | We only want to produce warnings for TH-splices if the user requests so. +-- See Note [Warnings for TH splices]. +getThSpliceOrigin :: TcM Origin +getThSpliceOrigin = do + warn <- goptM Opt_EnableThSpliceWarnings + if warn then return FromSource else return Generated + + +getThing :: TH.Name -> TcM TcTyThing +getThing th_name + = do { name <- lookupThName th_name + ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name) + ; tcLookupTh name } + -- 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 _ = panic "reify/ppr_ns" + +reify :: TH.Name -> TcM TH.Info +reify th_name + = do { traceTc "reify 1" (text (TH.showName th_name)) + ; thing <- getThing th_name + ; traceTc "reify 2" (ppr thing) + ; reifyThing thing } + +lookupThName :: TH.Name -> TcM Name +lookupThName th_name = do + mb_name <- lookupThName_maybe th_name + case mb_name of + Nothing -> failWithTc (notInScope th_name) + Just name -> return name + +lookupThName_maybe :: TH.Name -> TcM (Maybe Name) +lookupThName_maybe th_name + = do { names <- mapMaybeM lookupOccRn_maybe (thRdrNameGuesses th_name) + -- 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) } + +tcLookupTh :: Name -> TcM TcTyThing +-- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that +-- it gives a reify-related error message on failure, whereas in the normal +-- tcLookup, failure is a bug. +tcLookupTh name + = do { (gbl_env, lcl_env) <- getEnvs + ; case lookupNameEnv (tcl_env lcl_env) name of { + Just thing -> return thing; + Nothing -> + + case lookupNameEnv (tcg_type_env gbl_env) name of { + Just thing -> return (AGlobal thing); + Nothing -> + + -- EZY: I don't think this choice matters, no TH in signatures! + if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name + then -- It's defined in this module + failWithTc (notInEnv name) + + else + do { mb_thing <- tcLookupImported_maybe name + ; case mb_thing of + Succeeded thing -> return (AGlobal thing) + Failed msg -> failWithTc (TcRnInterfaceLookupError name msg) + }}}} + +notInScope :: TH.Name -> TcRnMessage +notInScope th_name = + TcRnCannotReifyOutOfScopeThing th_name + +notInEnv :: Name -> TcRnMessage +notInEnv name = TcRnCannotReifyThingNotInTypeEnv name + +------------------------------ +reifyRoles :: TH.Name -> TcM [TH.Role] +reifyRoles th_name + = do { thing <- getThing th_name + ; case thing of + AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc)) + _ -> failWithTc (TcRnNoRolesAssociatedWithThing thing) + } + where + reify_role Nominal = TH.NominalR + reify_role Representational = TH.RepresentationalR + reify_role Phantom = TH.PhantomR + +------------------------------ +reifyThing :: TcTyThing -> TcM TH.Info +-- The only reason this is monadic is for error reporting, +-- which in turn is mainly for the case when TH can't express +-- some random GHC extension + +reifyThing (AGlobal (AnId id)) + = 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) + } + +reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc +reifyThing (AGlobal (AConLike (RealDataCon dc))) + = mkDataConI dc + +reifyThing (AGlobal (AConLike (PatSynCon ps))) + = do { let name = reifyName ps + ; ty <- reifyPatSynType (patSynSigBndr ps) + ; return (TH.PatSynI name ty) } + +reifyThing (ATcId {tct_id = id}) + = do { ty1 <- 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 + ; ty2 <- reifyType ty1 + ; return (TH.TyVarI (reifyName tv) ty2) } + +reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing) + +------------------------------------------- +reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn +reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs + , cab_lhs = lhs + , cab_rhs = rhs }) + -- remove kind patterns (#8884) + = do { tvs' <- reifyTyVarsToMaybe tvs + ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs + ; lhs' <- reifyTypes lhs_types_only + ; annot_th_lhs <- zipWith3M annotThType (tyConArgsPolyKinded fam_tc) + lhs_types_only lhs' + ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs + ; rhs' <- reifyType rhs + ; return (TH.TySynEqn tvs' lhs_type rhs') } + +reifyTyCon :: TyCon -> TcM TH.Info +reifyTyCon tc + | Just cls <- tyConClass_maybe tc + = reifyClass cls + +{- Seems to be just a short cut for the next equation -- omit + | tc `hasKey` fUNTyConKey -- I'm not quite sure what is happening here + = return (TH.PrimTyConI (reifyName tc) 2 False) +-} + + | isPrimTyCon tc + = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc)) + (isUnliftedTypeKind (tyConResKind tc))) + + | isTypeFamilyTyCon tc + = do { let tvs = tyConTyVars tc + res_kind = tyConResKind tc + resVar = tyConFamilyResVar_maybe tc + + ; kind' <- reifyKind res_kind + ; let (resultSig, injectivity) = + case resVar of + Nothing -> (TH.KindSig kind', Nothing) + Just name -> + let thName = reifyName name + injAnnot = tyConInjectivityInfo tc + sig = TH.TyVarSig (TH.KindedTV thName () kind') + inj = case injAnnot of + NotInjective -> Nothing + Injective ms -> + Just (TH.InjectivityAnn thName injRHS) + where + injRHS = map (reifyName . tyVarName) + (filterByList ms tvs) + in (sig, inj) + ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; let tfHead = + TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity + ; if isOpenTypeFamilyTyCon tc + then do { fam_envs <- tcGetFamInstEnvs + ; instances <- reifyFamilyInstances tc + (familyInstances fam_envs tc) + ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) } + else do { eqns <- + case isClosedSynFamilyTyConWithAxiom_maybe tc of + Just ax -> mapM (reifyAxBranch tc) $ + fromBranches $ coAxiomBranches ax + Nothing -> return [] + ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns) + []) } } + + | isDataFamilyTyCon tc + = do { let res_kind = tyConResKind tc + + ; kind' <- fmap Just (reifyKind res_kind) + + ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; fam_envs <- tcGetFamInstEnvs + ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc) + ; return (TH.FamilyI + (TH.DataFamilyD (reifyName tc) tvs' kind') instances) } + + | Just (_, rhs) <- synTyConDefn_maybe tc -- Vanilla type synonym + = do { rhs' <- reifyType rhs + ; tvs' <- reifyTyVars (tyConVisibleTyVars tc) + ; return (TH.TyConI + (TH.TySynD (reifyName tc) tvs' rhs')) + } + + -- Special case for `type data` data constructors, which are reified as + -- `ATyCon`s rather than `ADataCon`s (#22818). + -- See Note [Type data declarations] in GHC.Rename.Module. + | Just dc <- isPromotedDataCon_maybe tc + , isTypeDataCon dc + = mkDataConI dc + + | otherwise + = do { cxt <- reifyCxt (tyConStupidTheta tc) + ; let tvs = tyConTyVars tc + dataCons = tyConDataCons tc + isGadt = isGadtSyntaxTyCon tc + ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons + ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc) + ; let name = reifyName tc + deriv = [] -- Don't know about deriving + decl | isTypeDataTyCon tc = + -- `type data` declarations have a special `Dec`, + -- separate from other `DataD`s. See + -- [Type data declarations] in GHC.Rename.Module. + TH.TypeDataD name r_tvs Nothing cons + | isNewTyCon tc = + TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv + | otherwise = + TH.DataD cxt name r_tvs Nothing cons deriv + ; return (TH.TyConI decl) } + +reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con +reifyDataCon isGadtDataCon tys dc + = do { let -- used for H98 data constructors + (ex_tvs, theta, arg_tys) + = dataConInstSig dc tys + -- used for GADTs data constructors + g_user_tvs' = dataConUserTyVarBinders dc + (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty') + = dataConFullSig dc + (srcUnpks, srcStricts) + = mapAndUnzip reifySourceBang (dataConSrcBangs dc) + dcdBangs = zipWith TH.Bang srcUnpks srcStricts + fields = dataConFieldLabels dc + name = reifyName dc + -- Universal tvs present in eq_spec need to be filtered out, as + -- they will not appear anywhere in the type. + eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec) + + ; (univ_subst, _) + -- See Note [Freshen reified GADT constructors' universal tyvars] + <- freshenTyVarBndrs $ + filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs + ; let (tvb_subst, g_user_tvs) = subst_tv_binders univ_subst g_user_tvs' + g_theta = substTys tvb_subst g_theta' + g_arg_tys = substTys tvb_subst (map scaledThing g_arg_tys') + g_res_ty = substTy tvb_subst g_res_ty' + + ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys) + + ; main_con <- + if | not (null fields) && not isGadtDataCon -> + return $ TH.RecC name (zip3 (map reifyFieldLabel fields) + dcdBangs r_arg_tys) + | not (null fields) -> do + { res_ty <- reifyType g_res_ty + ; return $ TH.RecGadtC [name] + (zip3 (map (reifyName . flSelector) fields) + dcdBangs r_arg_tys) res_ty } + -- We need to check not isGadtDataCon here because GADT + -- constructors can be declared infix. + -- See Note [Infix GADT constructors] in GHC.Tc.TyCl. + | dataConIsInfix dc && not isGadtDataCon -> + assert (r_arg_tys `lengthIs` 2) $ do + { let [r_a1, r_a2] = r_arg_tys + [s1, s2] = dcdBangs + ; 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 } + | otherwise -> + return $ TH.NormalC name (dcdBangs `zip` r_arg_tys) + + ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta) + | otherwise = assert (all isTyVar ex_tvs) + -- no covars for haskell syntax + (map mk_specified ex_tvs, theta) + ret_con | null ex_tvs' && null theta' = return main_con + | otherwise = do + { cxt <- reifyCxt theta' + ; ex_tvs'' <- reifyTyVarBndrs ex_tvs' + ; return (TH.ForallC ex_tvs'' cxt main_con) } + ; assert (r_arg_tys `equalLength` dcdBangs) + ret_con } + where + mk_specified tv = Bndr tv SpecifiedSpec + + subst_tv_binders subst tv_bndrs = + let tvs = binderVars tv_bndrs + flags = binderFlags tv_bndrs + (subst', tvs') = substTyVarBndrs subst tvs + tv_bndrs' = map (\(tv,fl) -> Bndr tv fl) (zip tvs' flags) + in (subst', tv_bndrs') + +mkDataConI :: DataCon -> TcM TH.Info +mkDataConI dc + = do { let name = dataConName dc + ; ty <- reifyType (idType (dataConWrapId dc)) + ; return (TH.DataConI (reifyName name) ty + (reifyName (dataConOrigTyCon dc))) + } + +{- +Note [Freshen reified GADT constructors' universal tyvars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose one were to reify this GADT: + + data a :~: b where + Refl :: forall a b. (a ~ b) => a :~: b + +We ought to be careful here about the uniques we give to the occurrences of `a` +and `b` in this definition. That is because in the original DataCon, all uses +of `a` and `b` have the same unique, since `a` and `b` are both universally +quantified type variables--that is, they are used in both the (:~:) tycon as +well as in the constructor type signature. But when we turn the DataCon +definition into the reified one, the `a` and `b` in the constructor type +signature becomes differently scoped than the `a` and `b` in `data a :~: b`. + +While it wouldn't technically be *wrong* per se to re-use the same uniques for +`a` and `b` across these two different scopes, it's somewhat annoying for end +users of Template Haskell, since they wouldn't be able to rely on the +assumption that all TH names have globally distinct uniques (#13885). For this +reason, we freshen the universally quantified tyvars that go into the reified +GADT constructor type signature to give them distinct uniques from their +counterparts in the tycon. +-} + +------------------------------ +reifyClass :: Class -> TcM TH.Info +reifyClass cls + = do { cxt <- reifyCxt theta + ; inst_envs <- tcGetInstEnvs + ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls) + ; assocTys <- concatMapM reifyAT ats + ; ops <- concatMapM reify_op op_stuff + ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls)) + ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops) + ; return (TH.ClassI dec insts) } + where + (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls + fds' = map reifyFunDep fds + reify_op (op, def_meth) + = do { let (_, _, ty) = tcSplitMethodTy (idType op) + -- Use tcSplitMethodTy to get rid of the extraneous class + -- variables and predicates at the beginning of op's type + -- (see #15551). + ; ty' <- reifyType ty + ; let nm' = reifyName op + ; case def_meth of + Just (_, GenericDM gdm_ty) -> + do { gdm_ty' <- reifyType gdm_ty + ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] } + _ -> return [TH.SigD nm' ty'] } + + reifyAT :: ClassATItem -> TcM [TH.Dec] + reifyAT (ATI tycon def) = do + tycon' <- reifyTyCon tycon + case tycon' of + TH.FamilyI dec _ -> do + let (tyName, tyArgs) = tfNames dec + (dec :) <$> maybe (return []) + (fmap (:[]) . reifyDefImpl tyName tyArgs . fst) + def + _ -> pprPanic "reifyAT" (text (show tycon')) + + reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec + reifyDefImpl n args ty = + TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args)) + <$> reifyType ty + + tfNames :: TH.Dec -> (TH.Name, [TH.Name]) + tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _)) + = (n, map bndrName args) + tfNames d = pprPanic "tfNames" (text (show d)) + + bndrName :: TH.TyVarBndr flag -> TH.Name + bndrName (TH.PlainTV n _) = n + bndrName (TH.KindedTV n _ _) = n + +------------------------------ +-- | Annotate (with TH.SigT) a type if the first parameter is True +-- and if the type contains a free variable. +-- This is used to annotate type patterns for poly-kinded tyvars in +-- reifying class and type instances. +-- See @Note [Reified instances and explicit kind signatures]@. +annotThType :: Bool -- True <=> annotate + -> TyCoRep.Type -> TH.Type -> TcM TH.Type + -- tiny optimization: if the type is annotated, don't annotate again. +annotThType _ _ th_ty@(TH.SigT {}) = return th_ty +annotThType True ty th_ty + | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty + = do { let ki = typeKind ty + ; th_ki <- reifyKind ki + ; return (TH.SigT th_ty th_ki) } +annotThType _ _ th_ty = return th_ty + +-- | For every argument type that a type constructor accepts, +-- report whether or not the argument is poly-kinded. This is used to +-- eventually feed into 'annotThType'. +-- See @Note [Reified instances and explicit kind signatures]@. +tyConArgsPolyKinded :: TyCon -> [Bool] +tyConArgsPolyKinded tc = + map (is_poly_ty . tyVarKind) tc_vis_tvs + -- See "Wrinkle: Oversaturated data family instances" in + -- @Note [Reified instances and explicit kind signatures]@ + ++ map (is_poly_ty . piTyBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle + ++ repeat True -- (2) in Wrinkle + where + is_poly_ty :: Type -> Bool + is_poly_ty ty = not $ + isEmptyVarSet $ + filterVarSet isTyVar $ + tyCoVarsOfType ty + + tc_vis_tvs :: [TyVar] + tc_vis_tvs = tyConVisibleTyVars tc + + tc_res_kind_vis_bndrs :: [PiTyBinder] + tc_res_kind_vis_bndrs = filter isVisiblePiTyBinder $ fst $ splitPiTys $ tyConResKind tc + +{- +Note [Reified instances and explicit kind signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Reified class instances and type family instances often include extra kind +information to disambiguate instances. Here is one such example that +illustrates this (#8953): + + type family Poly (a :: k) :: Type + type instance Poly (x :: Bool) = Int + type instance Poly (x :: Maybe k) = Double + +If you're not careful, reifying these instances might yield this: + + type instance Poly x = Int + type instance Poly x = Double + +To avoid this, we go through some care to annotate things with extra kind +information. Some functions which accomplish this feat include: + +* annotThType: This annotates a type with a kind signature if the type contains + a free variable. +* tyConArgsPolyKinded: This checks every argument that a type constructor can + accept and reports if the type of the argument is poly-kinded. This + information is ultimately fed into annotThType. + +----- +-- Wrinkle: Oversaturated data family instances +----- + +What constitutes an argument to a type constructor in the definition of +tyConArgsPolyKinded? For most type constructors, it's simply the visible +type variable binders (i.e., tyConVisibleTyVars). There is one corner case +we must keep in mind, however: data family instances can appear oversaturated +(#17296). For instance: + + data family Foo :: Type -> Type + data instance Foo x + + data family Bar :: k + data family Bar x + +For these sorts of data family instances, tyConVisibleTyVars isn't enough, +as they won't give you the kinds of the oversaturated arguments. We must +also consult: + +1. The kinds of the arguments in the result kind (i.e., the tyConResKind). + This will tell us, e.g., the kind of `x` in `Foo x` above. +2. If we go beyond the number of arguments in the result kind (like the + `x` in `Bar x`), then we conservatively assume that the argument's + kind is poly-kinded. + +----- +-- Wrinkle: data family instances with return kinds +----- + +Another squirrelly corner case is this: + + data family Foo (a :: k) + data instance Foo :: Bool -> Type + data instance Foo :: Char -> Type + +If you're not careful, reifying these instances might yield this: + + data instance Foo + data instance Foo + +We can fix this ambiguity by reifying the instances' explicit return kinds. We +should only do this if necessary (see +Note [When does a tycon application need an explicit kind signature?] in GHC.Core.Type), +but more importantly, we *only* do this if either of the following are true: + +1. The data family instance has no constructors. +2. The data family instance is declared with GADT syntax. + +If neither of these are true, then reifying the return kind would yield +something like this: + + data instance (Bar a :: Type) = MkBar a + +Which is not valid syntax. +-} + +------------------------------ +reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec] +reifyClassInstances cls insts + = mapM (reifyClassInstance (tyConArgsPolyKinded (classTyCon cls))) insts + +reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded + -- includes only *visible* tvs + -> ClsInst -> TcM TH.Dec +reifyClassInstance is_poly_tvs i + = do { cxt <- reifyCxt theta + ; let vis_types = filterOutInvisibleTypes cls_tc types + ; thtypes <- reifyTypes vis_types + ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes + ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes + ; return $ (TH.InstanceD over cxt head_ty []) } + where + (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun) + cls_tc = classTyCon cls + dfun = instanceDFunId i + over = case overlapMode (is_flag i) of + NoOverlap _ -> Nothing + Overlappable _ -> Just TH.Overlappable + Overlapping _ -> Just TH.Overlapping + Overlaps _ -> Just TH.Overlaps + Incoherent _ -> Just TH.Incoherent + +------------------------------ +reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec] +reifyFamilyInstances fam_tc fam_insts + = mapM (reifyFamilyInstance (tyConArgsPolyKinded fam_tc)) fam_insts + +reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded + -- includes only *visible* tvs + -> FamInst -> TcM TH.Dec +reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor + , fi_axiom = ax + , fi_fam = fam }) + | let fam_tc = coAxiomTyCon ax + branch = coAxiomSingleBranch ax + , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch + = case flavor of + SynFamilyInst -> + -- remove kind patterns (#8884) + do { th_tvs <- reifyTyVarsToMaybe tvs + ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs + ; th_lhs <- reifyTypes lhs_types_only + ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only + th_lhs + ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs + ; th_rhs <- reifyType rhs + ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) } + + DataFamilyInst rep_tc -> + do { let -- eta-expand lhs types, because sometimes data/newtype + -- instances are eta-reduced; See #9692 + -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom + (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch + fam' = reifyName fam + dataCons = tyConDataCons rep_tc + isGadt = isGadtSyntaxTyCon rep_tc + ; th_tvs <- reifyTyVarsToMaybe ee_tvs + ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons + ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs + ; th_tys <- reifyTypes types_only + ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys + ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys + ; mb_sig <- + -- See "Wrinkle: data family instances with return kinds" in + -- Note [Reified instances and explicit kind signatures] + if (null cons || isGadtSyntaxTyCon rep_tc) + && tyConAppNeedsKindSig False fam_tc (length ee_lhs) + then do { let full_kind = typeKind (mkTyConApp fam_tc ee_lhs) + ; th_full_kind <- reifyKind full_kind + ; pure $ Just th_full_kind } + else pure Nothing + ; return $ + if isNewTyCon rep_tc + then TH.NewtypeInstD [] th_tvs lhs_type mb_sig (head cons) [] + else TH.DataInstD [] th_tvs lhs_type mb_sig cons [] + } + +------------------------------ +reifyType :: TyCoRep.Type -> TcM TH.Type +-- Monadic only because of failure +reifyType ty | tcIsLiftedTypeKind ty = return TH.StarT + -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it + -- with Constraint (#14869). +reifyType ty@(ForAllTy (Bndr _ argf) _) + = reify_for_all argf ty +reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } +reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) +reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here +reifyType ty@(AppTy {}) = do + let (ty_head, ty_args) = splitAppTys ty + ty_head' <- reifyType ty_head + ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args) + pure $ mkThAppTs ty_head' ty_args' + where + -- Make sure to filter out any invisible arguments. For instance, if you + -- reify the following: + -- + -- newtype T (f :: forall a. a -> Type) = MkT (f Bool) + -- + -- Then you should receive back `f Bool`, not `f Type Bool`, since the + -- `Type` argument is invisible (#15792). + filter_out_invisible_args :: Type -> [Type] -> [Type] + filter_out_invisible_args ty_head ty_args = + filterByList (map isVisibleForAllTyFlag $ appTyForAllTyFlags ty_head ty_args) + ty_args +reifyType ty@(FunTy { ft_af = af, ft_mult = ManyTy, ft_arg = t1, ft_res = t2 }) + | isInvisibleFunArg af = reify_for_all Inferred ty -- Types like ((?x::Int) => Char -> Char) + | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] + ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } +reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 }) + | isInvisibleFunArg af = noTH LinearInvisibleArgument ty + | otherwise = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2] + ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) } +reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH +reifyType ty@(CoercionTy {})= noTH CoercionsInTypes ty + +reify_for_all :: TyCoRep.ForAllTyFlag -> TyCoRep.Type -> TcM TH.Type +-- Arg of reify_for_all is always ForAllTy or a predicate FunTy +reify_for_all argf ty + | isVisibleForAllTyFlag argf + = do let (req_bndrs, phi) = tcSplitForAllReqTVBinders ty + tvbndrs' <- reifyTyVarBndrs req_bndrs + phi' <- reifyType phi + pure $ TH.ForallVisT tvbndrs' phi' + | otherwise + = do let (inv_bndrs, phi) = tcSplitForAllInvisTVBinders ty + tvbndrs' <- reifyTyVarBndrs inv_bndrs + let (cxt, tau) = tcSplitPhiTy phi + cxt' <- reifyCxt cxt + tau' <- reifyType tau + pure $ TH.ForallT tvbndrs' cxt' tau' + +reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit +reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) +reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) +reifyTyLit (CharTyLit c) = return (TH.CharTyLit c) + +reifyTypes :: [Type] -> TcM [TH.Type] +reifyTypes = mapM reifyType + +reifyPatSynType + :: ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Scaled Type], Type) -> TcM TH.Type +-- reifies a pattern synonym's type and returns its *complete* type +-- signature; see Note [Pattern synonym type signatures and Template +-- Haskell] in GHC.ThToHs +reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy) + = do { univTyVars' <- reifyTyVarBndrs univTyVars + ; req' <- reifyCxt req + ; exTyVars' <- reifyTyVarBndrs exTyVars + ; prov' <- reifyCxt prov + ; tau' <- reifyType (mkScaledFunTys argTys resTy) + ; return $ TH.ForallT univTyVars' req' + $ TH.ForallT exTyVars' prov' tau' } + +reifyKind :: Kind -> TcM TH.Kind +reifyKind = reifyType + +reifyCxt :: [PredType] -> TcM [TH.Pred] +reifyCxt = mapM reifyType + +reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep +reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) + +class ReifyFlag flag flag' | flag -> flag' where + reifyFlag :: flag -> flag' + +instance ReifyFlag () () where + reifyFlag () = () + +instance ReifyFlag Specificity TH.Specificity where + reifyFlag SpecifiedSpec = TH.SpecifiedSpec + reifyFlag InferredSpec = TH.InferredSpec + +reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr ()] +reifyTyVars = reifyTyVarBndrs . map mk_bndr + where + mk_bndr tv = Bndr tv () + +reifyTyVarBndrs :: ReifyFlag flag flag' + => [VarBndr TyVar flag] -> TcM [TH.TyVarBndr flag'] +reifyTyVarBndrs = mapM reify_tvbndr + where + -- even if the kind is *, we need to include a kind annotation, + -- in case a poly-kind would be inferred without the annotation. + -- See #8953 or test th/T8953 + reify_tvbndr (Bndr tv fl) = TH.KindedTV (reifyName tv) + (reifyFlag fl) + <$> reifyKind (tyVarKind tv) + +reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr ()]) +reifyTyVarsToMaybe [] = pure Nothing +reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys + +reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type +reify_tc_app tc tys + = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys) + ; maybe_sig_t (mkThAppTs r_tc tys') } + where + arity = tyConArity tc + + r_tc | isUnboxedSumTyCon tc = TH.UnboxedSumT (arity `div` 2) + | isUnboxedTupleTyCon tc = TH.UnboxedTupleT (arity `div` 2) + | isPromotedTupleTyCon tc = TH.PromotedTupleT (arity `div` 2) + -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon + | isTupleTyCon tc = if isPromotedDataCon tc + then TH.PromotedTupleT arity + else TH.TupleT arity + | tc `hasKey` constraintKindTyConKey + = TH.ConstraintT + | tc `hasKey` unrestrictedFunTyConKey = TH.ArrowT + | tc `hasKey` listTyConKey = TH.ListT + | tc `hasKey` nilDataConKey = TH.PromotedNilT + | tc `hasKey` consDataConKey = TH.PromotedConsT + | tc `hasKey` heqTyConKey = TH.EqualityT + | tc `hasKey` eqPrimTyConKey = TH.EqualityT + | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon) + | isDataKindsPromotedDataCon tc = TH.PromotedT (reifyName tc) + | otherwise = TH.ConT (reifyName tc) + + -- See Note [When does a tycon application need an explicit kind + -- signature?] in GHC.Core.TyCo.Rep + maybe_sig_t th_type + | tyConAppNeedsKindSig + False -- We don't reify types using visible kind applications, so + -- don't count specified binders as contributing towards + -- injective positions in the kind of the tycon. + tc (length tys) + = do { let full_kind = typeKind (mkTyConApp tc tys) + ; th_full_kind <- reifyKind full_kind + ; return (TH.SigT th_type th_full_kind) } + | otherwise + = return th_type + +------------------------------ +reifyName :: NamedThing n => n -> TH.Name +reifyName thing + | isExternalName name + = mk_varg pkg_str mod_str occ_str + | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name)) + -- Many of the things we reify have local bindings, and + -- NameL's aren't supposed to appear in binding positions, so + -- we use NameU. When/if we start to reify nested things, that + -- have free variables, we may need to generate NameL's for them. + where + name = getName thing + mod = assert (isExternalName name) $ nameModule name + pkg_str = unitString (moduleUnit mod) + mod_str = moduleNameString (moduleName mod) + occ_str = occNameString occ + occ = nameOccName name + mk_varg | OccName.isDataOcc occ = TH.mkNameG_d + | OccName.isVarOcc occ = TH.mkNameG_v + | OccName.isTcOcc occ = TH.mkNameG_tc + | 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) + +------------------------------ +reifyFixity :: Name -> TcM (Maybe TH.Fixity) +reifyFixity name + = 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_dir Hs.InfixR = TH.InfixR + conv_dir Hs.InfixL = TH.InfixL + conv_dir Hs.InfixN = TH.InfixN + +reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness +reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness +reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack +reifyUnpackedness SrcUnpack = TH.SourceUnpack + +reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness +reifyStrictness NoSrcStrict = TH.NoSourceStrictness +reifyStrictness SrcStrict = TH.SourceStrict +reifyStrictness SrcLazy = TH.SourceLazy + +reifySourceBang :: DataCon.HsSrcBang + -> (TH.SourceUnpackedness, TH.SourceStrictness) +reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s) + +reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness +reifyDecidedStrictness HsLazy = TH.DecidedLazy +reifyDecidedStrictness (HsStrict _) = TH.DecidedStrict +reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack + +reifyTypeOfThing :: TH.Name -> TcM TH.Type +reifyTypeOfThing th_name = do + thing <- getThing th_name + case thing of + AGlobal (AnId id) -> reifyType (idType id) + AGlobal (ATyCon tc) -> reifyKind (tyConKind tc) + AGlobal (AConLike (RealDataCon dc)) -> + reifyType (idType (dataConWrapId dc)) + AGlobal (AConLike (PatSynCon ps)) -> + reifyPatSynType (patSynSigBndr ps) + ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType + ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType + -- Impossible cases, supposedly: + AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom" + ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon" + APromotionErr _ -> panic "reifyTypeOfThing: APromotionErr" + +------------------------------ +lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget +lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm) +lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn)) + = return $ ModuleTarget $ + mkModule (stringToUnit $ TH.pkgString pn) (mkModuleName $ TH.modString mn) + +reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a] +reifyAnnotations th_name + = do { name <- lookupThAnnLookup th_name + ; topEnv <- getTopEnv + ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing + ; tcg <- getGblEnv + ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name + ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name + ; return (selectedEpsHptAnns ++ selectedTcgAnns) } + +------------------------------ +modToTHMod :: Module -> TH.Module +modToTHMod m = TH.Module (TH.PkgName $ unitString $ moduleUnit m) + (TH.ModName $ moduleNameString $ moduleName m) + +reifyModule :: TH.Module -> TcM TH.ModuleInfo +reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do + this_mod <- getModule + let reifMod = mkModule (stringToUnit pkgString) (mkModuleName mString) + if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod + where + reifyThisModule = do + usages <- fmap (map modToTHMod . moduleEnvKeys . 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] ] + 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) 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,13 +10,13 @@ import GHC.Types.Annotations ( Annotation, CoreAnnTarget ) import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc ) -import GHC.Hs ( HsSplice, HsQuote, HsExpr, LHsExpr, LHsType, - LPat, LHsDecl, ThModFinalizers ) +import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers ) import qualified Language.Haskell.TH as TH -tcSpliceExpr :: HsSplice GhcRn - -> ExpRhoType - -> TcM (HsExpr GhcTc) +tcTypedSplice :: Name + -> LHsExpr GhcRn + -> ExpRhoType + -> TcM (HsExpr GhcTc) tcTypedBracket :: HsExpr GhcRn -> LHsExpr GhcRn 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 @@ -28,14 +28,17 @@ import GHC.Builtin.Types.Prim import GHC.Builtin.Names +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.Var.Env ( VarEnv ) import GHC.Types.Id +import GHC.Types.Id.Make ( nospecId ) import GHC.Types.Var import GHC.Core.Predicate +import GHC.Core.Coercion import GHC.Core.InstEnv import GHC.Core.Type import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams ) @@ -43,15 +46,14 @@ import GHC.Core.TyCon import GHC.Core.Class -import GHC.Core ( Expr(Var, App, Cast, Let), Bind (NonRec) ) -import GHC.Types.Basic +import GHC.Core ( Expr(Var, App, Cast, Type) ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 ) import GHC.Data.FastString -import Data.Maybe +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) {- ******************************************************************* * * @@ -151,20 +153,17 @@ -- 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 + | 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 where cls_name = className clas @@ -190,7 +189,7 @@ -- Nothing matches ([], NoUnifiers, _) - -> do { traceTc "matchClass not matching" (ppr pred) + -> do { traceTc "matchClass not matching" (ppr pred $$ ppr (ie_local instEnvs)) ; return NoInstance } -- A single match (& no safe haskell failure) @@ -424,7 +423,7 @@ -- then tcRep is SNat , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] -- SNat n ~ Integer - , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep)) + , let ev_tm = mkEvCast et (mkSymCo (mkTransCo co_dict co_rep)) = return $ OneInst { cir_new_theta = [] , cir_mk_ev = \_ -> ev_tm , cir_what = BuiltinInstance } @@ -451,25 +450,29 @@ -- and in that case let -- co :: C t1 ..tn ~R# inst_meth_ty , Just (inst_meth_ty, co) <- tcInstNewTyCon_maybe dict_tc dict_args - = do { sv <- mkSysLocalM (fsLit "withDict_s") Many mty - ; k <- mkSysLocalM (fsLit "withDict_k") Many (mkInvisFunTyMany cls openAlphaTy) - - ; let evWithDict_type = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] $ - mkVisFunTysMany [mty, mkInvisFunTyMany cls openAlphaTy] openAlphaTy - - ; wd_id <- mkSysLocalM (fsLit "withDict_wd") Many evWithDict_type - ; let wd_id' = wd_id `setInlinePragma` neverInlinePragma - -- Inlining withDict can cause the specialiser to incorrectly common up - -- distinct evidence terms. See (WD6) in Note [withDict]. + = do { sv <- mkSysLocalM (fsLit "withDict_s") ManyTy mty + ; k <- mkSysLocalM (fsLit "withDict_k") ManyTy (mkInvisFunTy cls openAlphaTy) -- Given co2 : mty ~N# inst_meth_ty, construct the method of -- the WithDict dictionary: - -- \@(r : RuntimeRep) @(a :: TYPE r) (sv : mty) (k :: cls => a) -> k (sv |> (sub co; sym co2)) + -- + -- \@(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 = - let wd_rhs = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $ - Var k `App` Cast (Var sv) (mkTcTransCo (mkTcSubCo co2) (mkTcSymCo co)) - in Let (NonRec wd_id' wd_rhs) (Var wd_id') - -- Why a Let? See (WD6) in Note [withDict] + mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $ + Var nospecId + `App` + (Type $ mkInvisFunTy cls openAlphaTy) + `App` + Var k + `App` + (Var sv `Cast` mkTransCo (mkSubCo co2) (mkSymCo co)) ; tc <- tcLookupTyCon withDictClassName ; let Just withdict_data_con @@ -531,7 +534,7 @@ 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 (sv |> (sub co2 ; sym 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 @@ -564,50 +567,69 @@ (WD3) As an alternative to `withDict`, one could define functions like `withT` above in terms of `unsafeCoerce`. This is more error-prone, however. -(WD4) In order to define things like `reifySymbol` below: +(WD4) In order to define things like `withKnownNat` below: - reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => r) -> r + withKnownNat :: SNat n -> (KnownNat n => r) -> r `withDict` needs to be instantiated with `Any`, like so: - reifySymbol n k = withDict @(KnownSymbol Any) @String @r n (k @Any) + withKnownNat = withDict @(KnownNat Any) @(SNat Any) @r - The use of `Any` is explained in Note [NOINLINE someNatVal] in + The use of `Any` is explained in Note [NOINLINE withSomeSNat] in base:GHC.TypeNats. (WD5) In earlier implementations, `withDict` was implemented as an identifier with special handling during either constant-folding or desugaring. - The current approach is more robust, previously the type of `withDict` + The current approach is more robust: previously, the type of `withDict` did not have a type-class constraint and was overly polymorphic. See #19915. -(WD6) In fact we desugar `withDict @(C t_1 ... t_n) @mty @{rr} @r` to +(WD6) In fact, we desugar `withDict @cls @mty @{rr} @r` to - let wd = \sv k -> k (sv |> co) - {-# NOINLINE wd #-} - in wd + \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) -> + nospec @(cls => a) k (sv |> (sub co2 ; sym co))) - The local `let` and NOINLINE pragma ensure that the type-class specialiser - doesn't wrongly 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. + 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 + withDict A k withDict B k - where k1, k2 :: C T -> blah. If we inline those withDict calls we'll get + + where k1, k2 :: C T -> blah. If we desugared withDict naively, we'd get + k (A |> co1) k (B |> co2) - and the Specialiser will assume that those arguments (of type `C T`) are - the same, will specialise `k` for that type, and will call the same, + + and the Specialiser would assume that those arguments (of type `C T`) are + the same. It would then specialise `k` for that type, and then call the same, specialised function from both call sites. #21575 is a concrete case in point. - Solution: never inline `withDict`. Note that it is not sufficient to delay - inlining until after the specialiser (that is, until Phase 2), because if - we inline withDict in module A but import it in module B, the specialiser - will try to common up the two distinct evidence terms. - See test case T21575b. + To avoid this, we need to stop the typeclass specialiser from seeing this + structure, by using nospec. This function is inlined only in CorePrep; crucially + this means that it still appears in interface files, so that the desugaring of + withDict remains opaque to the typeclass specialiser across modules. + This means the specialiser will always see instead: - This solution is unsatisfactory, as it imposes a performance overhead - on uses of withDict. + nospec @(cls => a) k (A |> co1) + nospec @(cls => a) k (B |> co2) + Why does this work? Recall that nospec is not an overloaded function; + it has the type + + nospec :: forall a. a -> a + + This means that there is nothing for the specialiser to do with function calls + such as + + nospec @(cls => a) k (A |> co) + + as the specialiser only looks at calls of the form `f dict` for an + overloaded function `f` (e.g. with a type such as `f :: Eq a => ...`). + + See test-case T21575b. + -} {- ******************************************************************** @@ -620,18 +642,29 @@ -- and it was applied to the correct argument. matchTypeable :: Class -> [Type] -> TcM ClsInstResult matchTypeable clas [k,t] -- clas = Typeable - -- For the first two cases, See Note [No Typeable for polytypes or qualified types] - | isForAllTy k = return NoInstance -- Polytype - | isJust (tcSplitPredFunTy_maybe t) = return NoInstance -- Qualified type + -- Forall types: see Note [No Typeable for polytypes or qualified types] + | isForAllTy k = return NoInstance + -- Functions; but only with a visible argment + | Just (af,mult,arg,ret) <- splitFunTy_maybe t + = if isVisibleFunArg af + then doFunTy clas t mult arg ret + else return NoInstance + -- 'else' case: qualified types like (Num a => blah) are not typeable + -- see Note [No Typeable for polytypes or qualified types] + -- Now cases that do work - | k `eqType` naturalTy = doTyLit knownNatClassName t - | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t - | k `eqType` charTy = doTyLit knownCharClassName t - | tcIsConstraintKind t = doTyConApp clas t constraintKindTyCon [] - | Just (mult,arg,ret) <- splitFunTy_maybe t = doFunTy clas t mult arg ret + | k `eqType` naturalTy = doTyLit knownNatClassName t + | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t + | k `eqType` charTy = doTyLit knownCharClassName t + + -- TyCon applied to its kind args + -- No special treatment of Type and Constraint; they get distinct TypeReps + -- see wrinkle (W4) of Note [Type and Constraint are not apart] + -- in GHC.Builtin.Types.Prim. | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks + | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt matchTypeable _ _ = return NoInstance @@ -655,10 +688,9 @@ doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult doTyConApp clas ty tc kind_args | tyConIsTypeable tc - = do - 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_what = BuiltinTypeableInstance tc } | otherwise = return NoInstance where @@ -684,7 +716,7 @@ -- (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) -- Typeable f doTyApp clas ty f tk - | isForAllTy (tcTypeKind f) + | 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] @@ -697,7 +729,7 @@ -- Emit a `Typeable` constraint for the given type. mk_typeable_pred :: Class -> Type -> PredType -mk_typeable_pred clas ty = mkClassPred clas [ tcTypeKind ty, ty ] +mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ] -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal -- we generate a sub-goal for the appropriate class. @@ -713,15 +745,32 @@ {- Note [Typeable (T a b c)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + For type applications we always decompose using binary application, -via doTyApp, until we get to a *kind* instantiation. Example - Proxy :: forall k. k -> * +via doTyApp (building a TrApp), until we get to a *kind* instantiation +(building a TrTyCon). We detect a pure kind instantiation using +`onlyNamedBndrsApplied`. -To solve Typeable (Proxy (* -> *) Maybe) we - - First decompose with doTyApp, - to get (Typeable (Proxy (* -> *))) and Typeable Maybe - - Then solve (Typeable (Proxy (* -> *))) with doTyConApp +Example: Proxy :: forall k. k -> * + To solve Typeable (Proxy @(* -> *) Maybe) we + + - First decompose with doTyApp (onlyNamedBndrsApplied is False) + to get (Typeable (Proxy @(* -> *))) and Typeable Maybe. + This step returns a TrApp. + + - Then solve (Typeable (Proxy @(* -> *))) with doTyConApp + (onlyNamedBndrsApplied is True). + This step returns a TrTyCon + + So the TypeRep we build is + TrApp (TrTyCon ("Proxy" @(*->*))) (TrTyCon "Maybe") + +Notice also that TYPE and CONSTRAINT are distinct so, in effect, we +allow (Typeable TYPE) and (Typeable CONSTRAINT), giving disinct TypeReps. +This is very important: we may want to get a TypeRep for a kind like + Type -> Constraint + If we attempt to short-cut by solving it all at once, via doTyConApp @@ -894,7 +943,7 @@ -- 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 x r_tc + , Just fl <- lookupTyConFieldLabel (FieldLabelString x) r_tc -- the field selector should be in scope , Just gre <- lookupGRE_FieldLabel rdr_env fl @@ -913,8 +962,8 @@ -- it to a HasField dictionary. mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co where - co = mkTcSubCo (evTermCoercion (EvExpr ev1)) - `mkTcTransCo` mkTcSymCo co2 + co = mkSubCo (evTermCoercion (EvExpr ev1)) + `mkTransCo` mkSymCo co2 mk_ev [] = panic "matchHasField.mk_ev" Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas) 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 @@ -364,7 +364,7 @@ -- We could, but doing so means one of two things: -- -- 1. When looping over the cartesian product we convert - -- a set into a non-deterministicly ordered list. Which + -- 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 @@ -519,16 +519,16 @@ = Nothing -- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes, --- potentially looking through newtype /instances/. +-- potentially looking through newtype /instances/ and type synonyms. -- -- It is only used by the type inference engine (specifically, when -- solving representational equality), and hence it is careful to unwrap -- only if the relevant data constructor is in scope. That's why -- it gets a GlobalRdrEnv argument. -- --- It is careful not to unwrap data/newtype instances if it can't --- continue unwrapping. Such care is necessary for proper error --- messages. +-- It is careful not to unwrap data/newtype instances nor synonyms +-- if it can't continue unwrapping. Such care is necessary for proper +-- error messages. -- -- It does not look through type families. -- It does not normalise arguments to a tycon. @@ -558,8 +558,7 @@ -- which would lead to terrible error messages unwrap_newtype_instance rec_nts tc tys | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys - = mapStepResult (\(gres, co1) -> (gres, co `mkTransCo` co1)) $ - unwrap_newtype rec_nts tc' tys' + = fmap (mkTransCo co) <$> unwrap_newtype rec_nts tc' tys' | otherwise = NS_Done unwrap_newtype rec_nts tc tys @@ -567,8 +566,7 @@ , Just gre <- lookupGRE_Name rdr_env (dataConName con) -- This is where we check that the -- data constructor is in scope - = mapStepResult (\co -> (unitBag gre, co)) $ - unwrapNewTypeStepper rec_nts tc tys + = (,) (unitBag gre) <$> unwrapNewTypeStepper rec_nts tc tys | otherwise = NS_Done 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 @@ -29,14 +29,18 @@ import GHC.Core.Class import GHC.Core.Predicate import GHC.Core.Type -import GHC.Tc.Utils.TcType( transSuperClasses ) +import GHC.Core.RoughMap( RoughMatchTc(..) ) import GHC.Core.Coercion.Axiom( TypeEqn ) import GHC.Core.Unify import GHC.Core.InstEnv -import GHC.Types.Var.Set -import GHC.Types.Var.Env import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Compare( eqTypes, eqType ) import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen ) + +import GHC.Tc.Utils.TcType( transSuperClasses ) + +import GHC.Types.Var.Set +import GHC.Types.Var.Env import GHC.Types.SrcLoc import GHC.Utils.Outputable @@ -57,7 +61,6 @@ * * ************************************************************************ - Each functional dependency with one variable in the RHS is responsible for generating a single equality. For instance: class C a b | a -> b @@ -83,31 +86,57 @@ INVARIANT: Corresponding types aren't already equal That is, there exists at least one non-identity equality in FDEqs. +Note [Improving against instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Assume: - class C a b c | a -> b c - instance C Int x x -And: [Wanted] C Int Bool alpha -We will /match/ the LHS of fundep equations, producing a matching substitution -and create equations for the RHS sides. In our last example we'd have generated: - ({x}, [fd1,fd2]) -where - fd1 = FDEq 1 Bool x - fd2 = FDEq 2 alpha x -To ``execute'' the equation, make fresh type variable for each tyvar in the set, -instantiate the two types with these fresh variables, and then unify or generate -a new constraint. In the above example we would generate a new unification -variable 'beta' for x and produce the following constraints: - [Wanted] (Bool ~ beta) - [Wanted] (alpha ~ beta) + class C a b | a -> b + instance C Int Bool + [W] C Int ty -Notice the subtle difference between the above class declaration and: - class C a b c | a -> b, a -> c -where we would generate: - ({x},[fd1]),({x},[fd2]) -This means that the template variable would be instantiated to different -unification variables when producing the FD constraints. +Then `improveFromInstEnv` should return a FDEqn with + FDEqn { fd_qtvs = [], fd_eqs = [Pair Bool ty] } -Finally, the position parameters will help us rewrite the wanted constraint ``on the spot'' +describing an equality (Int ~ 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. + +Wrinkles: + +(1) meta_tvs: sometimes the instance mentions variables in the RHS that + are not bound in the LHS. For example + + class C a b | a -> b + instance C Int (Maybe x) + [W] C Int ty + + Note that although the `Int` parts match, that does not fix what `x` is. + So we just make up a fresh unification variable (a meta_tv), to give the + "shape" of the RHS. So we emit the FDEqun + 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. + +(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). + Consider + class D a b c | a -> b c + instance D Int x (Maybe x) + [W] D Int Bool ty + + Then we'll generate + FDEqn { fd_qtvs = [x0], fd_eqs = [ x0 ~ Bool, Maybe x0 ~ ty] } + which generates one fresh unification variable x0 + + But if the fundeps had been (a->b, a->c) we'd generate two FDEqns + FDEqn { fd_qtvs = [x1], fd_eqs = [ x1 ~ Bool ] } + FDEqn { fd_qtvs = [x2], fd_eqs = [ Maybe x2 ~ ty ] } + with two FDEqns, generating two separate unification variables. + +(3) improveFromInstEnv doesn't return any equations that already hold. + Reason: then we know if any actual improvement has happened, in + which case we need to iterate the solver -} data FunDepEqn loc @@ -116,11 +145,24 @@ -- Non-empty only for FunDepEqns arising from instance decls , fd_eqs :: [TypeEqn] -- Make these pairs of types equal + -- Invariant: In each (Pair ty1 ty2), the fd_qtvs may be + -- 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 +instance Outputable (FunDepEqn a) where + ppr = pprEquation + +pprEquation :: FunDepEqn a -> SDoc +pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) + = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs), + nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2 + | Pair t1 t2 <- pairs])] + {- Given a bunch of predicates that must hold, such as @@ -195,20 +237,12 @@ -- Improve a class constraint from instance declarations -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -instance Outputable (FunDepEqn a) where - ppr = pprEquation - -pprEquation :: FunDepEqn a -> SDoc -pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs }) - = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs), - nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2 - | Pair t1 t2 <- pairs])] - improveFromInstEnv :: InstEnvs -> (PredType -> SrcSpan -> 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 @@ -232,37 +266,16 @@ 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 -> [Type] -> [RoughMatchTc] -- Arguments of this (C tys) predicate -> [([TyCoVar], [TypeEqn])] -- Empty or singleton +-- See Note [Improving against instances] improveClsFD clas_tvs fd (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst }) tys_actual rough_tcs_actual --- Compare instance {a,b} C sx sp sy sq --- with wanted [W] C tx tp ty tq --- for fundep (x,y -> p,q) from class (C x p y q) --- If (sx,sy) unifies with (tx,ty), take the subst S - --- 'qtvs' are the quantified type variables, the ones which can be instantiated --- to make the types match. For example, given --- class C a b | a->b where ... --- instance C (Maybe x) (Tree x) where .. --- --- and a wanted constraint of form (C (Maybe t1) t2), --- then we will call checkClsFD with --- --- is_qtvs = {x}, is_tys = [Maybe x, Tree x] --- tys_actual = [Maybe t1, t2] --- --- We can instantiate x to t1, and then we want to force --- (Tree x) [t1/x] ~ t2 - | instanceCantMatch rough_tcs_inst rough_tcs_actual = [] -- Filter out ones that can't possibly match, @@ -271,12 +284,11 @@ equalLength tys_inst clas_tvs) (ppr tys_inst <+> ppr tys_actual) $ - case tcMatchTyKis ltys1 ltys2 of + case tcMatchTyKisX init_subst ltys1 ltys2 of Nothing -> [] Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2) -- Don't include any equations that already hold. - -- Reason: then we know if any actual improvement has happened, - -- in which case we need to iterate the solver + -- See Note [Improving against instances] wrinkle (3) -- In making this check we must taking account of the fact that any -- qtvs that aren't already instantiated can be instantiated to anything -- at all @@ -307,7 +319,7 @@ -- executed. What we're doing instead is recording the partial -- work of the ls1/ls2 unification leaving a smaller unification problem where - rtys1' = map (substTyUnchecked subst) rtys1 + rtys1' = map (substTy subst) rtys1 fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2 -- Don't discard anything! @@ -315,8 +327,10 @@ -- eqType again, since we know for sure that /at least one/ -- equation in there is useful) - meta_tvs = [ setVarType tv (substTyUnchecked subst (varType tv)) - | tv <- qtvs, tv `notElemTCvSubst` subst ] + meta_tvs = [ setVarType tv (substTy subst (varType tv)) + | tv <- qtvs + , tv `notElemSubst` subst + , tv `elemVarSet` rtys1_tvs ] -- meta_tvs are the quantified type variables -- that have not been substituted out -- @@ -331,11 +345,14 @@ -- type variables' kinds -- (b) we must apply 'subst' to the kinds, in case we have -- matched out a kind variable, but not a type variable - -- whose kind mentions that kind variable! - -- #6015, #6068 + -- whose kind mentions that kind variable! #6015, #6068 + -- (c) no need to include tyvars not in rtys1 where + init_subst = mkEmptySubst $ mkInScopeSet $ + mkVarSet qtvs `unionVarSet` tyCoVarsOfTypes ltys2 (ltys1, rtys1) = instFD fd clas_tvs tys_inst (ltys2, rtys2) = instFD fd clas_tvs tys_actual + rtys1_tvs = tyCoVarsOfTypes rtys1 {- %************************************************************************ @@ -393,7 +410,7 @@ where (ls,rs) = instFD fd tyvars inst_taus ls_tvs = tyCoVarsOfTypes ls - rs_tvs = splitVisVarsOfTypes rs + rs_tvs = visVarsOfTypes rs undetermined_tvs | be_liberal = liberal_undet_tvs | otherwise = conserv_undet_tvs @@ -621,7 +638,7 @@ ClsInsts in the environment. The bogus aspect is discussed in #10675. Currently it if the two -types are *contradicatory*, using (isNothing . tcUnifyTys). But all +types are *contradictory*, using (isNothing . tcUnifyTys). But all the papers say we should check if the two types are *equal* thus not (substTys subst rtys1 `eqTypes` substTys subst rtys2) For now I'm leaving the bogus form because that's the way it has 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(..), neverInlinePragma ) +import GHC.Types.Basic ( Boxity(..), TypeOrConstraint(..), neverInlinePragma ) import GHC.Types.SourceText ( SourceText(..) ) import GHC.Iface.Env( newGlobalBinder ) import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) @@ -106,7 +106,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 - injecting the bindings for the GHC.Prim representions when compiling + injecting the bindings for the GHC.Prim representations when compiling GHC.Types. * TyCon.tyConRepModOcc is responsible for determining where to find @@ -190,7 +190,7 @@ mkModIdBindings = do { mod <- getModule ; loc <- getSrcSpanM - ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc + ; mod_nm <- newGlobalBinder mod (mkVarOccFS (fsLit "$trModule")) loc ; trModuleTyCon <- tcLookupTyCon trModuleTyConName ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon []) ; mod_bind <- mkVarBind mod_id <$> mkModIdRHS mod @@ -330,9 +330,11 @@ -- Build TypeRepTodos for built-in KindReps ; todo1 <- todoForExportedKindReps builtInKindReps + -- Build TypeRepTodos for types in GHC.Prim ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id ghcPrimTypeableTyCons + ; tcg_env <- getGblEnv ; let mod_id = case tcg_tr_module tcg_env of -- Should be set by now Just mod_id -> mod_id @@ -419,7 +421,7 @@ -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) mkTyConRepBinds stuff todo (TypeableTyCon {..}) = do -- Make a KindRep - let (bndrs, kind) = splitForAllTyCoVarBinders (tyConKind tycon) + let (bndrs, kind) = splitForAllForAllTyBinders (tyConKind tycon) liftTc $ traceTc "mkTyConKindRepBinds" (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind) let ctx = mkDeBruijnContext (map binderVar bndrs) @@ -433,9 +435,8 @@ -- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type -- families and polytypes. tyConIsTypeable :: TyCon -> Bool -tyConIsTypeable tc = - isJust (tyConRepName_maybe tc) - && kindIsTypeable (dropForAlls $ tyConKind tc) +tyConIsTypeable tc = isJust (tyConRepName_maybe tc) + && kindIsTypeable (dropForAlls $ tyConKind tc) -- | Is a particular 'Kind' representable by @Typeable@? Here we look for -- polytypes and types containing casts (which may be, for instance, a type @@ -477,12 +478,14 @@ liftTc :: TcRn a -> KindRepM a liftTc = KindRepM . lift --- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they +-- | We generate `KindRep`s for a few common kinds, so that they -- can be reused across modules. +-- These definitions are generated in `ghc-prim:GHC.Types`. builtInKindReps :: [(Kind, Name)] builtInKindReps = - [ (star, starKindRepName) - , (mkVisFunTyMany star star, starArrStarKindRepName) + [ (star, starKindRepName) + , (constraintKind, constraintKindRepName) + , (mkVisFunTyMany star star, starArrStarKindRepName) , (mkVisFunTysMany [star, star] star, starArrStarArrStarKindRepName) ] where @@ -494,6 +497,7 @@ add_kind_rep acc (k,n) = do id <- tcLookupId n return $! extendTypeMap acc k (id, Nothing) + -- The TypeMap looks through type synonyms -- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's. mkExportedKindReps :: TypeableStuff @@ -509,6 +513,7 @@ -- since the latter would find the built-in 'KindRep's in the -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv'). rhs <- mkKindRepRhs stuff empty_scope kind + liftTc (traceTc "mkExport" (ppr kind $$ ppr rep_bndr $$ ppr rhs)) addKindRepBind empty_scope kind rep_bndr rhs addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM () @@ -541,10 +546,8 @@ go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv) go' k env - -- Look through type synonyms - | Just k' <- tcView k = go' k' env - -- We've already generated the needed KindRep + -- This lookup looks through synonyms | Just (id, _) <- lookupTypeMapWithScope env in_scope k = return (nlHsVar id, env) @@ -553,7 +556,7 @@ = do -- Place a NOINLINE pragma on KindReps since they tend to be quite -- large and bloat interface files. rep_bndr <- (`setInlinePragma` neverInlinePragma) - <$> newSysLocalId (fsLit "$krep") Many (mkTyConTy kindRepTyCon) + <$> newSysLocalId (fsLit "$krep") ManyTy (mkTyConTy kindRepTyCon) -- do we need to tie a knot here? flip runStateT env $ unKindRepM $ do @@ -573,24 +576,27 @@ -- We handle (TYPE LiftedRep) etc separately to make it -- clear to consumers (e.g. serializers) that there is -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep) - | not (tcIsConstraintKind k) + | Just (TypeLike, rep) <- sORTKind_maybe k -- Typeable respects the Constraint/Type distinction -- so do not follow the special case here - , Just arg <- kindRep_maybe k - = case splitTyConApp_maybe arg of - Just (tc, []) + = -- Here k = TYPE + case splitTyConApp_maybe rep of + Just (tc, []) -- TYPE IntRep, TYPE FloatRep etc | Just dc <- isPromotedDataCon_maybe tc -> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc - Just (rep, [levArg]) - | Just dcRep <- isPromotedDataCon_maybe rep - , Just (lev, []) <- splitTyConApp_maybe levArg - , Just dcLev <- isPromotedDataCon_maybe lev + Just (rep_tc, [levArg]) -- TYPE (BoxedRep lev) + | Just dcRep <- isPromotedDataCon_maybe rep_tc + , Just (lev_tc, []) <- splitTyConApp_maybe levArg + , Just dcLev <- isPromotedDataCon_maybe lev_tc -> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` (nlHsDataCon dcRep `nlHsApp` nlHsDataCon dcLev) _ -> new_kind_rep k | otherwise = new_kind_rep k + new_kind_rep ki -- Expand synonyms + | Just ki' <- coreView ki + = new_kind_rep ki' new_kind_rep (TyVarTy v) | Just idx <- lookupCME in_scope v @@ -662,7 +668,7 @@ where n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon) tycon_str = add_tick (occNameString (getOccName tycon)) - add_tick s | isPromotedDataCon tycon = '\'' : s + add_tick s | isDataKindsPromotedDataCon tycon = '\'' : s | otherwise = s -- This must match the computation done in diff --git a/GHC/Tc/Module.hs b/GHC/Tc/Module.hs --- a/GHC/Tc/Module.hs +++ b/GHC/Tc/Module.hs @@ -112,7 +112,6 @@ import GHC.Core.PatSyn ( pprPatSynType ) import GHC.Core.Predicate ( classMethodTy ) -import GHC.Core.FVs ( orphNamesOfFamInst ) import GHC.Core.InstEnv import GHC.Core.TyCon import GHC.Core.ConLike @@ -121,9 +120,10 @@ import GHC.Core.Class import GHC.Core.Coercion.Axiom import GHC.Core.Reduction ( Reduction(..) ) -import GHC.Core.Unify( RoughMatchTc(..) ) +import GHC.Core.RoughMap( RoughMatchTc(..) ) +import GHC.Core.TyCo.Ppr( debugPprType ) import GHC.Core.FamInstEnv - ( FamInst, pprFamInst, famInstsRepTyCons + ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst , famInstEnvElts, extendFamInstEnvList, normaliseType ) import GHC.Parser.Header ( mkPrelImports ) @@ -176,7 +176,10 @@ 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 @@ -242,9 +245,8 @@ tcRnModuleTcRnM hsc_env mod_sum (HsParsedModule { hpm_module = - (L loc (HsModule _ _ maybe_mod export_ies - import_decls local_decls mod_deprec - maybe_doc_hdr)), + (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) @@ -265,7 +267,7 @@ implicit_prelude import_decls } ; when (notNull prel_imports) $ do - let msg = TcRnUnknownMessage $ + let msg = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) noHints (implicitPreludeWarn) addDiagnostic msg @@ -283,7 +285,7 @@ ++ import_decls)) ; let { mkImport mod_name = noLocA $ (simpleImportDecl mod_name) - { ideclHiding = Just (False, noLocA [])}} + { 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 @@ -628,7 +630,7 @@ { Nothing -> return () ; Just (SpliceDecl _ (L loc _) _, _) -> setSrcSpanA loc - $ addErr (TcRnUnknownMessage $ mkPlainError noHints $ text + $ addErr (mkTcRnUnknownMessage $ mkPlainError noHints $ text ("Declaration splices are not " ++ "permitted inside top-level " ++ "declarations added with addTopDecls")) @@ -750,7 +752,7 @@ badBootDecl :: HscSource -> String -> LocatedA decl -> TcM () badBootDecl hsc_src what (L loc _) - = addErrAt (locA loc) $ TcRnUnknownMessage $ mkPlainError noHints $ + = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $ (char 'A' <+> text what <+> text "declaration is not (currently) allowed in a" <+> (case hsc_src of @@ -889,9 +891,9 @@ | name `elem` boot_dfun_names = return () -- Check that the actual module exports the same thing - | not (null missing_names) - = addErrAt (nameSrcSpan (head missing_names)) - (missingBootThing True (head missing_names) "exported by") + | 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) @@ -1066,7 +1068,7 @@ (text "The types of" <+> pname1 <+> text "are different") `andThenCheck` if is_boot - then check (eqMaybeBy eqDM def_meth1 def_meth2) + 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) @@ -1093,6 +1095,7 @@ -- Order of pattern matching matters. subDM _ Nothing _ = True subDM _ _ Nothing = False + -- If the hsig wrote: -- -- f :: a -> a @@ -1100,11 +1103,14 @@ -- -- this should be validly implementable using an old-fashioned -- vanilla default method. - subDM t1 (Just (_, GenericDM t2)) (Just (_, VanillaDM)) - = eqTypeX env t1 t2 + 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 @@ -1115,15 +1121,15 @@ eqATDef _ _ = False eqFD (as1,bs1) (as2,bs2) = - eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && - eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys 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 (eqListBy eqFD clas_fds1 clas_fds2) + check (liftEq eqFD clas_fds1 clas_fds2) (text "The functional dependencies do not match") `andThenCheck` checkUnless (isAbstractTyCon tc1) $ - check (eqListBy (eqTypeX env) sc_theta1 sc_theta2) + 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` @@ -1191,7 +1197,7 @@ , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2) = assert (tc1 == tc2) $ checkRoles roles1 roles2 `andThenCheck` - check (eqListBy (eqTypeX env) + check (liftEq (eqTypeX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2)) (text "The datatype contexts do not match") `andThenCheck` eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2) @@ -1250,7 +1256,7 @@ -- 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 (mkNthCo). But if we can + -- 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. -- @@ -1276,7 +1282,7 @@ -- 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 paramaters), + -- For any T (with some number of parameters), -- -- 1. T is a valid type (it is "curryable"), and -- @@ -1337,7 +1343,7 @@ check (dataConIsInfix c1 == dataConIsInfix c2) (text "The fixities of" <+> pname1 <+> text "differ") `andThenCheck` - check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2)) + 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)) @@ -1368,7 +1374,7 @@ , cab_lhs = lhs2, cab_rhs = rhs2 }) | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2 , Just env <- eqVarBndrs env1 cvs1 cvs2 - = eqListBy (eqTypeX env) lhs1 lhs2 && + = liftEq (eqTypeX env) lhs1 lhs2 && eqTypeX env rhs1 rhs2 | otherwise = False @@ -1379,7 +1385,7 @@ ---------------- missingBootThing :: Bool -> Name -> String -> TcRnMessage missingBootThing is_boot name what - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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" @@ -1387,7 +1393,7 @@ badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage badReexportedBootThing is_boot name name' - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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) @@ -1396,7 +1402,7 @@ bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage bootMisMatch is_boot extra_info real_thing boot_thing - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc where to_doc @@ -1427,7 +1433,7 @@ instMisMatch :: DFunId -> TcRnMessage instMisMatch dfun - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "instance" <+> ppr (idType dfun)) 2 (text "is defined in the hs-boot file, but not in the module itself") @@ -1620,7 +1626,7 @@ (hang (ppr name) 4 (sep [ppr clashingElts])) ; let warn_msg x = addDiagnosticAt (nameSrcSpan (greMangledName x)) $ - TcRnUnknownMessage $ + mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ (hsep [ text "Local definition of" , (quotes . ppr . nameOccName . greMangledName) x @@ -1650,7 +1656,7 @@ -- Implicit (Prelude) import? isImplicit :: ImportDecl GhcRn -> Bool - isImplicit = ideclImplicit + isImplicit = ideclImplicit . ideclExt -- Unqualified import? isUnqualified :: ImportDecl GhcRn -> Bool @@ -1660,17 +1666,17 @@ -- Nothing -> No explicit imports -- Just (False, ) -> Explicit import list of -- Just (True , ) -> Explicit hiding of - importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name]) - importListOf = fmap toImportList . ideclHiding + 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 (False, explicit) + Just (Exactly, explicit) -> nameOccName name `elem` map nameOccName explicit - Just (True, hidden) + Just (EverythingBut, hidden) -> nameOccName name `notElem` map nameOccName hidden -- Check whether the given name would be imported (unqualified) from @@ -1733,7 +1739,7 @@ ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst warnMsg (RM_KnownTc name:_) = addDiagnosticAt instLoc $ - TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ + mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ hsep [ (quotes . ppr . nameOccName) name , text "is an instance of" , (ppr . nameOccName . className) isClass @@ -1871,7 +1877,7 @@ -- in other modes, add error message and go on with typechecking. noMainMsg main_mod main_occ - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "The" <+> ppMainFn main_occ <+> text "is not" <+> text defOrExp <+> text "module" <+> quotes (ppr main_mod) @@ -1913,7 +1919,7 @@ ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $ tcCheckMonoExpr main_expr_rn io_ty - -- See Note [Root-main id] + -- See Note [Root-main Id] -- Construct the binding -- :Main.main :: IO res_ty = runMainIO res_ty main ; run_main_id <- tcLookupId runMainIOName @@ -1983,7 +1989,7 @@ - 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] + 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 @@ -2040,7 +2046,15 @@ 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 @@ -2189,7 +2203,7 @@ return (global_ids, zonked_expr, fix_env) } where - bad_unboxed id = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + 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))]) @@ -2223,10 +2237,8 @@ -- | Try the plans in order. If one fails (by raising an exn), try the next. -- If one succeeds, take it. -runPlans :: [Plan] -> TcM PlanResult -runPlans [] = panic "runPlans" -runPlans [p] = p -runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p +runPlans :: NonEmpty Plan -> Plan +runPlans = foldr1 (flip tryTcDiscardingErrs) -- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the -- GHCi 'environment'. @@ -2298,30 +2310,31 @@ -- See Note [GHCi Plans] - it_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 }, + ; when (isUnitTy it_ty) failM + ; return stuff } :| -- Plan B; a naked bind statement - tcGhciStmts [bind_stmt], + [ 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]) + , 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] ] + no_it_plans = + tcGhciStmts [no_it_a] :| + tcGhciStmts [no_it_b] : + tcGhciStmts [no_it_c] : + [] ; generate_it <- goptM Opt_NoIt @@ -2413,13 +2426,13 @@ ; let print_result_plan | opt_pr_flag -- The flag says "print result" , [v] <- collectLStmtBinders CollNoDictBinders gi_stmt -- One binder - = [mk_print_result_plan gi_stmt v] - | otherwise = [] + = 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 (print_result_plan ++ [tcGhciStmts [gi_stmt]]) + ; plan <- runPlans $ maybe id (NE.<|) print_result_plan $ NE.singleton $ tcGhciStmts [gi_stmt] ; return (plan, fix_env) } where mk_print_result_plan stmt v @@ -2544,8 +2557,8 @@ _ <- tcLookupInstance ghciClass [userTy] return name - Just _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text "Ambiguous type!" - Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ text ("Can't find type:" ++ ty) + 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) @@ -2669,8 +2682,15 @@ 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_type }, _fvs) - <- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type) + 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 @@ -2680,14 +2700,14 @@ -- 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_type]) - ; ((ty, kind), wanted) + ; 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' - ; tcInferLHsTypeUnsaturated rn_type } - + ; 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) @@ -2709,7 +2729,8 @@ normaliseType fam_envs Nominal ty | otherwise = ty - ; return (ty', mkInfForAllTys kvs (tcTypeKind ty')) } + ; traceTc "tcRnExpr" (debugPprType ty $$ debugPprType ty') + ; return (ty', mkInfForAllTys kvs (typeKind ty')) } {- Note [TcRnExprMode] @@ -2721,7 +2742,7 @@ :type / TM_Inst - In this mode, we report the type obained by instantiating only the + 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. @@ -2841,7 +2862,7 @@ let rdr_names = dataTcOccs rdr_name ; names_s <- mapM lookupInfoOccRn rdr_names ; let names = concat names_s - ; when (null names) (addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + ; when (null names) (addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ (text "Not in scope:" <+> quotes (ppr rdr_name))) ; return names } diff --git a/GHC/Tc/Solver.hs b/GHC/Tc/Solver.hs --- a/GHC/Tc/Solver.hs +++ b/GHC/Tc/Solver.hs @@ -58,7 +58,7 @@ import GHC.Core.Type import GHC.Core.Ppr import GHC.Core.TyCon ( TyConBinder, isTypeFamilyTyCon ) -import GHC.Builtin.Types ( liftedRepTy, manyDataConTy, liftedDataConTy ) +import GHC.Builtin.Types ( liftedRepTy, liftedDataConTy ) import GHC.Core.Unify ( tcMatchTyKi ) import GHC.Utils.Misc import GHC.Utils.Panic @@ -73,7 +73,7 @@ import Data.Foldable ( toList ) import Data.List ( partition ) import Data.List.NonEmpty ( NonEmpty(..) ) -import GHC.Data.Maybe ( mapMaybe ) +import GHC.Data.Maybe ( mapMaybe, isJust ) {- ********************************************************************************* @@ -438,7 +438,7 @@ We re-emit the implication rather than reporting the errors right now, -so that the error mesages are improved by other solving and defaulting. +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' @@ -1013,7 +1013,7 @@ the recursive case, we would go on forever in the common case where the constraints /are/ satisfiable (#10592 comment:12!). -For stratightforard situations without type functions the try_harder +For straightforward situations without type functions the try_harder step does nothing. Note [tcNormalise] @@ -1199,10 +1199,12 @@ -- 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 + ; 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) @@ -1668,13 +1670,13 @@ 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 impedence matching. Why avoid? Because it falls +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) mutiple +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 -> _ @@ -1848,7 +1850,7 @@ -- NB: only pass 'DefaultKindVars' when we know we're dealing with a kind variable. tv - -- this common case (no inferred contraints) should be fast + -- this common case (no inferred constraints) should be fast simplify_cand [] = return [] -- see Note [Unconditionally resimplify constraints when quantifying] simplify_cand candidates @@ -2490,18 +2492,7 @@ ; bad_telescope <- checkBadTelescope implic - ; let (used_givens, unused_givens) - | warnRedundantGivens info - = partition (`elemVarSet` need_inner) givens - | otherwise = (givens, []) -- None to report - - minimal_used_givens = mkMinimalBySCs evVarPred used_givens - is_minimal = (`elemVarSet` mkVarSet minimal_used_givens) - - warn_givens - | not (null unused_givens) = unused_givens - | warnRedundantGivens info = filterOut is_minimal used_givens - | otherwise = [] + ; 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 @@ -2541,6 +2532,67 @@ | 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 @@ -2689,7 +2741,7 @@ Moreover, if we simplify this implication more than once (e.g. because we can't solve it completely on the first iteration - of simpl_looop), we'll generate all the same bindings AGAIN! + 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 @@ -2895,7 +2947,7 @@ ; return True } | isMultiplicityVar the_tv = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv) - ; unifyTyVar the_tv manyDataConTy + ; unifyTyVar the_tv ManyTy ; return True } | otherwise = return False -- the common case @@ -2996,7 +3048,7 @@ 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 tcTypeKind (*) in the instance decl. See tests +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 @@ -3153,7 +3205,7 @@ | Just (cls,tys) <- getClassPredTys_maybe (ctPred cc) , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys -- Ignore invisible arguments for this purpose - , Just tv <- tcGetTyVar_maybe ty + , 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) diff --git a/GHC/Tc/Solver/Canonical.hs b/GHC/Tc/Solver/Canonical.hs --- a/GHC/Tc/Solver/Canonical.hs +++ b/GHC/Tc/Solver/Canonical.hs @@ -1,3144 +1,3420 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiWayIf #-} - -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 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 ) -import Data.Foldable ( traverse_ ) - -{- -************************************************************************ -* * -* 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 - , cc_fundeps = fds }) - = {-# SCC "canClass" #-} - canClass ev cls xis pend_sc fds - -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 fds } - - | 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 - False -- No top level instances for fundeps - } - - | otherwise - = canClass ev cls tys (has_scs cls) fds - - where - has_scs cls = not (null (classSCTheta cls)) - loc = ctEvLoc ev - orig = ctLocOrigin loc - pred = ctEvPred ev - fds = classHasFds cls - -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 - -> Bool -- True <=> unexploited fundep(s) - -> TcS (StopOrContinue Ct) --- Precondition: EvVar is class evidence - -canClass ev cls tys pend_sc fds - = -- 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 - , cc_fundeps = fds } - ; 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 -XNoRecursiveSuperClasses - 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 hance 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 - size = sizeTypes 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 InstSCOrigin mechanism - -- detailed in Note [Solving superclass constraints] in - -- GHC.Tc.TyCl.Instance. Skip for a tiny performance win. - - -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance - -- for explantation of InstSCOrigin and Note [Replacement vs keeping] in - -- GHC.Tc.Solver.Interact for why we need OtherSCOrigin and depths - | otherwise - = loc { ctl_origin = new_orig } - where - new_orig = case ctLocOrigin loc of - -- these cases are when we have something that's already a superclass constraint - InstSCOrigin sc_depth n -> InstSCOrigin (sc_depth + 1) (n `max` size) - OtherSCOrigin sc_depth si -> OtherSCOrigin (sc_depth + 1) si - - -- these cases do not already have a superclass constraint: depth starts at 1 - GivenOrigin InstSkol -> InstSCOrigin 1 size - GivenOrigin other_skol -> OtherSCOrigin 1 other_skol - - other_orig -> pprPanic "Given constraint without given origin" $ - ppr evar $$ ppr other_orig - -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, cc_fundeps = classHasFds cls } - -- 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 { skol_info <- mkSkolemInfo QuantCtxtSkol - ; let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs - ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs - ; given_ev_vars <- mapM newEvVar (substTheta subst theta) - - ; (lvl, (w_id, wanteds)) - <- pushLevelNoWorkList (ppr skol_info) $ - do { wanted_ev <- newWantedEvVarNC loc rewriters $ - substTy subst 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" } - - -- 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. - -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 getRuntimeRep_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 AnonArgFlag to match. This will stop -us decomposing - (Int -> Bool) ~ (Show a => blah) -It's as if we treat (->) and (=>) as different type constructors. --} - -canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct) -canEqNC ev eq_rel ty1 ty2 - = do { result <- zonk_eq_types ty1 ty2 - ; case result of - Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2 - Right ty -> canEqReflexive ev eq_rel ty } - -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) -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' <- tcView ty1 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 - | Just ty2' <- tcView 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 -- Don't decompose (Int -> blah) ~ (Show a => blah) - , Just ty1a_rep <- getRuntimeRep_maybe ty1a -- getRutimeRep_maybe: - , Just ty1b_rep <- getRuntimeRep_maybe ty1b -- see Note [Decomposing FunTy] - , Just ty2a_rep <- getRuntimeRep_maybe ty2a - , Just ty2b_rep <- getRuntimeRep_maybe ty2b - = canDecomposableTyConAppOK ev eq_rel funTyCon - [am1, ty1a_rep, ty1b_rep, ty1a, ty1b] - [am2, ty2a_rep, ty2b_rep, 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 `sameVis` vis2 -- Note [ForAllTy and typechecker 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 equality] -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 - = 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 - -Note [ForAllTy and typechecker equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Should GHC type-check the following program (adapted from #15740)? - - {-# LANGUAGE PolyKinds, ... #-} - data D a - type family F :: forall k. k -> Type - type instance F = D - -Due to the way F is declared, any instance of F must have a right-hand side -whose kind is equal to `forall k. k -> Type`. The kind of D is -`forall {k}. k -> Type`, which is very close, but technically uses distinct -Core: - - ----------------------------------------------------------- - | Source Haskell | Core | - ----------------------------------------------------------- - | forall k. <...> | ForAllTy (Bndr k Specified) (<...>) | - | forall {k}. <...> | ForAllTy (Bndr k Inferred) (<...>) | - ----------------------------------------------------------- - -We could deem these kinds to be unequal, but that would imply rejecting -programs like the one above. Whether a kind variable binder ends up being -specified or inferred can be somewhat subtle, however, especially for kinds -that aren't explicitly written out in the source code (like in D above). -For now, we decide to not make the specified/inferred status of an invisible -type variable binder affect GHC's notion of typechecker equality -(see Note [Typechecker equality vs definitional equality] in -GHC.Tc.Utils.TcType). That is, we have the following: - - -------------------------------------------------- - | Type 1 | Type 2 | Equal? | - --------------------|----------------------------- - | forall k. <...> | forall k. <...> | Yes | - | | forall {k}. <...> | Yes | - | | forall k -> <...> | No | - -------------------------------------------------- - | forall {k}. <...> | forall k. <...> | Yes | - | | forall {k}. <...> | Yes | - | | forall k -> <...> | No | - -------------------------------------------------- - | forall k -> <...> | forall k. <...> | No | - | | forall {k}. <...> | No | - | | forall k -> <...> | Yes | - -------------------------------------------------- - -We implement this nuance by using the GHC.Types.Var.sameVis function in -GHC.Tc.Solver.Canonical.canEqNC and GHC.Tc.Utils.TcType.tcEqType, which -respect typechecker equality. sameVis puts both forms of invisible type -variable binders into the same equivalence class. - -Note that we do /not/ use sameVis in GHC.Core.Type.eqType, which implements -/definitional/ equality, a slighty more coarse-grained notion of equality -(see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep) that does -not consider the ArgFlag of ForAllTys at all. That is, eqType would equate all -of forall k. <...>, forall {k}. <...>, and forall k -> <...>. --} - ---------------------------------- -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 (map binderArgFlag bndrs1) - , ppr (map binderArgFlag bndrs2) ] - ; canEqHardFailure ev s1 s2 } - else - do { traceTcS "Creating implication for polytype equality" $ ppr ev - ; let empty_subst1 = mkEmptyTCvSubst $ 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] -> TCvSubst -> [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 ( mkTcForAllCo 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 = mkEmptyTCvSubst (getTCvInScope 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 (mkTcReflCo 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 ty1 ty2 - | Just (Scaled w1 arg1, res1) <- split1 - , Just (Scaled w2 arg2, res2) <- split2 - , eqType w1 w2 - = do { res_a <- go arg1 arg2 - ; res_b <- go res1 res2 - ; return $ combine_rev (mkVisFunTy w1) res_b res_a - } - | isJust split1 || isJust split2 - = bale_out ty1 ty2 - where - split1 = tcSplitFunTy_maybe ty1 - split2 = tcSplitFunTy_maybe ty2 - - go ty1 ty2 - | Just (tc1, tys1) <- tcRepSplitTyConApp_maybe ty1 - , Just (tc2, tys2) <- tcRepSplitTyConApp_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) <- tcRepSplitAppTy_maybe ty1 - , Just (ty2a, ty2b) <- tcRepSplitAppTy_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) - -{- See Note [Unwrap newtypes first] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - newtype N m a = MkN (m a) -Then 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. - -Bottom line: unwrap newtypes before decomposing them! -c.f. #9123 comment:52,53 for a compelling example. - -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 when unwrapping newtypes. - -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.) --} - ------------------------- --- | 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: - -- See Note [Newtypes can blow the stack] - ; checkReductionDepth (ctEvLoc ev) ty1 - - -- Next, we record uses of newtype constructors, since coercing - -- through newtypes is tantamount to using their constructors. - ; addUsedGREs gre_list - -- If a newtype constructor was imported, don't warn about not - -- importing it... - ; traverse_ keepAlive $ map 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. - - ; 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 } - where - gre_list = bagToList gres - ---------- --- ^ 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 at representational role] -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 = mkTcCoVarCo evar - co_s = mkTcLRCo CLeft co - co_t = mkTcLRCo 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 = tcTypeKind s1 - s2k = tcTypeKind 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 TyConApps] --- Neither tc1 nor tc2 is a saturated funTyCon -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 AnonArgFlag; but - -- in fact we never call canTyConApp on a saturated FunTyCon - ty1 = mkTyConApp tc1 tys1 - ty2 = mkTyConApp tc2 tys2 - - loc = ctEvLoc ev - pred = ctEvPred ev - - -- See Note [Decomposing equality] - can_decompose inerts - = isInjectiveTyCon tc1 (eqRelRole eq_rel) - || (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts)) - -{- -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 [Decomposing equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If we have a constraint (of any flavour and role) that looks like -T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer, -of course, is "it depends". This Note spells it all out. - -In this Note, "decomposition" refers to taking the constraint - [fl] (T tys1 ~X T tys2) -(for some flavour fl and some role X) and replacing it with - [fls'] (tys1 ~Xs' tys2) -where that notation indicates a list of new constraints, where the -new constraints may have different flavours and different roles. - -The key property to consider is injectivity. When decomposing a Given, the -decomposition is sound if and only if T is injective in all of its type -arguments. When decomposing a Wanted, the decomposition is sound (assuming the -correct roles in the produced equality constraints), but it may be a guess -- -that is, an unforced decision by the constraint solver. Decomposing Wanteds -over injective TyCons does not entail guessing. But sometimes we want to -decompose a Wanted even when the TyCon involved is not injective! (See below.) - -So, in broad strokes, we want this rule: - -(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective -at role X. - -Pursuing the details requires exploring three axes: -* Flavour: Given vs. Wanted -* Role: Nominal vs. Representational -* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable - -(A type variable isn't a TyCon, of course, but it's convenient to put the AppTy case -in the same table.) - -Here is a table (discussion following) detailing where decomposition of - (T s1 ... sn) ~r (T t1 .. tn) -is allowed. The first four lines (Data types ... type family) refer -to TyConApps with various TyCons T; the last line is for AppTy, covering -both where there is a type variable at the head and the case for an over- -saturated type family. - -NOMINAL GIVEN WANTED WHERE - -Datatype YES YES canTyConApp -Newtype YES YES canTyConApp -Data family YES YES canTyConApp -Type family NO{1} YES, in injective args{1} canEqCanLHS2 -AppTy YES YES can_eq_app - -REPRESENTATIONAL GIVEN WANTED - -Datatype YES YES canTyConApp -Newtype NO{2} MAYBE{2} canTyConApp(can_decompose) -Data family NO{3} MAYBE{3} canTyConApp(can_decompose) -Type family NO NO canEqCanLHS2 -AppTy NO{4} NO{4} can_eq_nc' - -{1}: Type families can be injective in some, but not all, of their arguments, -so we want to do partial decomposition. This is quite different than the way -other decomposition is done, where the decomposed equalities replace the original -one. We thus proceed much like we do with superclasses, emitting new Wanteds -when "decomposing" a partially-injective type family Wanted. Injective type -families have no corresponding evidence of their injectivity, so we cannot -decompose an injective-type-family Given. - -{2}: See Note [Decomposing newtypes at representational role] - -{3}: Because of the possibility of newtype instances, we must treat -data families like newtypes. See also -Note [Decomposing newtypes at representational role]. See #10534 and -test case typecheck/should_fail/T10534. - -{4}: See Note [Decomposing AppTy at representational role] - - Because type variables can stand in for newtypes, we conservatively do not - decompose AppTys over representational equality. Here are two examples that - demonstrate why we can't: - - 4a: newtype Phant a = MkPhant Int - [W] alpha Int ~R beta Bool - - If we eventually solve alpha := Phant and beta := Phant, then we can solve - this equality by unwrapping. But it would have been disastrous to decompose - the wanted to produce Int ~ Bool, which is definitely insoluble. - - 4b: newtype Age = MkAge Int - [W] alpha Age ~R Maybe Int - - First, a question: if we know that ty1 ~R ty2, can we conclude that - a ty1 ~R a ty2? Not for all a. This is precisely why we need role annotations - on type constructors. So, if we were to decompose, we would need to - decompose to [W] alpha ~R Maybe and [W] Age ~ Int. On the other hand, if we - later solve alpha := Maybe, then we would decompose to [W] Age ~R Int, and - that would be soluble. - -In the implementation of can_eq_nc and friends, we don't directly pattern -match using lines like in the tables above, as those tables don't cover -all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity, -boiling the tables above down to rule (*). The exceptions to rule (*) are for -injective type families, which are handled separately from other decompositions, -and the MAYBE entries above. - -Note [Decomposing newtypes at representational role] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This note discusses the 'newtype' line in the REPRESENTATIONAL table -in Note [Decomposing equality]. (At nominal role, newtypes are fully -decomposable.) - -Here is a representative example of why representational equality over -newtypes is tricky: - - 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 - -If we have [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. Here's another example. - - 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: - * Unwrap newtypes before attempting to decompose them. - This is done in can_eq_nc'. - -It all comes from the fact that newtypes aren't necessarily injective -w.r.t. representational equality. - -Furthermore, as explained in Note [NthCo and newtypes] in GHC.Core.TyCo.Rep, we can't use -NthCo on representational coercions over newtypes. NthCo comes into play -only when decomposing givens. - -Conclusion: - * Do not decompose [G] N s ~R N t - -Is it sensible to decompose *Wanted* constraints over newtypes? Yes! -It's the only way we could ever prove (IO Int ~R IO Age), recalling -that IO is a newtype. - -However we must be careful. Consider - - type role Nt representational - - [G] Nt a ~R Nt b (1) - [W] NT alpha ~R Nt b (2) - [W] alpha ~ a (3) - -If we focus on (3) first, we'll substitute in (2), and now it's -identical to the given (1), so we succeed. But if we focus on (2) -first, and decompose it, we'll get (alpha ~R b), which is not soluble. -This is exactly like the question of overlapping Givens for class -constraints: see Note [Instance and Given overlap] in GHC.Tc.Solver.Interact. - -Conclusion: - * Decompose [W] N s ~R N t iff there no given constraint that could - later solve it. - -Note [Decomposing AppTy at representational role] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We never decompose AppTy at a representational role. For Givens, doing -so is simply unsound: the LRCo coercion former requires a nominal-roled -arguments. (See (1) for an example of why.) For Wanteds, decomposing -would be sound, but it would be a guess, and a non-confluent one at that. - -Here is an example: - - [G] g1 :: a ~R b - [W] w1 :: Maybe b ~R alpha a - [W] w2 :: alpha ~ Maybe - -Suppose we see w1 before w2. If we were to decompose, we would decompose -this to become - - [W] w3 :: Maybe ~R alpha - [W] w4 :: b ~ 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.) If we decomposed w1 to w3,w4, we would then get 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: never decompose AppTy with representational roles. - -(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 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 length - -- as tys1 and tys2 - -> do { cos <- zipWith4M (unifyWanted 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 $ mkNthCo r i 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, as tyConRolesX returns an infinite tail of Nominal - tc_roles = tyConRolesX 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 - --- | 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) <- rewrite ev ty1 - ; (redn2, rewriters2) <- rewrite ev ty2 - ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 - ; continueWith (mkIrredCt ShapeMismatchReason new_ev) } - -{- -Note [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 decomopose 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 canDecomposableTyCon is a fast-path decomposition that uses -unifyWanted etc to short-cut that work. - -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 [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 = tcTypeKind xi2 - -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] - = do { (kind_ev, kind_co) <- mk_kind_eq -- :: ki2 ~N ki1 - - ; let -- kind_co :: (ki2 :: *) ~N (ki1 :: *) (whether swapped or not) - lhs_redn = mkReflRedn role xi1 - rhs_redn = mkGReflRightRedn role xi2 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 ki2, text "~#", ppr ki1 ]) - ; 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 ki2 ki1 } - where - mk_kind_eq :: TcS (CtEvidence, CoercionN) - mk_kind_eq = case ev of - CtGiven { ctev_evar = evar } - -> do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar) -- :: k2 ~ k1 - ; 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 ki2 ki1 - - xi1 = canEqLHSType lhs1 - loc = ctev_loc ev - role = eqRelRole eq_rel - kind_loc = mkKindLoc xi1 xi2 loc - kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki2 ki1 - - maybe_sym = case swapped of - IsSwapped -> id -- if the input is swapped, then we already - -- will have k2 ~ k1 - NotSwapped -> mkTcSymCo - --- guaranteed that tcTypeKind lhs == tcTypeKind 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` mkTcSymMCo 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 - = 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 = mkTcSymMCo 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 = mkTcSymMCo 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` tcTypeKind 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 newtype - -- whose constructor is in scope at the top-level of the RHS. - ty_eq_N_OK :: TcS Bool - ty_eq_N_OK - | ReprEq <- eq_rel - , Just tc <- tyConAppTyCon_maybe rhs - , Just con <- newTyConDataCon_maybe tc - -- #21010: only a problem if the newtype constructor is in scope - -- yet we didn't rewrite it away. - = 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 $ - mkTcReflCo (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 = mkTcSymMCo 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 :: k2 ~ k1 - [X] (tv :: k1) ~ ((rhs |> 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 |> 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 :: k2 ~ k1, and adding - [W] (a :: k1) ~ ((rhs |> 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 meantion 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) - | isTcReflCo 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) - (tcDowngradeRole 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 (tcCoercionRole co == ctEvRole ev) - ; setWantedEvTerm dest - (mkEvCast (getEvExpr mb_new_ev) - (tcDowngradeRole 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 - , isTcReflCo lhs_co -- See Note [Rewriting with Refl] - , isTcReflCo rhs_co - = return (setCtEvPredType old_ev new_pred) - - | CtGiven { ctev_evar = old_evar } <- old_ev - = do { let new_tm = evCoercion ( mkTcSymCo lhs_co - `mkTcTransCo` maybeTcSymCo swapped (mkTcCoVarCo old_evar) - `mkTcTransCo` 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 = maybeTcSymCo swapped $ - lhs_co - `mkTransCo` hole_co - `mkTransCo` mkTcSymCo 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 - - -- equality is like a type class. Bumping the depth is necessary because - -- of recursive newtypes, where "reducing" a newtype can actually make - -- it bigger. See Note [Newtypes can blow the stack]. - loc = ctEvLoc old_ev - loc' = bumpCtLocDepth loc - -{- -************************************************************************ -* * - 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 (tcTypeKind ty1) (tcTypeKind 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' <- tcView ty1 = go ty1' ty2 - go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - - go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) - = 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 (mkFunCo role 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) - (tyConRolesX 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 (mkTcReflCo role ty1) - -- Check for equality; e.g. a ~ a, or (m a) ~ (m a) - | otherwise = emitNewWantedEq loc rewriters role orig_ty1 orig_ty2 +{-# LANGUAGE RecursiveDo #-} + +module GHC.Tc.Solver.Canonical( + canonicalize, + unifyWanted, + makeSuperClasses, + StopOrContinue(..), stopWith, continueWith, andWhenContinue, + 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 <- 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/InertSet.hs b/GHC/Tc/Solver/InertSet.hs --- a/GHC/Tc/Solver/InertSet.hs +++ b/GHC/Tc/Solver/InertSet.hs @@ -20,7 +20,8 @@ emptyInert, addInertItem, - matchableGivens, + noMatchableGivenDicts, + noGivenNewtypeReprEqs, mightEqualLater, prohibitedSuperClassSolve, @@ -41,11 +42,11 @@ import GHC.Prelude -import GHC.Tc.Solver.Types - 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 @@ -53,6 +54,7 @@ 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 @@ -338,7 +340,7 @@ in the above sense - Exception 1: local quantified constraints have no such guarantee; - indeed, adding a "solved dictionary" when appling a quantified + indeed, adding a "solved dictionary" when applying a quantified constraint led to the ability to define unsafeCoerce in #17267. @@ -883,7 +885,7 @@ (this is Lemma (L0)), and hence this triple never plays a role in application S(f,t). It is always safe to extend S with such a triple. - (NB: we could strengten K1) in this way too, but see K3. + (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 @@ -1535,46 +1537,59 @@ -- becomes "outer" even though its level numbers says it isn't. | otherwise = False -- Coercion variables; doesn't much matter --- | Returns Given constraints that might, --- potentially, match the given pred. This is used when checking to see if a +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" -matchableGivens :: CtLoc -> PredType -> InertSet -> Cts -matchableGivens loc_w pred_w inerts@(IS { inert_cans = inert_cans }) - = filterBag matchable_given all_relevant_givens +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 - -- just look in class constraints and irreds. matchableGivens does get called - -- for ~R constraints, but we don't need to look through equalities, because - -- canonical equalities are used for rewriting. We'll only get caught by - -- non-canonical -- that is, irreducible -- equalities. - all_relevant_givens :: Cts - all_relevant_givens - | Just (clas, _) <- getClassPredTys_maybe pred_w - = findDictsByClass (inert_dicts inert_cans) clas - `unionBags` inert_irreds inert_cans - | otherwise - = inert_irreds inert_cans + pred_w = mkClassPred clas tys matchable_given :: Ct -> Bool matchable_given ct | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct - = mightEqualLater inerts pred_g loc_g pred_w loc_w + = isJust $ mightEqualLater inerts pred_g loc_g pred_w loc_w | otherwise = False -mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool +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 - = False + = Nothing | otherwise = case tcUnifyTysFG bind_fun [flattened_given] [flattened_wanted] of - SurelyApart -> False -- types that are surely apart do not equal later - MaybeApart MARInfinite _ -> False -- see Example 7 in the Note. - _ -> True + 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] @@ -1621,7 +1636,7 @@ -- 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 <- tcGetTyVar_maybe rhs_ty + | Just rhs_tv <- getTyVar_maybe rhs_ty = case tcTyVarDetails rhs_tv of MetaTv { mtv_info = TyVarTv } -> True MetaTv {} -> False -- could unify with anything @@ -1631,12 +1646,24 @@ = False can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv -prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool --- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance -prohibitedSuperClassSolve from_loc solve_loc - | InstSCOrigin _ given_size <- ctLocOrigin from_loc - , ScOrigin wanted_size <- ctLocOrigin solve_loc - = given_size >= wanted_size +-- | 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 diff --git a/GHC/Tc/Solver/Interact.hs b/GHC/Tc/Solver/Interact.hs --- a/GHC/Tc/Solver/Interact.hs +++ b/GHC/Tc/Solver/Interact.hs @@ -1,5 +1,3 @@ - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Tc.Solver.Interact ( @@ -8,26 +6,17 @@ ) where import GHC.Prelude -import GHC.Types.Basic ( SwapFlag(..), - infinity, IntWithInf, intGtLimit ) +import GHC.Types.Basic ( SwapFlag(..), IntWithInf, intGtLimit ) import GHC.Tc.Solver.Canonical import GHC.Types.Var.Set -import GHC.Core.Type as Type -import GHC.Core.InstEnv ( DFunInstType ) import GHC.Types.Var import GHC.Tc.Errors.Types import GHC.Tc.Utils.TcType import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey ) -import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches, sfInteractInert, sfInteractTop ) -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Core.Reduction import GHC.Tc.Instance.FunDeps import GHC.Tc.Instance.Family import GHC.Tc.Instance.Class ( InstanceWhat(..), safeOverlap ) -import GHC.Core.FamInstEnv -import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX ) import GHC.Tc.Types.Evidence import GHC.Utils.Outputable @@ -35,31 +24,46 @@ import GHC.Tc.Types import GHC.Tc.Types.Constraint -import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcMType( promoteMetaTyVarTo ) import GHC.Tc.Solver.Types import GHC.Tc.Solver.InertSet import GHC.Tc.Solver.Monad -import GHC.Data.Bag -import GHC.Utils.Monad ( concatMapM, foldlM ) import GHC.Core -import Data.List( deleteFirstsBy ) -import Data.Function ( on ) +import GHC.Core.Type as Type +import GHC.Core.InstEnv ( DFunInstType ) +import GHC.Core.Class +import GHC.Core.TyCon +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 qualified Data.Semigroup as S -import Control.Monad +import GHC.Data.Bag import GHC.Data.Pair (Pair(..)) -import GHC.Types.Unique( hasKey ) -import GHC.Driver.Session + +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 {- ********************************************************************** @@ -78,7 +82,7 @@ - inert reactions - spontaneous reactions - top-level interactions - Each stage returns a StopOrContinue and may have sideffected + Each stage returns a StopOrContinue and may have sideeffected the inerts or worklist. The threading of the stages is as follows: @@ -445,7 +449,7 @@ solveOneFromTheOther :: Ct -- Inert (Dict or Irred) -> Ct -- WorkItem (same predicate as inert) - -> TcS InteractResult + -> InteractResult -- Precondition: -- * inert and work item represent evidence for the /same/ predicate -- * Both are CDictCan or CIrredCan @@ -457,28 +461,28 @@ 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 - do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w) - ; return KeepWork } + KeepWork | CtWanted {} <- ev_w = -- Inert is Given or Wanted case ev_i of - CtGiven {} -> return KeepInert + 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 -> return KeepInert - | is_psc_i, not is_psc_w -> return KeepWork + | 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 -> return KeepInert - | is_wsc_orig_i, not is_wsc_orig_w -> return KeepWork + | 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 @@ -486,46 +490,46 @@ -- 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 -> return KeepInert - | otherwise -> return KeepWork + | ((<) `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 - = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w) - ; return KeepInert } -- Just discard the un-usable Given - -- This never actually happens because - -- Givens get processed first + = KeepInert -- Just discard the un-usable Given + -- This never actually happens because + -- Givens get processed first | CtWanted {} <- ev_i - = return KeepWork + = KeepWork -- From here on both are Given -- See Note [Replacement vs keeping] | lvl_i == lvl_w - = return same_level_strategy + = same_level_strategy | otherwise -- Both are Given, levels differ - = return different_level_strategy + = 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 - lvl_i = ctLocLevel loc_i - lvl_w = ctLocLevel loc_w + 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 = is_wanted_superclass_loc loc_i - is_wsc_orig_w = is_wanted_superclass_loc loc_w - is_wanted_superclass_loc = isWantedSuperclassOrigin . ctLocOrigin + 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 @@ -534,28 +538,21 @@ -- For the isIPLikePred case see Note [Shadowing of Implicit Parameters] same_level_strategy -- Both Given - = case (ctLocOrigin loc_i, ctLocOrigin loc_w) of - -- case 2(a) from Note [Replacement vs keeping] - (InstSCOrigin _depth_i size_i, InstSCOrigin _depth_w size_w) - | size_w < size_i -> KeepWork - | otherwise -> KeepInert + = case (orig_i, orig_w) of - -- case 2(c) from Note [Replacement vs keeping] - (InstSCOrigin depth_i _, OtherSCOrigin depth_w _) -> choose_shallower depth_i depth_w - (OtherSCOrigin depth_i _, InstSCOrigin depth_w _) -> choose_shallower depth_i depth_w - (OtherSCOrigin depth_i _, OtherSCOrigin depth_w _) -> choose_shallower depth_i depth_w + (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] - -- case 2(b) from Note [Replacement vs keeping] - (InstSCOrigin {}, _) -> KeepWork - (OtherSCOrigin {}, _) -> KeepWork + -- Both blocked or both not blocked - -- case 2(d) from Note [Replacement vs keeping] - _ -> KeepInert + | depth_w < depth_i -> KeepWork -- Case 2(c) from + | otherwise -> KeepInert -- Note [Replacement vs keeping] - choose_shallower depth_i depth_w | depth_w < depth_i = KeepWork - | otherwise = KeepInert - -- favor KeepInert in the equals case, according to 2(d) from the Note + (GivenSCOrigin {}, _) -> KeepWork -- Case 2(b) from Note [Replacement vs keeping] + _ -> KeepInert -- Case 2(d) from Note [Replacement vs keeping] + {- Note [Replacement vs keeping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -580,7 +577,7 @@ 2) Constraints coming from the same level (i.e. same implication) - (a) If both are InstSCOrigin, choose the one with the smallest TypeSize, + (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: @@ -596,12 +593,13 @@ Getting this wrong was #20602. See also Note [Tracking redundant constraints] in GHC.Tc.Solver. - (c) If both are superclass selections (but not both InstSCOrigin), choose 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. + (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. @@ -663,11 +661,12 @@ , ((ct_i, swap) : _rest) <- bagToList matching_irreds -- See Note [Multiple matching irreds] , let ev_i = ctEvidence ct_i - = do { what_next <- solveOneFromTheOther ct_i ct_w - ; traceTcS "iteractIrred" (ppr ct_w $$ ppr what_next $$ ppr ct_i) - ; case what_next of + = 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" <+> parens (ppr what_next))) } + ; 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 } } @@ -680,7 +679,7 @@ swap_me swap ev = case swap of NotSwapped -> ctEvTerm ev - IsSwapped -> evCoercion (mkTcSymCo (evTermCoercion (ctEvTerm ev))) + IsSwapped -> evCoercion (mkSymCo (evTermCoercion (ctEvTerm ev))) interactIrred _ wi = pprPanic "interactIrred" (ppr wi) @@ -921,7 +920,7 @@ cannot be solved from instances. * The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional - state that allows try_solve_from_instance to augmennt the evidence + 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 @@ -994,7 +993,7 @@ [W] iss ~ is2 : beta Again we can't prove that equality; and worse we'll rewrite iss to - (is2:beta) in deeply nested contraints inside this implication, + (is2:beta) in deeply nested constraints inside this implication, where beta is untouchable (under other equality constraints), leading to other insoluble constraints. @@ -1005,7 +1004,9 @@ 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 + , 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] @@ -1013,16 +1014,24 @@ ; short_cut_worked <- shortCutSolver dflags ev_w ev_i ; if short_cut_worked then stopWith ev_w "interactDict/solved from instance" - else - do { -- Ths short-cut solver didn't fire, so we - -- solve ev_w from the matching inert ev_i we found - what_next <- solveOneFromTheOther ct_i ct_w - ; traceTcS "lookupInertDict" (ppr what_next) - ; case what_next of - KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i) - ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) } - KeepWork -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w) + -- Next see if we are in "loopy-superclass" land. If so, + -- we don't want to replace the (Given) inert with the + -- (Wanted) work-item, or vice versa; we want to hang on + -- to both, and try to solve the work-item via an instance. + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + else if prohibitedSuperClassSolve loc_i loc_w + then continueWith 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 } } } @@ -1393,7 +1402,7 @@ injectivity. 1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and -described in Note [Decomposing equality] in GHC.Tc.Solver.Canonical. +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 @@ -1469,7 +1478,7 @@ 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 visiblity in the uo_visible field of a TypeEqOrigin. + 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). @@ -1531,10 +1540,10 @@ , cc_eq_rel = eq_rel }) | Just (ev_i, swapped) <- inertsCanDischarge inerts workItem = do { setEvBindIfWanted ev $ - evCoercion (maybeTcSymCo swapped $ - tcDowngradeRole (eqRelRole eq_rel) - (ctEvRole ev_i) - (ctEvCoercion ev_i)) + evCoercion (maybeSymCo swapped $ + downgradeRole (eqRelRole eq_rel) + (ctEvRole ev_i) + (ctEvCoercion ev_i)) ; stopWith ev "Solved from inert" } @@ -1563,7 +1572,7 @@ -> TcType -- RHS -> TcS (StopOrContinue Ct) tryToSolveByUnification work_item ev tv rhs - = do { (is_touchable, rhs) <- touchabilityTest (ctEvFlavour ev) tv rhs + = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv rhs ; traceTcS "tryToSolveByUnification" (vcat [ ppr tv <+> char '~' <+> ppr rhs , ppr is_touchable ]) @@ -1596,10 +1605,10 @@ ; traceTcS "Sneaky unification:" $ vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi, text "Coercion:" <+> pprEq tv_ty xi, - text "Left Kind is:" <+> ppr (tcTypeKind tv_ty), - text "Right Kind is:" <+> ppr (tcTypeKind xi) ] + text "Left Kind is:" <+> ppr (typeKind tv_ty), + text "Right Kind is:" <+> ppr (typeKind xi) ] ; unifyTyVar tv xi - ; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) + ; setEvBindIfWanted wd (evCoercion (mkNomReflCo xi)) ; n_kicked <- kickOutAfterUnification tv ; return (Stop wd (text "Solved by unification" <+> pprKicked n_kicked)) } @@ -1734,8 +1743,12 @@ It's exactly the same with implicit parameters, except that the "aggressive" approach would be much easier to implement. -Note [Fundeps with instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 @@ -1749,53 +1762,123 @@ work_item: dwrk :: C (T @ka (a::ka)) (T @kb0 (b0::kb0)) Char where kb0, b0 are unification vars - ==> {fundeps against instance; k0, y0 fresh unification vars} - [W] T kb0 (b0::kb0) ~ T k0 (y0::k0) - Add dwrk to inert set - ==> {solve that equality kb0 := k0, b0 := y0 + + ==> {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), which is known to lead to termination trouble +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: if the unification was the other way round, k0:=kb0, all would be -well. It's a very delicate problem. +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 -The ticket #19415 discusses various solutions, but the one we adopted -is very simple: +We solve the problem by (#21703): -* There is a flag in CDictCan (cc_fundeps :: Bool) + carefully orienting the new Wanted so that all the + freshly-generated unification variables are on the LHS. -* cc_fundeps = True means - a) The class has fundeps - b) We have not had a successful hit against instances yet + Thus we emit + [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0) + and /NOT/ + [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0) -* In doTopFundepImprovement, if we emit some constraints we flip the flag - to False, so that we won't try again with the same CDictCan. In our - example, dwrk will have its flag set to False. +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. -* Not that if we have no "hits" we must /not/ flip the flag. We might have - dwrk :: C alpha beta Char - which does not yet trigger fundeps from the instance, but later we - get alpha := T ka a. We could be cleverer, and spot that the constraint - is such that we will /never/ get any hits (no unifiers) but we don't do - that yet. +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. -Easy! What could go wrong? -* Maybe the class has multiple fundeps, and we get hit with one but not - the other. Per-fundep flags? -* Maybe we get a hit against one instance with one fundep but, after - the work-item is instantiated a bit more, we get a second hit - against a second instance. (This is a pretty strange and - undesirable thing anyway, and can only happen with overlapping - instances; one example is in Note [Weird fundeps].) +But this is is a delicate solution. We must take care to /preserve/ +orientation during solving. Wrinkles: -But both of these seem extremely exotic, and ignoring them threatens -completeness (fixable with some type signature), but not termination -(not fixable). So for now we are just doing the simplest thing. +(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 @@ -1818,25 +1901,17 @@ #7875 is a case in point. -} -doTopFundepImprovement :: Ct -> TcS (StopOrContinue Ct) --- Try to functional-dependency improvement betweeen the constraint +doTopFundepImprovement :: Ct -> TcS () +-- Try to functional-dependency improvement between the constraint -- and the top-level instance declarations --- See Note [Fundeps with instances] +-- 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 - , cc_fundeps = has_fds }) - | has_fds + , cc_tyargs = xis }) = do { traceTcS "try_fundeps" (ppr work_item) ; instEnvs <- getInstEnvs ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis - ; case fundep_eqns of - [] -> continueWith work_item -- No improvement - _ -> do { emitFunDepWanteds (ctEvRewriters ev) fundep_eqns - ; continueWith (work_item { cc_fundeps = False }) } } - | otherwise - = continueWith work_item - + ; emitFunDepWanteds (ctEvRewriters ev) fundep_eqns } where dict_pred = mkClassPred cls xis dict_loc = ctEvLoc ev @@ -1853,8 +1928,11 @@ doTopFundepImprovement work_item = pprPanic "doTopFundepImprovement" (ppr work_item) emitFunDepWanteds :: RewriterSet -- from the work item - -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS () + -> [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 @@ -1867,15 +1945,24 @@ | otherwise = do { traceTcS "emitFunDepWanteds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs) - ; subst <- instFlexi tvs -- Takes account of kind substitution + ; 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 - (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst 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. {- ********************************************************************** @@ -1923,7 +2010,7 @@ | otherwise = do { res <- matchLocalInst pred loc ; case res of - OneInst {} -> chooseInstance ev res + OneInst {} -> chooseInstance work_item res _ -> continueWith work_item } where @@ -1940,44 +2027,20 @@ doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct) doTopReactEqPred work_item eq_rel t1 t2 -- 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} + | Just (cls, tys) <- boxEqPred eq_rel t1 t2 + = do { res <- matchLocalInst (mkClassPred cls tys) loc + ; case res of + OneInst { cir_mk_ev = mk_ev } + -> chooseInstance work_item + (res { cir_mk_ev = mk_eq_ev cls tys mk_ev }) + _ -> continueWith work_item } + + | otherwise + = 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 t1 t2 - = 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 t2 t1 - = 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 t2) (mkReflRedn role t1) - ; 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) @@ -2097,13 +2160,15 @@ = 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], TCvSubst, [TyVar], Maybe CoAxBranch )] + -> [( [Type], Subst, [TyVar], Maybe CoAxBranch )] -- Result: -- ( [arguments of a matching axiom] -- , RHS-unifying substitution @@ -2115,14 +2180,15 @@ , let ax_args = axiomLHS axiom ax_rhs = axiomRHS axiom ax_tvs = axiomTVs axiom - , Just subst <- [tcUnifyTyWithTFs False ax_rhs rhs_ty] + 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], TCvSubst, [TyCoVar], Maybe CoAxBranch) + -> ([Type], Subst, [TyCoVar], Maybe CoAxBranch) -> TcS [TypeEqn] injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr) = do { subst <- instFlexiX subst unsubstTvs @@ -2131,7 +2197,7 @@ -- be sure to apply the current substitution to a's kind. -- Hence instFlexiX. #13135 was an example. - ; return [ Pair (substTyUnchecked subst ax_arg) arg + ; return [ Pair (substTy subst ax_arg) arg -- NB: the ax_arg part is on the left -- see Note [Improvement orientation] | case cabr of @@ -2148,6 +2214,9 @@ 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 @@ -2210,35 +2279,60 @@ OneInst { cir_what = what } -> do { insertSafeOverlapFailureTcS what work_item ; addSolvedDict what ev cls xis - ; chooseInstance ev lkup_res } + ; chooseInstance work_item lkup_res } _ -> -- NoInstance or NotSure -- We didn't solve it; so try functional dependencies with - -- the instance environment, and return - doTopFundepImprovement work_item } + -- 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 :: Ct -> 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 + = do { traceTcS "doTopReact/found instance for" $ ppr ev ; 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)" } + ; evb <- getTcEvBindsVar + ; if isCoEvBindsVar evb + then continueWith work_item + -- See Note [Instances in no-evidence implications] + else + do { evc_vars <- mapM (newWanted deeper_loc (ctRewriters work_item)) theta + ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars)) + ; emitWorkNC (freshGoals evc_vars) + ; stopWith ev "Dict/Top (solved wanted)" }} where - pred = ctEvPred work_item - loc = ctEvLoc work_item + ev = ctEvidence work_item + pred = ctEvPred ev + loc = ctEvLoc ev chooseInstance work_item lookup_res = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res) @@ -2256,13 +2350,35 @@ origin = ctLocOrigin loc zap_origin loc -- After applying an instance we can set ScOrigin to - -- infinity, so that prohibitedSuperClassSolve never fires - | ScOrigin {} <- origin - = setCtLocOrigin loc (ScOrigin infinity) + -- 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 @@ -2273,11 +2389,9 @@ -- See Note [Instance and Given overlap] | not (xopt LangExt.IncoherentInstances dflags) , not (naturallyCoherentClass clas) - , let matchable_givens = matchableGivens loc pred inerts - , not (isEmptyBag matchable_givens) + , not (noMatchableGivenDicts inerts loc clas tys) = do { traceTcS "Delaying instance application" $ - vcat [ text "Work item=" <+> pprClassPred clas tys - , text "Potential matching givens:" <+> ppr matchable_givens ] + vcat [ text "Work item=" <+> pprClassPred clas tys ] ; return NotSure } | otherwise @@ -2303,7 +2417,7 @@ -- | 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 class story] in "GHC.Builtin.Types.Prim". +-- See also Note [The equality types story] in GHC.Builtin.Types.Prim. naturallyCoherentClass :: Class -> Bool naturallyCoherentClass cls = isCTupleClass cls @@ -2429,7 +2543,7 @@ instance (c1, c2) => (% c1, c2 %) Example in #14218 -Exammples: T5853, T10432, T5315, T9222, T2627b, T3028b +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. @@ -2454,7 +2568,7 @@ that unify with it here. It is not like an incoherent user-written instance which might have utterly different behaviour. -Consdider f :: Eq a => blah. If we have [W] Eq a, we certainly +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 @@ -2467,110 +2581,236 @@ matchLocalInst pred loc = do { inerts@(IS { inert_cans = ics }) <- getTcSInerts ; case match_local_inst inerts (inert_insts ics) of - ([], Nothing) -> do { traceTcS "No local instance for" (ppr pred) - ; return NoInstance } - - -- See Note [Use only the best local instance] about - -- superclass depths - (matches, unifs) - | [(dfun_ev, inst_tys)] <- best_matches - , maybe True (> min_sc_depth) unifs - -> do { let dfun_id = ctEvEvId dfun_ev - ; (tys, theta) <- instDFunType dfun_id inst_tys - ; let result = OneInst { cir_new_theta = theta - , cir_mk_ev = evDFunApp dfun_id tys - , cir_what = LocalInstance } - ; traceTcS "Best local inst found:" (ppr result) - ; traceTcS "All local insts:" (ppr matches) - ; return result } - - | otherwise - -> do { traceTcS "Multiple local instances for" (ppr pred) - ; return NotSure } + { ([], []) -> 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 } - where - extract_depth = sc_depth . ctEvLoc . fst - min_sc_depth = minimum (map extract_depth matches) - best_matches = filter ((== min_sc_depth) . extract_depth) matches } + ; 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 - sc_depth :: CtLoc -> Int - sc_depth ctloc = case ctLocOrigin ctloc of - InstSCOrigin depth _ -> depth - OtherSCOrigin depth _ -> depth - _ -> 0 + 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) } - -- See Note [Use only the best local instance] about superclass depths + -- Compute matching and unifying local instances match_local_inst :: InertSet -> [QCInst] -> ( [(CtEvidence, [DFunInstType])] - , Maybe Int ) -- Nothing ==> no unifying local insts - -- Just n ==> unifying local insts, with - -- minimum superclass depth - -- of n + , [(CtEvidence, [DFunInstType])] ) match_local_inst _inerts [] - = ([], Nothing) - match_local_inst inerts (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred - , qci_ev = qev }) - : qcis) + = ([], []) + 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, unif) + = (match:matches, unifs) | otherwise = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred)) (ppr qci $$ ppr pred) -- ASSERT: unification relies on the -- quantified variables being fresh - (matches, unif `combine` this_unif) + (matches, this_unif `combine` unifs) where qloc = ctEvLoc qev qtv_set = mkVarSet qtvs + (matches, unifs) = match_local_inst inerts qcis this_unif - | mightEqualLater inerts qpred qloc pred loc = Just (sc_depth qloc) - | otherwise = Nothing - (matches, unif) = match_local_inst inerts qcis + | Just subst <- mightEqualLater inerts qpred qloc pred loc + = Just (qev, map (lookupTyVar subst) qtvs) + | otherwise + = Nothing - combine Nothing Nothing = Nothing - combine (Just n) Nothing = Just n - combine Nothing (Just n) = Just n - combine (Just n1) (Just n2) = Just (n1 `min` n2) + combine Nothing us = us + combine (Just u) us = u : us -{- Note [Use only the best local instance] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- | 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] forall a. Ord (m a) - [G] forall a. Eq (m a) - [G] forall a. Semigroup a => Eq (m a) + [G] d1: forall a. Ord (m a) + [G] d2: forall a. Eq (m a) + [G] d3: forall a. Semigroup a => Eq (m a) - [W] forall a. Ord (m a) - [W] 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. Our general rule around multiple local +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 with fewer superclass selections. -So, matchLocalInst is careful to whittle down the matches only to the -ones with the shallowest superclass depth, and also to worry about unifying -local instances that are at that depth (or less). +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. -By preferring these shallower local instances, we can use the last given -listed above and pass the ambiguity check. +Our criterion for solving a Wanted by matching local quantified instances is +thus as follows: -The instance-depth mechanism uses the same superclass depth -information as described in Note [Replacement vs keeping], 2a. + - 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. -Test case: typecheck/should_compile/T20582. +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/Monad.hs b/GHC/Tc/Solver/Monad.hs --- a/GHC/Tc/Solver/Monad.hs +++ b/GHC/Tc/Solver/Monad.hs @@ -8,14 +8,14 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-orphans #-} +{-# 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, + failTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS, runTcSEqualities, nestTcS, nestImplicTcS, setEvBindsTcS, emitImplicationTcS, emitTvImplicationTcS, @@ -25,7 +25,7 @@ updWorkListTcS, pushLevelNoWorkList, - runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive, + runTcPluginTcS, recordUsedGREs, matchGlobalInst, TcM.ClsInstResult(..), QCInst(..), @@ -89,7 +89,7 @@ instDFunType, -- Instantiation -- MetaTyVars - newFlexiTcSTy, instFlexi, instFlexiX, + newFlexiTcSTy, instFlexiX, cloneMetaTyVar, tcInstSkolTyVarsX, @@ -131,27 +131,29 @@ 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.Driver.Session +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.Tc.Solver.Types -import GHC.Tc.Solver.InertSet - -import GHC.Tc.Types.Evidence import GHC.Core.Class import GHC.Core.TyCon -import GHC.Tc.Errors.Types -import GHC.Types.Error ( mkPlainError, noHints ) +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 GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt ) import qualified GHC.Rename.Env as TcM import GHC.Types.Var import GHC.Types.Var.Env @@ -173,7 +175,8 @@ import GHC.Utils.Monad import Data.IORef import GHC.Exts (oneShot) -import Data.List ( mapAccumL, partition, find ) +import Data.List ( mapAccumL, partition ) +import Data.Foldable #if defined(DEBUG) import GHC.Data.Graph.Directed @@ -220,21 +223,17 @@ {- Note [Do not add duplicate quantified instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#15244): - - f :: (C g, D g) => .... - class S g => C g where ... - class S g => D g where ... - class (forall a. Eq a => Eq (g a)) => S g where ... +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): -Then in f's RHS there are two identical quantified constraints -available, one via the superclasses of C and one via the superclasses -of D. The two are identical, and it seems wrong to reject the program -because of that. But without doing duplicate-elimination we will have -two matching QCInsts when we try to solve constraints arising from f's -RHS. + - forall a b. C a b + - forall b a. C a b -The simplest thing is simply to eliminate duplicates, which we do here. +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. -} {- ********************************************************************* @@ -674,8 +673,18 @@ lookupInInerts loc pty | ClassPred cls tys <- classifyPredType pty = do { inerts <- getTcSInerts - ; return (lookupSolvedDict inerts loc cls tys `mplus` - fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)) } + ; 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 @@ -785,8 +794,12 @@ } --------------- -newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor) +newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } + deriving (Functor) +instance MonadFix TcS where + mfix k = TcS $ \env -> mfix (\x -> unTcS (k x) env) + -- | Smart constructor for 'TcS', as describe in Note [The one-shot state -- monad trick] in "GHC.Utils.Monad". mkTcS :: (TcSEnv -> TcM a) -> TcS a @@ -844,6 +857,10 @@ 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] @@ -902,7 +919,7 @@ ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var ; return (res, ev_binds) } --- | This variant of 'runTcS' will immediatley fail upon encountering an +-- | 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 @@ -1250,37 +1267,35 @@ 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: +touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult +-- 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 + = do { can_continue_solving <- wrapTcS $ startSolvingByUnification info rhs + ; if not can_continue_solving + then return Untouchable + else + do { ambient_lvl <- getTcLevel ; given_eq_lvl <- getInnermostGivenEqLevel ; if | tv_lvl `sameDepthAs` ambient_lvl - -> return (TouchableSameLevel, rhs) + -> return TouchableSameLevel | 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) + -> return (TouchableOuterLevel free_metas tv_lvl) | otherwise - -> return (Untouchable, rhs) } } } + -> return Untouchable } } | otherwise - = return (Untouchable, rhs) + = return Untouchable where + (free_metas, free_skols) = partition isPromotableMetaTyVar $ + nonDetEltsUniqSet $ + tyCoVarsOfType rhs does_not_escape tv_lvl fv | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv @@ -1365,17 +1380,22 @@ tcLookupId :: Name -> TcS Id tcLookupId n = wrapTcS $ TcM.tcLookupId n --- Setting names as used (used in the deriving of Coercible evidence) --- Too hackish to expose it to TcS? In that case somehow extract the used --- constructors from the result of solveInteract -addUsedGREs :: [GlobalRdrElt] -> TcS () -addUsedGREs gres = wrapTcS $ TcM.addUsedGREs gres - -addUsedGRE :: Bool -> GlobalRdrElt -> TcS () -addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre +-- 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. -keepAlive :: Name -> TcS () -keepAlive = wrapTcS . TcM.keepAlive + where + gre_list = bagToList gres -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1616,22 +1636,21 @@ cloneMetaTyVar :: TcTyVar -> TcS TcTyVar cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) -instFlexi :: [TKVar] -> TcS TCvSubst -instFlexi = instFlexiX emptyTCvSubst - -instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst +instFlexiX :: Subst -> [TKVar] -> TcS Subst instFlexiX subst tvs = wrapTcS (foldlM instFlexiHelper subst tvs) -instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst +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) - ty' = mkTyVarTy (mkTcTyVar name kind details) - ; TcM.traceTc "instFlexi" (ppr ty') - ; return (extendTvSubst subst tv ty') } + ; 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 @@ -1640,7 +1659,7 @@ matchGlobalInst dflags short_cut cls tys = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys) -tcInstSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar]) +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 @@ -1691,7 +1710,7 @@ = -- See Note [Yukky eq_sel for a HoleDest] do { let co_var = coHoleCoVar hole ; setEvBind (mkWantedEvBind co_var tm) - ; fillCoercionHole hole (mkTcCoVarCo co_var) } + ; fillCoercionHole hole (mkCoVarCo co_var) } setWantedEvTerm (EvVarDest ev_id) tm = setEvBind (mkWantedEvBind ev_id tm) @@ -1704,8 +1723,8 @@ 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 +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 (...) @@ -1875,7 +1894,7 @@ ; env0 <- TcM.tcInitTidyEnv ; let tidy_env = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty) tidy_ty = tidyType tidy_env ty - msg = TcRnUnknownMessage $ mkPlainError noHints $ + msg = mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Reduction stack overflow; size =" <+> ppr depth , hang (text "When simplifying the following type:") 2 (ppr tidy_ty) @@ -1921,21 +1940,23 @@ -- See Detail (8) of the Note. = do { should_break <- final_check - ; mapM go should_break } + ; if should_break then do { redn <- go rhs + ; return (Just redn) } + else return Nothing } where flavour = ctEvFlavour ev eq_rel = ctEvEqRel ev final_check = case flavour of - Given -> return $ Just rhs + Given -> return True 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 + do { result <- touchabilityTest Wanted lhs_tv rhs ; return $ case result of - Untouchable -> Nothing - _ -> Just rhs } - | otherwise -> return Nothing + Untouchable -> False + _ -> True } + | otherwise -> return False -- This could be considerably more efficient. See Detail (5) of Note. go :: TcType -> TcS ReductionN @@ -1945,7 +1966,7 @@ -- 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 = tcTypeKind fun_app + 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 } @@ -2015,5 +2036,5 @@ rewriterView :: TcType -> Maybe TcType rewriterView ty@(Rep.TyConApp tc _) | isForgetfulSynTyCon tc || (isTypeSynonymTyCon tc && not (isFamFreeTyCon tc)) - = tcView ty + = coreView ty rewriterView _other = Nothing 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 @@ -2,10 +2,8 @@ {-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Tc.Solver.Rewrite( - rewrite, rewriteArgsNom, + rewrite, rewriteForErrors, rewriteArgsNom, rewriteType ) where @@ -40,8 +38,10 @@ import GHC.Exts (oneShot) import Control.Monad import Control.Applicative (liftA3) -import GHC.Builtin.Types.Prim (tYPETyCon) +import GHC.Builtin.Types (tYPETyCon) import Data.List ( find ) +import GHC.Data.List.Infinite (Infinite) +import qualified GHC.Data.List.Infinite as Inf {- ************************************************************************ @@ -223,6 +223,22 @@ ; traceTcS "rewrite }" (ppr $ reductionReducedType redn) ; return result } +-- | See Note [Rewriting] +-- `rewriteForErrors` is a variant of 'rewrite' that rewrites +-- w.r.t. nominal equality only, as this is better than full rewriting +-- for error messages. (This was important when we flirted with rewriting +-- newtypes but perhaps less so now.) +rewriteForErrors :: CtEvidence -> TcType + -> TcS (Reduction, RewriterSet) +rewriteForErrors ev ty + = do { traceTcS "rewriteForErrors {" (ppr ty) + ; result@(redn, rewriters) <- + runRewrite (ctEvLoc ev) (ctEvFlavour ev) NomEq (rewrite_one ty) + ; traceTcS "rewriteForErrors }" (ppr $ reductionReducedType redn) + ; return $ case ctEvEqRel ev of + NomEq -> result + ReprEq -> (mkSubRedn redn, rewriters) } + -- See Note [Rewriting] rewriteArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS (Reductions, RewriterSet) @@ -275,8 +291,8 @@ Key invariants: (F0) co :: zonk(ty') ~ xi where zonk(ty') ~ zonk(ty) - (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind - (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty)) + (F1) typeKind(xi) succeeds and returns a fully zonked kind + (F2) typeKind(xi) `eqType` zonk(typeKind(ty)) Note that it is rewrite's job to try to reduce *every type function it sees*. @@ -297,14 +313,14 @@ when (co :: ty ~ xi) is important even before we zonk the whole program. For example, see the RTRNotFollowed case in rewriteTyVar. -Why have these invariants on rewriting? Because we sometimes use tcTypeKind +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). 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: - (F2) zonk(tcTypeKind(ty)) `eqType` tcTypeKind(xi) + (F2) zonk(typeKind(ty)) `eqType` typeKind(xi) This invariant means that the kind of a rewritten type might not itself be rewritten. @@ -368,7 +384,7 @@ {-# INLINE rewrite_args_tc #-} rewrite_args_tc :: TyCon -- T - -> Maybe [Role] -- Nothing: ambient role is Nominal; all args are Nominal + -> Maybe (Infinite Role) -- Nothing: ambient role is Nominal; all args are Nominal -- Otherwise: no assumptions; use roles provided -> [Type] -> RewriteM ArgsReductions -- See the commentary on rewrite_args @@ -389,16 +405,16 @@ -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%. {-# INLINE rewrite_args #-} -rewrite_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are +rewrite_args :: [PiTyBinder] -> Bool -- Binders, and True iff any of them are -- named. -> Kind -> TcTyCoVarSet -- function kind; kind's free vars - -> Maybe [Role] -> [Type] -- these are in 1-to-1 correspondence + -> Maybe (Infinite Role) -> [Type] -- these are in 1-to-1 correspondence -- Nothing: use all Nominal -> RewriteM ArgsReductions -- This function returns ArgsReductions (Reductions cos xis) res_co -- coercions: co_i :: ty_i ~ xi_i, at roles given -- types: xi_i --- coercion: res_co :: tcTypeKind(fun tys) ~N tcTypeKind(fun xis) +-- coercion: res_co :: typeKind(fun tys) ~N typeKind(fun xis) -- That is, the result coercion relates the kind of some function (whose kind is -- passed as the first parameter) instantiated at tys to the kind of that -- function instantiated at the xis. This is useful in keeping rewriting @@ -413,7 +429,7 @@ = case (orig_m_roles, any_named_bndrs) of (Nothing, False) -> rewrite_args_fast orig_tys _ -> rewrite_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys - where orig_roles = fromMaybe (repeat Nominal) orig_m_roles + where orig_roles = fromMaybe (Inf.repeat Nominal) orig_m_roles {-# INLINE rewrite_args_fast #-} -- | fast path rewrite_args, in which none of the binders are named and @@ -437,11 +453,11 @@ {-# INLINE rewrite_args_slow #-} -- | Slow path, compared to rewrite_args_fast, because this one must track -- a lifting context. -rewrite_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet - -> [Role] -> [Type] +rewrite_args_slow :: [PiTyBinder] -> Kind -> TcTyCoVarSet + -> Infinite Role -> [Type] -> RewriteM ArgsReductions rewrite_args_slow binders inner_ki fvs roles tys - = do { rewritten_args <- zipWithM rw roles tys + = do { rewritten_args <- zipWithM rw (Inf.toList roles) tys ; return (simplifyArgsWorker binders inner_ki fvs roles rewritten_args) } where {-# INLINE rw #-} @@ -487,10 +503,8 @@ | isTypeFamilyTyCon tc = rewrite_fam_app tc tys - -- For * a normal data type application - -- * data family application - -- we just recursively rewrite the arguments. - | otherwise + | otherwise -- We just recursively rewrite the arguments. + -- See Note [Do not rewrite newtypes] = rewrite_ty_con_app tc tys rewrite_one (FunTy { ft_af = vis, ft_mult = mult, ft_arg = ty1, ft_res = ty2 }) @@ -587,9 +601,9 @@ = do { het_redn <- case tcSplitTyConApp_maybe fun_xi of Just (tc, xis) -> do { let tc_roles = tyConRolesRepresentational tc - arg_roles = dropList xis tc_roles + arg_roles = Inf.dropList xis tc_roles ; ArgsReductions (Reductions arg_cos arg_xis) kind_co - <- rewrite_vector (tcTypeKind fun_xi) arg_roles arg_tys + <- rewrite_vector (typeKind fun_xi) arg_roles arg_tys -- We start with a reduction of the form -- fun_co :: ty ~ T xi_1 ... xi_n @@ -606,9 +620,9 @@ app_co = case eq_rel of NomEq -> mkAppCos fun_co arg_cos ReprEq -> mkAppCos fun_co (map mkNomReflCo arg_tys) - `mkTcTransCo` - mkTcTyConAppCo Representational tc - (zipWith mkReflCo tc_roles xis ++ arg_cos) + `mkTransCo` + mkTyConAppCo Representational tc + (zipWith mkReflCo (Inf.toList tc_roles) xis ++ arg_cos) ; return $ mkHetReduction @@ -616,7 +630,7 @@ kind_co } Nothing -> do { ArgsReductions redns kind_co - <- rewrite_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys + <- rewrite_vector (typeKind fun_xi) (Inf.repeat Nominal) arg_tys ; return $ mkHetReduction (mkAppRedns fun_redn redns) kind_co } ; role <- getRole @@ -636,7 +650,7 @@ -- Rewrite a vector (list of arguments). rewrite_vector :: Kind -- of the function being applied to these arguments - -> [Role] -- If we're rewriting w.r.t. ReprEq, what roles do the + -> Infinite Role -- If we're rewriting w.r.t. ReprEq, what roles do the -- args have? -> [Type] -- the args to rewrite -> RewriteM ArgsReductions @@ -650,7 +664,13 @@ fvs = tyCoVarsOfType ki {-# INLINE rewrite_vector #-} -{- + +{- Note [Do not rewrite newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We flirted with unwrapping newtypes in the rewriter -- see GHC.Tc.Solver.Canonical +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! + Note [Rewriting synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Not expanding synonyms aggressively improves error messages, and @@ -1053,7 +1073,7 @@ -- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at -- least one named binder. -split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool) +split_pi_tys' :: Type -> ([PiTyBinder], Type, Bool) split_pi_tys' ty = split ty ty where -- put common cases first @@ -1064,20 +1084,20 @@ split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) = let -- See #19102 !(bs, ty, named) = split res res - in (Anon af (mkScaled w arg) : bs, ty, named) + in (Anon (mkScaled w arg) af : bs, ty, named) split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' split orig_ty _ = ([], orig_ty, False) {-# INLINE split_pi_tys' #-} --- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff +-- | Like 'tyConBindersPiTyBinders' but you also get a 'Bool' which is true iff -- there is at least one named binder. -ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool) +ty_con_binders_ty_binders' :: [TyConBinder] -> ([PiTyBinder], Bool) ty_con_binders_ty_binders' = foldr go ([], False) where go (Bndr tv (NamedTCB vis)) (bndrs, _) = (Named (Bndr tv vis) : bndrs, True) go (Bndr tv (AnonTCB af)) (bndrs, n) - = (Anon af (tymult (tyVarKind tv)) : bndrs, n) + = (Anon (tymult (tyVarKind tv)) af : bndrs, n) {-# INLINE go #-} {-# INLINE ty_con_binders_ty_binders' #-} 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 @@ -1,8 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | Utility types used within the constraint solver module GHC.Tc.Solver.Types ( -- Inert CDictCans diff --git a/GHC/Tc/TyCl.hs b/GHC/Tc/TyCl.hs --- a/GHC/Tc/TyCl.hs +++ b/GHC/Tc/TyCl.hs @@ -34,7 +34,8 @@ import GHC.Hs -import GHC.Tc.Errors.Types ( TcRnMessage(..), FixedRuntimeRepProvenance(..) ) +import GHC.Tc.Errors.Types ( TcRnMessage(..), FixedRuntimeRepProvenance(..) + , mkTcRnUnknownMessage, IllegalNewtypeReason (..) ) import GHC.Tc.TyCl.Build import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX , reportUnsolvedEqualities ) @@ -98,11 +99,14 @@ 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.Set as Set +import qualified Data.List.NonEmpty as NE import Data.Tuple( swap ) {- @@ -385,7 +389,7 @@ 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 determinded by its kind signature; +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 @@ -406,21 +410,27 @@ 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. + final TyCon. Here is the plan: - We first build a MonoTcTyCon, then generalise to a PolyTcTyCon - See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType - Specifically: + Step 1 (inferInitialKinds, inference only, skipped for checking): + Make a MonoTcTyCon whose binders are TcTyVars, + which may contain free unification variables - S1) In kcTyClGroup, we use checkInitialKinds to get the - utterly-final Kind of all TyCons in the group that - (a) have a 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. + Step 2 (generaliseTcTyCon) + Generalise that MonoTcTyCon to make a PolyTcTyCon + Its binders are skolem TcTyVars, with accurate SkolemInfo - S2) In kcTyClGroup, we use inferInitialKinds to look over the + 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. @@ -429,27 +439,30 @@ "mono" because it has not been been generalised, and its binders and result kind may have free unification variables. - S3) Still in kcTyClGroup, we use kcLTyClDecl to kind-check the + 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. - S4) Still in kcTyClGroup, we use generaliseTyClDecl to generalize - each MonoTcTyCon to get a PolyTcTyCon, with final TyVars in it, + 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. - S5) Finally, back in TcTyClDecls, we extend the environment with + 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. - These TcTyCons are stored in the local environment in GHC.Tc.TyCl, - until the real full TyCons can be created during desugaring. A - desugared program should never have a TcTyCon. + More details about /kind checking/ -3. A MonoTcTyCon can contain unification variables, but a PolyTcTyCon - does not: only skolem TcTyVars. + 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. -4. tyConScopedTyVars. A challenging piece in all of this is that we +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) @@ -624,7 +637,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In 'kcTyClGroup', there is a missed opportunity to make kind inference work in a few more cases. The idea is analogous -to Note [Single function non-recursive binding special-case]: +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 @@ -642,7 +655,7 @@ 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 sepearately. +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 @@ -968,7 +981,7 @@ around even between minor released. By forbidding visible type application, we ensure users aren't caught unawares. -Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep. +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? @@ -982,7 +995,7 @@ 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 depdendency order. + to put them in dependency order. 3. Required variables before a top-level :: 4. All variables after a top-level :: @@ -1051,7 +1064,7 @@ ~~~~~~~~~~~~~~~~~~~ * 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 compilicated; see #15592, comment:21ff. + 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 @@ -1282,9 +1295,15 @@ , tcdDataDefn = HsDataDefn { dd_cons = cons } }) = unitNameEnv name (APromotionErr TyConPE) `plusNameEnv` - mkNameEnv [ (con, APromotionErr RecDataConPE) - | L _ con' <- cons + 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) @@ -1352,14 +1371,13 @@ getInitialKind strategy (DataDecl { tcdLName = L _ name , tcdTyVars = ktvs - , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig - , dd_ND = new_or_data } }) - = do { let flav = newOrDataToFlavour new_or_data + , 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 new_or_data + Nothing -> return $ dataDeclDefaultResultKind strategy (dataDefnConsNewOrData cons) ; return [tc] } getInitialKind InitialKindInfer (FamDecl { tcdFam = decl }) @@ -1567,8 +1585,7 @@ -- - In this function, those TcTyVars are unified with other kind variables during -- kind inference (see [How TcTyCons work]) -kcTyClDecl (DataDecl { tcdLName = (L _ _name), tcdDataDefn = defn }) tycon - | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_ND = new_or_data } <- defn +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, @@ -1576,7 +1593,7 @@ -- (conceivably) shadowed. do { traceTc "kcTyClDecl" (ppr tycon $$ ppr (tyConTyVars tycon) $$ ppr (tyConResKind tycon)) ; _ <- tcHsContext ctxt - ; kcConDecls new_or_data (tyConResKind tycon) cons + ; kcConDecls (dataDefnConsNewOrData cons) (tyConResKind tycon) cons } kcTyClDecl (SynDecl { tcdLName = L _ _name, tcdRhs = rhs }) tycon @@ -1631,14 +1648,14 @@ RecConGADT (L _ flds) _ -> kcConArgTys new_or_data res_kind $ map (hsLinear . cd_fld_type . unLoc) flds -kcConDecls :: NewOrData +kcConDecls :: Foldable f + => NewOrData -> TcKind -- The result kind signature -- Used only in H98 case - -> [LConDecl GhcRn] -- The data constructors + -> f (LConDecl GhcRn) -- The data constructors -> TcM () -- See Note [kcConDecls: kind-checking data type decls] -kcConDecls new_or_data tc_res_kind cons - = mapM_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind)) cons +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 @@ -1655,7 +1672,7 @@ 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 [name]) $ + = addErrCtxt (dataConCtxt (NE.singleton name)) $ discardResult $ bindExplicitTKBndrs_Tv ex_tvs $ do { _ <- tcHsContext ex_ctxt @@ -1785,7 +1802,10 @@ 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} @@ -1817,7 +1837,7 @@ "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 elaboarate (T k f a). How can we get T's kind +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) @@ -1892,8 +1912,7 @@ is produced by processing the return kind in etaExpandAlgTyCon, called in tcDataDefn. - See also Note [TyConBinders for the result kind signatures of a data type] - in GHC.Tc.Gen.HsType. + 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 @@ -2312,7 +2331,7 @@ data family F a :: UnliftedType data instance F Int = TInt - The ommission of a kind signature for `F` should not mean a result kind + 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. @@ -2360,7 +2379,7 @@ , HsDataDefn { dd_derivs = derivs } <- dataDefn = [ DerivInfo { di_rep_tc = tycon , di_scoped_tvs = - if isFunTyCon tycon || isPrimTyCon tycon + if isPrimTyCon tycon then [] -- no tyConTyVars else mkTyVarNamePairs (tyConTyVars tycon) , di_clauses = derivs @@ -2414,15 +2433,15 @@ -> 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 $ \ binders res_kind -> + bindTyClTyVars class_name $ \ tc_bndrs res_kind -> do { checkClassKindSig res_kind - ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders) + ; 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 binders $ - -- The (binderVars binders) is needed bring into scope the + <- 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 @@ -2447,9 +2466,10 @@ -- 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 - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff + ; 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, @@ -2471,8 +2491,8 @@ | otherwise = Just (ctxt, at_stuff, sig_stuff, mindef) - ; clas <- buildClass class_name binders roles fds body - ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$ + ; clas <- buildClass class_name bndrs roles fds body + ; traceTc "tcClassDecl" (ppr fundeps $$ ppr bndrs $$ ppr fds) ; return clas } where @@ -2540,7 +2560,7 @@ = return Nothing -- No default declaration tcDefaultAssocDecl _ (d1:_:_) - = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ + = failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints $ text "More than one default declaration for" <+> ppr (tyFamInstDeclName (unLoc d1))) @@ -2586,7 +2606,7 @@ ]) ; let subst = case traverse getTyVar_maybe pats of Just cpt_tvs -> zipTvSubst cpt_tvs (mkTyVarTys fam_tvs) - Nothing -> emptyTCvSubst + 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 @@ -2701,7 +2721,7 @@ , fdResultSig = L _ sig , fdInjectivityAnn = inj }) | DataFamily <- fam_info - = bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do + = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do { traceTc "tcFamDecl1 data family:" (ppr tc_name) ; checkFamFlag tc_name @@ -2718,8 +2738,8 @@ -- See also Note [Datatype return kinds] ; checkDataKindSig DataFamilySort res_kind ; tc_rep_name <- newTyConRepName tc_name - ; let inj = Injective $ replicate (length binders) True - tycon = mkFamilyTyCon tc_name binders + ; let inj = Injective $ replicate (length tc_bndrs) True + tycon = mkFamilyTyCon tc_name tc_bndrs res_kind (resultVariableName sig) (DataFamilyTyCon tc_rep_name) @@ -2727,12 +2747,12 @@ ; return tycon } | OpenTypeFamily <- fam_info - = bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do + = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do { traceTc "tcFamDecl1 open type family:" (ppr tc_name) ; checkFamFlag tc_name - ; inj' <- tcInjectivity binders inj + ; inj' <- tcInjectivity tc_bndrs inj ; checkResultSigFlag tc_name sig -- check after injectivity for better errors - ; let tycon = mkFamilyTyCon tc_name binders res_kind + ; let tycon = mkFamilyTyCon tc_name tc_bndrs res_kind (resultVariableName sig) OpenSynFamilyTyCon parent inj' ; return tycon } @@ -2743,10 +2763,10 @@ 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', binders, res_kind) - <- bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> - do { inj' <- tcInjectivity binders inj - ; return (inj', binders, res_kind) } + ; (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 @@ -2755,14 +2775,14 @@ -- but eqns might be empty in the Just case as well ; case mb_eqns of Nothing -> - return $ mkFamilyTyCon tc_name binders res_kind + 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 binders res_kind + ; let tc_fam_tc = mkTcTyCon tc_name tc_bndrs res_kind noTcTyConScopedTyVars False {- this doesn't matter here -} ClosedTypeFamilyFlavour @@ -2781,7 +2801,7 @@ | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) - fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig) + 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 @@ -2827,7 +2847,7 @@ do { let tvs = binderVars tcbs ; dflags <- getDynFlags ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) - (TcRnUnknownMessage $ mkPlainError noHints $ + (mkTcRnUnknownMessage $ mkPlainError noHints $ text "Illegal injectivity annotation" $$ text "Use TypeFamilyDependencies to allow this") ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames @@ -2842,10 +2862,10 @@ tcTySynRhs :: RolesInfo -> Name -> LHsType GhcRn -> TcM TyCon tcTySynRhs roles_info tc_name hs_ty - = bindTyClTyVars tc_name $ \ binders res_kind -> + = 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 binders $ + ; 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 @@ -2859,11 +2879,11 @@ , ppr rhs_ty ] ) } ; doNotQuantifyTyVars dvs mk_doc - ; ze <- mkEmptyZonkEnv NoFlexi - ; (ze, binders) <- zonkTyVarBindersX ze binders - ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty + ; 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 binders res_kind roles rhs_ty) } + ; return (buildSynTyCon tc_name bndrs res_kind roles rhs_ty) } where skol_info = TyConSkol TypeSynonymFlavour tc_name @@ -2871,7 +2891,7 @@ -> 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_ND = new_or_data, dd_cType = cType + (HsDataDefn { dd_cType = cType , dd_ctxt = ctxt , dd_kindSig = mb_ksig -- Already in tc's kind -- via inferInitialKinds @@ -2883,12 +2903,12 @@ -- - 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 new_or_data ctxt cons + 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 new_or_data) res_kind + checkDataKindSig (DataDeclSort (dataDefnConsNewOrData cons)) res_kind ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $ tcHsContext ctxt @@ -2916,8 +2936,7 @@ ; res_kind <- zonkTcTypeToTypeX ze res_kind ; tycon <- fixM $ \ rec_tycon -> do - { data_cons <- tcConDecls new_or_data DDataType rec_tycon - tc_bndrs res_kind cons + { 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 @@ -2941,7 +2960,7 @@ ; return (tycon, [deriv_info]) } where skol_info = TyConSkol flav tc_name - flav = newOrDataToFlavour new_or_data + flav = newOrDataToFlavour (dataDefnConsNewOrData cons) -- Abstract data types in hsig files can have arbitrary kinds, -- because they may be implemented by type synonyms @@ -2951,23 +2970,22 @@ -- 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 [] = True + 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) _ [] + mk_tc_rhs (isHsBootOrSig -> True) _ (DataTypeCons _ []) = return AbstractTyCon - mk_tc_rhs _ tycon data_cons - = case new_or_data of - DataType -> return $ + 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 - NewType -> assert (not (null data_cons)) $ - mkNewTyConRhs tc_name tycon (head data_cons) + NewTypeCon data_con -> mkNewTyConRhs tc_name tycon data_con ------------------------- kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () @@ -3083,7 +3101,7 @@ 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-quantifed ones specially. Wrinkles: +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 @@ -3310,26 +3328,20 @@ ************************************************************************ -} -dataDeclChecks :: Name -> NewOrData - -> Maybe (LHsContext GhcRn) -> [LConDecl GhcRn] +dataDeclChecks :: Name + -> Maybe (LHsContext GhcRn) -> DataDefnCons (LConDecl GhcRn) -> TcM Bool -dataDeclChecks tc_name new_or_data mctxt cons +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 = consUseGadtSyntax cons + ; 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 a newtype has exactly one constructor - -- Do this before checking for empty data decls, so that - -- we don't suggest -XEmptyDataDecls for newtypes - ; checkTc (new_or_data == DataType || isSingleton cons) - (newtypeConError tc_name (length cons)) - -- 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 @@ -3340,12 +3352,6 @@ ----------------------------------- -consUseGadtSyntax :: [LConDecl GhcRn] -> Bool -consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True -consUseGadtSyntax _ = False - -- All constructors have same shape - ------------------------------------ data DataDeclInfo = DDataType -- data T a b = T1 a | T2 b | DDataInstance -- data instance D [a] = D1 a | D2 @@ -3358,19 +3364,30 @@ mkTyVarTys (binderVars tc_bndrs) DDataInstance header_ty -> header_ty -tcConDecls :: NewOrData - -> DataDeclInfo +-- 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 - -> [LConDecl GhcRn] -> TcM [DataCon] -tcConDecls new_or_data dd_info rep_tycon tmpl_bndrs res_kind - = concatMapM $ addLocMA $ - tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind - (mkTyConTagMap rep_tycon) + -> 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! @@ -3378,14 +3395,14 @@ -> TcKind -- Result kind -> NameEnv ConTag -> ConDecl GhcRn - -> TcM [DataCon] + -> 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 [lname]) $ + = addErrCtxt (dataConCtxt (NE.singleton lname)) $ do { -- NB: the tyvars from the declaration header are in scope -- Get hold of the existential type variables @@ -3414,8 +3431,8 @@ ; let tc_tvs = binderVars tc_bndrs fake_ty = mkSpecForAllTys tc_tvs $ mkInvisForAllTys exp_tvbndrs $ - mkPhiTy ctxt $ - mkVisFunTys arg_tys $ + 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 @@ -3473,7 +3490,7 @@ -- constructor type signature into the data constructor; -- that way checkValidDataCon can complain if it's wrong. - ; return [dc] } + ; 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, @@ -3484,7 +3501,7 @@ , con_res_ty = hs_res_ty }) = addErrCtxt (dataConCtxt names) $ do { traceTc "tcConDecl 1 gadt" (ppr names) - ; let (L _ name : _) = 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" $ @@ -3520,8 +3537,8 @@ ; tkvs <- kindGeneralizeAll skol_info (mkInvisForAllTys outer_tv_bndrs $ - mkPhiTy ctxt $ - mkVisFunTys arg_tys $ + tcMkPhiTy ctxt $ + tcMkScaledFunTys arg_tys $ res_ty) ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs) ; reportUnsolvedEqualities skol_info tkvs tclvl wanted @@ -3799,7 +3816,7 @@ [InvisTVBinder], -- The constructor's rejigged, user-written -- type variables [EqSpec], -- Equality predicates - TCvSubst) -- Substitution to apply to argument types + 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 @@ -3830,10 +3847,12 @@ -- 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 (getTyVar "rejigConRes" . substTyVar arg_subst) + subst_user_tvs = mapVarBndrs (substTyVarToTyVar arg_subst) substed_tvbndrs = subst_user_tvs dc_tvbndrs - substed_eqs = map (substEqSpec arg_subst) raw_eqs + 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) @@ -3848,7 +3867,7 @@ -- 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, [], emptyTCvSubst) + = (tc_tvs, dc_tvs `minusList` tc_tvs, dc_tvbndrs, [], emptySubst) where dc_tvs = binderVars dc_tvbndrs tc_tvs = binderVars tc_tvbndrs @@ -3996,28 +4015,28 @@ -- See Note [mkGADTVars]. mkGADTVars :: [TyVar] -- ^ The tycon vars -> [TyVar] -- ^ The datacon vars - -> TCvSubst -- ^ The matching between the template result type + -> Subst -- ^ The matching between the template result type -- and the actual result type -> ( [TyVar] - , [EqSpec] - , TCvSubst ) -- ^ The univ. variables, the GADT equalities, + , [(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` getTCvInScope subst - empty_subst = mkEmptyTCvSubst in_scope + `unionInScope` getSubstInScope subst + empty_subst = mkEmptySubst in_scope - choose :: [TyVar] -- accumulator of univ tvs, reversed - -> [EqSpec] -- accumulator of GADT equalities, reversed - -> TCvSubst -- template substitution - -> TCvSubst -- res. substitution + 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 - , [EqSpec] -- GADT equalities - , TCvSubst ) -- a substitution to fix kinds in ex_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) @@ -4028,6 +4047,8 @@ | 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') @@ -4037,13 +4058,19 @@ r_ty' = mkTyVarTy r_tv1 -- Not a simple substitution: make an equality predicate - _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs) + -- 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 - t_tv' = updateTyVarKind (substTy t_sub) t_tv + 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) @@ -4236,7 +4263,7 @@ ; ClosedSynFamilyTyCon Nothing -> return () ; AbstractClosedSynFamilyTyCon -> do { hsBoot <- tcIsHsBootOrSig - ; checkTc hsBoot $ TcRnUnknownMessage $ mkPlainError noHints $ + ; checkTc hsBoot $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "You may define an abstract closed type family" $$ text "only in a .hs-boot file" } ; DataFamilyTyCon {} -> return () @@ -4271,7 +4298,7 @@ -- The order of these equivalence classes might conceivably (non-deterministically) -- depend on the result of this comparison, but that just affects the order in which -- fields are checked for compatibility. It will not affect the compiled binary. - cmp_fld (f1,_) (f2,_) = flLabel f1 `uniqCompareFS` flLabel f2 + 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 @@ -4314,7 +4341,7 @@ checkPartialRecordField all_cons fld = setSrcSpan loc $ warnIf (not is_exhaustive && not (startsWithUnderscore occ_name)) - (TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialFields) noHints $ + (mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialFields) noHints $ sep [text "Use of partial record field selector" <> colon, nest 2 $ quotes (ppr occ_name)]) where @@ -4326,9 +4353,7 @@ is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field con1 = assert (not (null cons_with_field)) $ head cons_with_field - (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1 - eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) - inst_tys = substTyVars eq_subst univ_tvs + inst_tys = dataConResRepTyArgs con1 checkFieldCompat :: FieldLabelString -> DataCon -> DataCon -> Type -> Type -> Type -> Type -> TcM () @@ -4343,7 +4368,7 @@ checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () checkValidDataCon dflags existential_ok tc con = setSrcSpan con_loc $ - addErrCtxt (dataConCtxt [L (noAnnSrcSpan con_loc) con_name]) $ + 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 @@ -4351,15 +4376,15 @@ ; traceTc "checkValidDataCon" (vcat [ ppr con, ppr tc, ppr tc_tvs - , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl) - , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)]) + , 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 [rejigCon + -- 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 @@ -4414,21 +4439,28 @@ ; checkTc (existential_ok || isVanillaDataCon con) (badExistential con) - -- Check that UNPACK pragmas and bangs work out - -- E.g. reject data T = MkT {-# UNPACK #-} Int -- No "!" - -- data T = MkT {-# UNPACK #-} !a -- Can't unpack + -- 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 $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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 $ TcRnUnknownMessage $ + = addDiagnosticTc $ mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "UNPACK pragma lacks '!'")) -- Warn about a redundant ! on an unlifted type @@ -4437,13 +4469,20 @@ , 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 - , isSrcUnpacked want_unpack - , case rep_bang of { HsUnpack {} -> False; _ -> True } - -- If not optimising, we don't unpack (rep_bang is never - -- HsUnpack), so don't complain! This happens, e.g., in Haddock. - -- See dataConSrcToImplBang. - , not (bang_opt_unbox_disable bang_opts) + + -- 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 @@ -4451,7 +4490,7 @@ -- warn in this case (it gives users the wrong idea about whether -- or not UNPACK on abstract types is supported; it is!) , isHomeUnitDefinite (hsc_home_unit hsc_env) - = addDiagnosticTc $ TcRnUnknownMessage $ + = addDiagnosticTc $ mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "Ignoring unusable UNPACK pragma")) | otherwise @@ -4465,17 +4504,8 @@ -- checked here because we sometimes build invalid DataCons before -- erroring above here ; when debugIsOn $ - do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con - user_tvs = dataConUserTyVars con - user_tvbs_invariant - = Set.fromList (filterEqSpec eq_spec univs ++ exs) - == Set.fromList user_tvs - ; massertPpr user_tvbs_invariant - $ vcat ([ ppr con - , ppr univs - , ppr exs - , ppr eq_spec - , ppr user_tvs ]) } + massertPpr (checkDataConTyVars con) $ + ppr con $$ ppr (dataConFullSig con) $$ ppr (dataConUserTyVars con) ; traceTc "Done validity of data con" $ vcat [ ppr con @@ -4506,40 +4536,30 @@ ------------------------------- 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 { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) - -- One argument - - ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes - ; let allowedArgType = - unlifted_newtypes || typeLevity_maybe (scaledThing arg_ty1) == Just Lifted - ; checkTc allowedArgType $ TcRnUnknownMessage $ mkPlainError noHints $ vcat - [ text "A newtype cannot have an unlifted argument type" - , text "Perhaps you intended to use UnliftedNewtypes" - ] - ; show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags + = do { show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags - ; let check_con what msg = - checkTc what $ TcRnUnknownMessage $ mkPlainError noHints $ - (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)) + ; checkTc (isSingleton arg_tys) $ + TcRnIllegalNewtype con show_linear_types (DoesNotHaveSingleField $ length arg_tys) ; checkTc (ok_mult (scaledMult arg_ty1)) $ - TcRnUnknownMessage $ mkPlainError noHints $ text "A newtype constructor must be linear" + TcRnIllegalNewtype con show_linear_types IsNonLinear - ; check_con (null eq_spec) $ - text "A newtype constructor must have a return type of form T a1 ... an" - -- Return type is (T a b c) + ; checkTc (null eq_spec) $ + TcRnIllegalNewtype con show_linear_types IsGADT - ; check_con (null theta) $ - text "A newtype constructor cannot have a context in its type" + ; checkTc (null theta) $ + TcRnIllegalNewtype con show_linear_types HasConstructorContext - ; check_con (null ex_tvs) $ - text "A newtype constructor cannot have existential type variables" - -- No existentials + ; checkTc (null ex_tvs) $ + TcRnIllegalNewtype con show_linear_types HasExistentialTyVar - ; checkTc (all ok_bang (dataConSrcBangs con)) - (newtypeStrictError con) - -- No strictness annotations + ; checkTc (all ok_bang (dataConSrcBangs con)) $ + TcRnIllegalNewtype con show_linear_types HasStrictnessAnnotation } where (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) @@ -4551,9 +4571,8 @@ ok_bang (HsSrcBang _ _ SrcLazy) = False ok_bang _ = True - ok_mult One = True - ok_mult _ = False - + ok_mult OneTy = True + ok_mult _ = False ------------------------------- checkValidClass :: Class -> TcM () @@ -4580,7 +4599,7 @@ ; unless undecidable_super_classes $ case checkClassCycles cls of Just err -> setSrcSpan (getSrcSpan cls) $ - addErrTc (TcRnUnknownMessage $ mkPlainError noHints err) + addErrTc (mkTcRnUnknownMessage $ mkPlainError noHints err) Nothing -> return () -- Check the class operations. @@ -4615,7 +4634,7 @@ -- Test case: rep-poly/RepPolyClassMethod. ; unless constrained_class_methods $ - mapM_ check_constraint (tail (cls_pred:op_theta)) + mapM_ check_constraint op_theta ; check_dm ctxt sel_id cls_pred tau2 dm } @@ -4723,7 +4742,7 @@ -- default foo2 :: a -> b unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty] [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $ - TcRnUnknownMessage $ mkPlainError noHints $ + mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "The default type signature for" <+> ppr sel_id <> colon) 2 (ppr dm_ty) @@ -4743,14 +4762,14 @@ ; checkTc idx_tys err_msg } where err_msg :: TcRnMessage - err_msg = TcRnUnknownMessage $ mkPlainError noHints $ + 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 $ TcRnUnknownMessage $ mkPlainError noHints $ + ; 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 @@ -4861,6 +4880,31 @@ 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: @@ -5008,7 +5052,7 @@ 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) } + 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) @@ -5068,7 +5112,7 @@ check_ty_roles env role ty report_error doc - = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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"] @@ -5089,8 +5133,7 @@ -- See Note [Inferring visible dependent quantification] -- Only types without a signature (CUSK or SAK) here addVDQNote tycon thing_inside - | assertPpr (isTcTyCon tycon) (ppr tycon) $ - assertPpr (not (tcTyConIsPoly tycon)) (ppr tycon $$ ppr tc_kind) + | assertPpr (isMonoTcTyCon tycon) (ppr tycon $$ ppr tc_kind) has_vdq = addLandmarkErrCtxt vdq_warning thing_inside | otherwise @@ -5152,24 +5195,24 @@ resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage resultTypeMisMatch field_name con1 con2 - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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 - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, text "give different types for field", quotes (ppr field_name)] -dataConCtxt :: [LocatedN Name] -> SDoc -dataConCtxt cons = text "In the definition of data constructor" <> plural cons - <+> ppr_cons cons +dataConCtxt :: NonEmpty (LocatedN Name) -> SDoc +dataConCtxt cons = text "In the definition of data constructor" <> plural (toList cons) + <+> ppr_cons (toList cons) -dataConResCtxt :: [LocatedN Name] -> SDoc -dataConResCtxt cons = text "In the result type of data constructor" <> plural cons - <+> ppr_cons 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) @@ -5184,20 +5227,20 @@ | n == 0 = mkErr "No" "no-parameter" | otherwise = mkErr "Too many" "multi-parameter" where - mkErr howMany allowWhat = TcRnUnknownMessage $ mkPlainError noHints $ + 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 - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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 - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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") @@ -5205,14 +5248,14 @@ noClassTyVarErr :: Class -> TyCon -> TcRnMessage noClassTyVarErr clas fam_tc - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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 - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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)) @@ -5221,13 +5264,13 @@ badGadtDecl :: Name -> TcRnMessage badGadtDecl tc_name - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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 - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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") @@ -5236,43 +5279,31 @@ badStupidTheta :: Name -> TcRnMessage badStupidTheta tc_name - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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 - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sep [text "A newtype must have exactly one constructor,", nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] -newtypeStrictError :: DataCon -> TcRnMessage -newtypeStrictError con - = TcRnUnknownMessage $ mkPlainError noHints $ - sep [text "A newtype constructor cannot have a strictness annotation,", - nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"] - -newtypeFieldErr :: DataCon -> Int -> TcRnMessage -newtypeFieldErr con_name n_flds - = TcRnUnknownMessage $ mkPlainError noHints $ - sep [text "The constructor of a newtype must have exactly one field", - nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds] - badSigTyDecl :: Name -> TcRnMessage badSigTyDecl tc_name - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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 - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ sep [quotes (ppr tycon) <+> text "has no constructors", nest 2 $ text "(EmptyDataDecls permits this)"] wrongKindOfFamily :: TyCon -> TcRnMessage wrongKindOfFamily family - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Wrong category of family instance; declaration was for a" <+> kindOfFamily where @@ -5285,13 +5316,13 @@ -- See Note [Oversaturated type family equations] in "GHC.Tc.Validity". wrongNumberOfParmsErr :: Arity -> TcRnMessage wrongNumberOfParmsErr max_args - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Number of parameters must match family declaration; expected" <+> ppr max_args badRoleAnnot :: Name -> Role -> Role -> TcRnMessage badRoleAnnot var annot inferred - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Role mismatch on variable" <+> ppr var <> colon) 2 (sep [ text "Annotation says", ppr annot , text "but role", ppr inferred @@ -5299,7 +5330,7 @@ wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> TcRnMessage wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots)) - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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) @@ -5310,25 +5341,25 @@ illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _)) = setErrCtxt [] $ setSrcSpanA loc $ - addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $ + 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 - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ text "Illegal role annotation for" <+> ppr tc <> char ';' $$ text "did you intend to use RoleAnnotations?" incoherentRoles :: TcRnMessage -incoherentRoles = TcRnUnknownMessage $ mkPlainError noHints $ +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 - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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 ]) 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 @@ -18,26 +18,29 @@ import GHC.Prelude import GHC.Iface.Env -import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) import GHC.Builtin.Types( isCTupleTyConName, unboxedUnitTy ) + +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad + import GHC.Core.DataCon import GHC.Core.PatSyn +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) + +import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Id.Make -import GHC.Core.Class -import GHC.Core.TyCon -import GHC.Core.Type import GHC.Types.SourceText -import GHC.Tc.Utils.TcType -import GHC.Core.Multiplicity - -import GHC.Types.SrcLoc( SrcSpan, noSrcSpan ) -import GHC.Tc.Utils.Monad import GHC.Types.Unique.Supply + import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -175,7 +178,7 @@ data_con = mkDataCon src_name declared_infix prom_info src_bangs field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt - arg_tys res_ty NoRRI rep_tycon tag + 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) @@ -320,22 +323,20 @@ -- (We used to call them D_C, but now we can have two different -- superclasses both called C!) - ; let use_newtype = isSingleton arg_tys + ; 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] - - -- We treat the dictionary superclasses as ordinary arguments. - -- That means that in the case of + -- + -- In the case of -- class C a => D a - -- we don't get a newtype with no arguments! + -- we use a newtype, but with one superclass and no arguments args = sc_sel_names ++ op_names op_tys = [ty | (_,ty,_) <- sig_stuff] op_names = [op | (op,_,_) <- sig_stuff] - arg_tys = sc_theta ++ op_tys rec_tycon = classTyCon rec_clas univ_bndrs = tyConInvisTVBinders binders univ_tvs = binderVars univ_bndrs @@ -353,8 +354,8 @@ [{- no existentials -}] univ_bndrs [{- No GADT equalities -}] - [{- No theta -}] - (map unrestricted arg_tys) -- type classes are unrestricted + sc_theta + (map unrestricted op_tys) -- type classes are unrestricted (mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) rec_tycon (mkTyConTagMap rec_tycon) 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 @@ -18,12 +18,10 @@ , tcClassMinimalDef , HsSigFun , mkHsSigFun - , badMethodErr , instDeclCtxt1 , instDeclCtxt2 , instDeclCtxt3 , tcATDefault - , substATBndrs ) where @@ -39,7 +37,7 @@ import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType -import GHC.Core.Type ( extendTvSubstWithClone, piResultTys ) +import GHC.Core.Type ( piResultTys ) import GHC.Core.Predicate import GHC.Core.Multiplicity import GHC.Tc.Types.Origin @@ -57,7 +55,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Var -import GHC.Types.Var.Env ( lookupVarEnv ) +import GHC.Types.Var.Env import GHC.Types.SourceFile (HscSource(..)) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -71,6 +69,7 @@ import Control.Monad import Data.List ( mapAccumL, partition ) +import qualified Data.List.NonEmpty as NE {- Dictionary handling @@ -100,7 +99,7 @@ newtype CDict a = CDict (forall b. a -> b -> b) -Now DictTy in Type is just a form of type synomym: +Now DictTy in Type is just a form of type synonym: DictTy c t = TyConTy CDict `AppTy` t Death to "ExpandingDicts". @@ -113,10 +112,6 @@ ************************************************************************ -} -illegalHsigDefaultMethod :: Name -> TcRnMessage -illegalHsigDefaultMethod n = TcRnUnknownMessage $ mkPlainError noHints $ - text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file" - tcClassSigs :: Name -- Name of the class -> [LSig GhcRn] -> LHsBinds GhcRn @@ -131,7 +126,7 @@ ; op_info <- concatMapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ] - ; sequence_ [ failWithTc (badMethodErr clas n) + ; sequence_ [ failWithTc (TcRnBadMethodErr clas n) | n <- dm_bind_names, not (n `elemNameSet` op_names) ] -- Value binding for non class-method (ie no TypeSig) @@ -142,11 +137,12 @@ -- (Generic signatures without value bindings indicate -- that a default of this form is expected to be -- provided.) - when (not (null def_methods)) $ - failWithTc (illegalHsigDefaultMethod clas) + case bagToList def_methods of + [] -> return () + meth : meths -> failWithTc (TcRnIllegalHsigDefaultMethods clas (meth NE.:| meths)) else -- Error for each generic signature without value binding - sequence_ [ failWithTc (badGenericMethod clas n) + sequence_ [ failWithTc (TcRnBadGenericMethod clas n) | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] ; traceTc "tcClassSigs 2" (ppr clas) @@ -237,7 +233,7 @@ tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing) = do { -- No default method - mapM_ (addLocMA (badDmPrag sel_id)) + mapM_ (addLocMA (badDmPrag sel_id )) (lookupPragEnv prag_fn (idName sel_id)) ; return emptyBag } @@ -263,9 +259,8 @@ ; spec_prags <- discardConstraints $ tcSpecPrags global_dm_id prags - ; let dia = TcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints $ - (text "Ignoring SPECIALISE pragmas on default method" <+> quotes (ppr sel_name)) + ; let dia = TcRnIgnoreSpecialisePragmaOnDefMethod sel_name + ; diagnosticTc (not (null spec_prags)) dia ; let hs_ty = hs_sig_fn sel_name @@ -295,7 +290,7 @@ ctxt = FunSigCtxt sel_name warn_redundant - ; let local_dm_id = mkLocalId local_dm_name Many local_dm_ty + ; 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 } @@ -341,7 +336,7 @@ -- since you can't write a default implementation. when (tcg_src tcg_env /= HsigFile) $ whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $ - (\bf -> addDiagnosticTc (warningMinimalDefIncomplete bf)) + (\bf -> addDiagnosticTc (TcRnWarningMinimalDefIncomplete bf)) return mindef where -- By default require all methods without a default implementation @@ -404,7 +399,7 @@ findMinimalDef = firstJusts . map toMinimalDef where toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef - toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf) + toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf) toMinimalDef _ = Nothing {- @@ -442,18 +437,6 @@ ************************************************************************ -} -badMethodErr :: Outputable a => a -> Name -> TcRnMessage -badMethodErr clas op - = TcRnUnknownMessage $ mkPlainError noHints $ - hsep [text "Class", quotes (ppr clas), - text "does not have a method", quotes (ppr op)] - -badGenericMethod :: Outputable a => a -> Name -> TcRnMessage -badGenericMethod clas op - = TcRnUnknownMessage $ mkPlainError noHints $ - hsep [text "Class", quotes (ppr clas), - text "has a generic-default signature without a binding", quotes (ppr op)] - {- badGenericInstanceType :: LHsBinds Name -> SDoc badGenericInstanceType binds @@ -473,19 +456,10 @@ where ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) -} + badDmPrag :: TcId -> Sig GhcRn -> TcM () badDmPrag sel_id prag - = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ - text "The" <+> hsSigDoc prag <+> text "for default method" - <+> quotes (ppr sel_id) - <+> text "lacks an accompanying binding") - -warningMinimalDefIncomplete :: ClassMinimalDef -> TcRnMessage -warningMinimalDefIncomplete mindef - = TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $ - vcat [ text "The MINIMAL pragma does not require:" - , nest 2 (pprBooleanFormulaNice mindef) - , text "but there is no default implementation." ] + = addErrTc (TcRnDefaultMethodForPragmaLacksBinding sel_id prag) instDeclCtxt1 :: LHsSigType GhcRn -> SDoc instDeclCtxt1 hs_inst_ty @@ -506,7 +480,7 @@ 2 (quotes doc) tcATDefault :: SrcSpan - -> TCvSubst + -> Subst -> NameSet -> ClassATItem -> TcM [FamInst] @@ -523,7 +497,8 @@ -- instance C [x] -- Then we want to generate the decl: type F [x] b = () | Just (rhs_ty, _loc) <- defs - = do { let (subst', pat_tys') = substATBndrs inst_subst (tyConTyVars fam_tc) + = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst + (tyConTyVars fam_tc) rhs' = substTyUnchecked subst' rhs_ty tcv' = tyCoVarsOfTypesList pat_tys' (tv', cv') = partition isTyVar tcv' @@ -546,73 +521,14 @@ | otherwise -- defs = Nothing = do { warnMissingAT (tyConName fam_tc) ; return [] } - --- | Apply a substitution to the type variable binders of an associated type --- family. This is used to compute default instances for associated type --- families (see 'tcATDefault') as well as @newtype@-derived associated type --- family instances (see @gen_Newtype_fam_insts@ in "GHC.Tc.Deriv.Generate"). --- --- As a concrete example, consider the following class and associated type --- family: --- --- @ --- class C k (a :: k) where --- type F k a (b :: k) :: Type --- type F j p q = (Proxy @j p, Proxy @j (q :: j)) --- @ --- --- If a user defines this instance: --- --- @ --- instance C (Type -> Type) Maybe where {} --- @ --- --- Then in order to typecheck the default @F@ instance, we must apply the --- substitution @[k :-> (Type -> Type), a :-> Maybe]@ to @F@'s binders, which --- are @[k, a, (b :: k)]@. The result should look like this: --- --- @ --- type F (Type -> Type) Maybe (b :: Type -> Type) = --- (Proxy @(Type -> Type) Maybe, Proxy @(Type -> Type) (b :: Type -> Type)) --- @ --- --- Making this work requires some care. There are two cases: --- --- 1. If we encounter a type variable in the domain of the substitution (e.g., --- @k@ or @a@), then we apply the substitution directly. --- --- 2. Otherwise, we substitute into the type variable's kind (e.g., turn --- @b :: k@ to @b :: Type -> Type@). We then return an extended substitution --- where the old @b@ (of kind @k@) maps to the new @b@ (of kind @Type -> Type@). --- --- This step is important to do in case there are later occurrences of @b@, --- which we must ensure have the correct kind. Otherwise, we might end up --- with @Proxy \@(Type -> Type) (b :: k)@ on the right-hand side of the --- default instance, which would be completely wrong. --- --- Contrast 'substATBndrs' function with similar substitution functions: --- --- * 'substTyVars' does not substitute into the kinds of each type variable, --- nor does it extend the substitution. 'substTyVars' is meant for occurrences --- of type variables, whereas 'substATBndr's is meant for binders. --- --- * 'substTyVarBndrs' does substitute into kinds and extends the substitution, --- but it does not apply the substitution to the variables themselves. As --- such, 'substTyVarBndrs' returns a list of 'TyVar's rather than a list of --- 'Type's. -substATBndrs :: TCvSubst -> [TyVar] -> (TCvSubst, [Type]) -substATBndrs = mapAccumL substATBndr where - substATBndr :: TCvSubst -> TyVar -> (TCvSubst, Type) - substATBndr subst tc_tv - -- Case (1) in the Haddocks + subst_tv subst tc_tv | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv = (subst, ty) - -- Case (2) in the Haddocks | otherwise - = (extendTvSubstWithClone subst tc_tv tc_tv', mkTyVarTy tc_tv') + = (extendTvSubst subst tc_tv ty', ty') where - tc_tv' = updateTyVarKind (substTy subst) tc_tv + ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv) warnMissingAT :: Name -> TcM () warnMissingAT name @@ -622,10 +538,6 @@ -- 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 = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints $ - (text "No explicit" <+> text "associated type" - <+> text "or default declaration for" - <+> quotes (ppr name)) + ; let dia = TcRnNoExplicitAssocTypeOrDefaultDeclaration name ; diagnosticTc (warn && hsc_src == HsSrcFile) dia } diff --git a/GHC/Tc/TyCl/Instance.hs b/GHC/Tc/TyCl/Instance.hs --- a/GHC/Tc/TyCl/Instance.hs +++ b/GHC/Tc/TyCl/Instance.hs @@ -8,7 +8,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | Typechecking instance declarations @@ -27,8 +26,8 @@ import GHC.Tc.TyCl import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv ) import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault, - HsSigFun, mkHsSigFun, badMethodErr, - findMethodBind, instantiateMethod ) + HsSigFun, mkHsSigFun, findMethodBind, + instantiateMethod ) import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) import GHC.Tc.Gen.Sig import GHC.Tc.Utils.Monad @@ -79,10 +78,9 @@ import GHC.Types.Name.Set import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Utils.Misc -import GHC.Data.BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) +import GHC.Data.BooleanFormula ( isUnsatisfied ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad @@ -176,7 +174,7 @@ inline df_i in it, and that in turn means that (since it'll be a loop-breaker because df_i isn't), op1_i will ironically never be inlined. But this is OK: the recursion breaking happens by way of - a RULE (the magic ClassOp rule above), and RULES work inside InlineRule + a RULE (the magic ClassOp rule above), and RULES work inside stable unfoldings. See Note [RULEs enabled in InitialPhase] in GHC.Core.Opt.Simplify.Utils Note [ClassOp/DFun selection] @@ -492,15 +490,15 @@ do { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty -- NB: tcHsClsInstType does checkValidInstance - ; skol_info <- mkSkolemInfo InstSkol + ; skol_info <- mkSkolemInfo (mkClsInstSkol clas inst_tys) ; (subst, skol_tvs) <- tcInstSkolTyVars skol_info tyvars ; let tv_skol_prs = [ (tyVarName tv, skol_tv) | (tv, skol_tv) <- tyvars `zip` skol_tvs ] -- Map from the skolemized Names to the original Names. -- See Note [Associated data family instances and di_scoped_tvs]. tv_skol_env = mkVarEnv $ map swap tv_skol_prs - n_inferred = countWhile ((== Inferred) . binderArgFlag) $ - fst $ splitForAllTyCoVarBinders dfun_ty + n_inferred = countWhile ((== Inferred) . binderFlag) $ + 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) @@ -592,7 +590,7 @@ -- (0) Check it's an open type family ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc) + ; checkTc (isOpenTypeFamilyTyCon fam_tc) (TcRnNotOpenFamily fam_tc) -- (1) do the work of verifying the synonym group -- For some reason we don't have a location for the equation @@ -619,16 +617,16 @@ ; traceTc "tcFamInstDecl" (ppr fam_tc) ; type_families <- xoptM LangExt.TypeFamilies ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file? - ; checkTc type_families $ badFamInstDecl fam_tc - ; checkTc (not is_boot) $ badBootFamInstDeclErr + ; checkTc type_families (TcRnBadFamInstDecl fam_tc) + ; checkTc (not is_boot) TcRnBadBootFamInstDecl -- Check that it is a family TyCon, and that -- oplevel type instances are not for associated types. - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) + ; checkTc (isFamilyTyCon fam_tc) (TcRnIllegalFamilyInstance fam_tc) ; when (isNotAssociated mb_clsinfo && -- Not in a class decl isTyConAssoc fam_tc) -- but an associated type - (addErr $ assocInClassErr fam_tc) + (addErr $ TcRnMissingClassAssoc fam_tc) } {- Note [Associated type instances] @@ -674,8 +672,7 @@ , feqn_pats = hs_pats , feqn_tycon = lfam_name@(L _ fam_name) , feqn_fixity = fixity - , feqn_rhs = HsDataDefn { dd_ND = new_or_data - , dd_cType = cType + , feqn_rhs = HsDataDefn { dd_cType = cType , dd_ctxt = hs_ctxt , dd_cons = hs_cons , dd_kindSig = m_ksig @@ -688,10 +685,11 @@ -- Check that the family declaration is for the right kind ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons + ; 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) <- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity hs_ctxt hs_pats m_ksig new_or_data @@ -767,19 +765,18 @@ do { data_cons <- tcExtendTyVarEnv (binderVars tc_ty_binders) $ -- For H98 decls, the tyvars scope -- over the data constructors - tcConDecls new_or_data (DDataInstance orig_res_ty) - rec_rep_tc tc_ty_binders tc_res_kind - hs_cons + tcConDecls (DDataInstance orig_res_ty) rec_rep_tc tc_ty_binders tc_res_kind + hs_cons ; rep_tc_name <- newFamInstTyConName lfam_name pats ; axiom_name <- newFamInstAxiomName lfam_name [pats] - ; tc_rhs <- case new_or_data of - DataType -> return $ + ; tc_rhs <- case data_cons of + DataTypeCons type_data data_cons -> return $ mkLevPolyDataTyConRhs (isFixedRuntimeRepKind res_kind) + type_data data_cons - NewType -> assert (not (null data_cons)) $ - mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) + NewTypeCon data_con -> mkNewTyConRhs rep_tc_name rec_rep_tc data_con ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys zonked_post_eta_qtvs) axiom = mkSingleCoAxiom Representational axiom_name @@ -893,7 +890,6 @@ -> NewOrData -> TcM ([TcTyVar], [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 ... @@ -944,7 +940,7 @@ -- clearer to duplicate it. Still, if you fix a bug here, -- check there too! - -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts] + -- See GHC.Tc.TyCl Note [Generalising in tcTyFamInstEqnGuts] ; dvs <- candidateQTyVarsWithBinders outer_tvs lhs_ty ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs ; let final_tvs = scopedSort (qtvs ++ outer_tvs) @@ -1099,7 +1095,7 @@ Now the subtleties of Note [Newtype eta and homogeneous axioms] are dealt with by the newtype (via mkNewTyConRhs called in tcDataFamInstDecl) while the axiom connecting F Int ~ R:FIntb is eta-reduced, but the - quantifer 'b' is derived from the original data family F, and so the + quantifier 'b' is derived from the original data family F, and so the kinds will always match. Note [Kind inference for data family instances] @@ -1132,7 +1128,7 @@ So what kind do 'p' and 'q' have? No clues from the header, but from the data constructor we can clearly see that (r :: Type->Type). Does -that mean that the the /entire data instance/ is instantiated at Type, +that mean that the /entire data instance/ is instantiated at Type, like this? data instance T @Type (p :: Type->Type) (q :: Type) where ... @@ -1232,19 +1228,14 @@ tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc) -- Returns a binding for the dfun tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) - = recoverM (return emptyLHsBinds) $ - setSrcSpan loc $ - addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ + = recoverM (return emptyLHsBinds) $ + setSrcSpan loc $ + addErrCtxt (instDeclCtxt2 dfun_ty) $ do { -- Instantiate the instance decl with skolem constants - ; skol_info <- mkSkolemInfo InstSkol - ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType skol_info dfun_id + (skol_info, inst_tyvars, dfun_theta, clas, inst_tys) <- tcSkolDFunType dfun_ty ; dfun_ev_vars <- newEvVars dfun_theta - -- We instantiate the dfun_id with superSkolems. - -- See Note [Subtle interaction of recursion and overlap] - -- and Note [Binding when looking up instances] - ; let (clas, inst_tys) = tcSplitDFunHead inst_head - (class_tyvars, sc_theta, _, op_items) = classBigSig clas + ; let (class_tyvars, sc_theta, _, op_items) = classBigSig clas sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta']) @@ -1260,13 +1251,12 @@ ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics)) <- pushTcLevelM $ do { (sc_ids, sc_binds, sc_implics) - <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars - inst_tys dfun_ev_binds - sc_theta' + <- tcSuperClasses skol_info dfun_id clas inst_tyvars + dfun_ev_vars dfun_ev_binds sc_theta' -- Typecheck the methods ; (meth_ids, meth_binds, meth_implics) - <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars + <- tcMethods skol_info dfun_id clas inst_tyvars dfun_ev_vars inst_tys dfun_ev_binds spec_inst_info op_items ibinds @@ -1281,13 +1271,13 @@ , ic_given = dfun_ev_vars , ic_wanted = mkImplicWC sc_meth_implics , ic_binds = dfun_ev_binds_var - , ic_info = InstSkol } + , ic_info = skol_info } -- Create the result bindings ; self_dict <- newDict clas inst_tys ; let class_tc = classTyCon clas loc' = noAnnSrcSpan loc - [dict_constr] = tyConDataCons class_tc + dict_constr = tyConSingleDataCon class_tc dict_bind = mkVarBind self_dict (L loc' con_app_args) -- We don't produce a binding for the dict_constr; instead we @@ -1339,6 +1329,7 @@ } where dfun_id = instanceDFunId ispec + dfun_ty = idType dfun_id loc = getSrcSpan dfun_id addDFunPrags :: DFunId -> [Id] -> DFunId @@ -1353,7 +1344,7 @@ -- is messing with. addDFunPrags dfun_id sc_meth_ids | is_newtype - = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 defaultSimpleOpts con_app + = 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 @@ -1371,7 +1362,7 @@ ev_ids = mkTemplateLocalsNum 1 dfun_theta dfun_bndrs = dfun_tvs ++ ev_ids clas_tc = classTyCon clas - [dict_con] = tyConDataCons clas_tc + dict_con = tyConSingleDataCon clas_tc is_newtype = isNewTyCon clas_tc wrapId :: HsWrapper -> Id -> HsExpr GhcTc @@ -1446,7 +1437,8 @@ ************************************************************************ -} -tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] +tcSuperClasses :: SkolemInfoAnon -> DFunId -> Class -> [TcTyVar] + -> [EvVar] -> TcEvBinds -> TcThetaType -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication) @@ -1458,22 +1450,22 @@ -- See Note [Recursive superclasses] for why this is so hard! -- In effect, we build a special-purpose solver for the first step -- of solving each superclass constraint -tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta +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) } where loc = getSrcSpan dfun_id - size = sizeTypes inst_tys tc_super (sc_pred, n) = do { (sc_implic, ev_binds_var, sc_ev_tm) - <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred + <- checkInstConstraints skol_info $ + emitWanted (ScOrigin IsClsInst NakedSc) sc_pred + -- ScOrigin IsClsInst True: see Note [Solving superclass constraints] ; 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 - ; let sc_top_ty = mkInfForAllTys tyvars $ - mkPhiTy (map idType dfun_evs) sc_pred - sc_top_id = mkLocalId sc_top_name Many sc_top_ty + ; 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 , abe_poly = sc_top_id , abe_mono = sc_ev_id @@ -1489,10 +1481,10 @@ ; return (sc_top_id, L (noAnnSrcSpan loc) bind, sc_implic) } ------------------- -checkInstConstraints :: TcM result +checkInstConstraints :: SkolemInfoAnon -> TcM result -> TcM (Implication, EvBindsVar, result) -- See Note [Typechecking plan for instance declarations] -checkInstConstraints thing_inside +checkInstConstraints skol_info thing_inside = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $ thing_inside @@ -1501,7 +1493,7 @@ ; let implic' = implic { ic_tclvl = tclvl , ic_wanted = wanted , ic_binds = ev_binds_var - , ic_info = InstSkol } + , ic_info = skol_info } ; return (implic', ev_binds_var, result) } @@ -1554,82 +1546,134 @@ To achieve the Superclass Invariant, in a dfun definition we can generate a guaranteed-non-bottom superclass witness from: (sc1) one of the dictionary arguments itself (all non-bottom) - (sc2) an immediate superclass of a smaller dictionary + (sc2) an immediate superclass of a non-bottom dictionary that is + /Paterson-smaller/ than the instance head + See Note [The PatersonSize of a type] in GHC.Tc.Utils.TcType (sc3) a call of a dfun (always returns a dictionary constructor) -The tricky case is (sc2). We proceed by induction on the size of -the (type of) the dictionary, defined by GHC.Tc.Validity.sizeTypes. -Let's suppose we are building a dictionary of size 3, and -suppose the Superclass Invariant holds of smaller dictionaries. -Then if we have a smaller dictionary, its immediate superclasses -will be non-bottom by induction. +The tricky case is (sc2). We proceed by induction on the size of the +(type of) the dictionary, defined by GHC.Tc.Utils.TcType.pSizeType. Let's +suppose we are building a dictionary of size 3 (the "head"), and suppose +the Superclass Invariant holds of smaller dictionaries. Then if we have a +smaller dictionary, its immediate superclasses will be non-bottom by +induction. -What does "we have a smaller dictionary" mean? It might be -one of the arguments of the instance, or one of its superclasses. +Why "Paterson-smaller"? See Note [Paterson conditions] in GHC.Tc.Validity. +We want to be sure that the superclass dictionary is smaller /for any +ground instatiation/ of the instance, so we need to account for type +variables that occur more than once, and for type families (#20666). And +that's exactly what the Paterson conditions check! + Here is an example, taken from CmmExpr: class Ord r => UserOfRegs r a where ... (i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where (i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where -For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a), -since it is smaller than the thing we are building (UserOfRegs r (Maybe a). +For (i1) we can get the (Ord r) superclass by selection from +(UserOfRegs r a), since it (i.e. UserOfRegs r a) is smaller than the +thing we are building, namely (UserOfRegs r (Maybe a)). -But for (i2) that isn't the case, so we must add an explicit, and -perhaps surprising, (Ord r) argument to the instance declaration. +But for (i2) that isn't the case: (UserOfRegs r CmmReg) is not smaller +than the thing we are building (UserOfRegs r CmmExpr), so we can't use +the superclasses of the former. Hence we must instead add an explicit, +and perhaps surprising, (Ord r) argument to the instance declaration. Here's another example from #6161: - class Super a => Duper a where ... - class Duper (Fam a) => Foo a where ... -(i3) instance Foo a => Duper (Fam a) where ... -(i4) instance Foo Float where ... + class Super a => Duper a where ... + class Duper (Maybe a) => Foo a where ... +(i3) instance Foo a => Duper (Maybe a) where ... +(i4) instance Foo Float where ... It would be horribly wrong to define - dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3) - dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ... + dfDuperMaybe :: Foo a -> Duper (Maybe a) -- from (i3) + dfDuperMaybe d = MkDuper (sc_sel1 (sc_sel2 d)) ... dfFooFloat :: Foo Float -- from (i4) - dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ... + dfFooFloat = MkFoo (dfDuperMaybe dfFooFloat) ... -Now the Super superclass of Duper is definitely bottom! +Let's expand the RHS of dfFooFloat: + dfFooFloat = MkFoo (MkDuper (sc_sel1 (sc_sel2 dfFooFloat)) ...) ... +That superclass argument to MkDuper is bottom! -This won't happen because when processing (i3) we can use the -superclasses of (Foo a), which is smaller, namely Duper (Fam a). But -that is *not* smaller than the target so we can't take *its* -superclasses. As a result the program is rightly rejected, unless you -add (Super (Fam a)) to the context of (i3). +This program gets rejected because: +* When processing (i3) we need to construct a dictionary for Super + (Maybe a), to put in the superclass field of (Duper (Maybe a)). +* We /can/ use the superclasses of (Foo a), because the latter is + smaller than the head of the instance, namely Duper (Maybe a). +* So we know (by (sc2)) that this Duper (Maybe a) dictionary is + non-bottom. But because (Duper (Maybe a)) is not smaller than the + instance head (Duper (Maybe a)), we can't take *its* superclasses. +As a result the program is rightly rejected, unless you add +(Super (Maybe a)) to the context of (i3). +Wrinkle (W1): + (sc2) says we only get a non-bottom dict if the dict we are + selecting from is itself non-bottom. So in a superclass chain, + all the dictionaries in the chain must be non-bottom. + class C a => D3 a + class D2 a [[Maybe b]] => D1 a b + class D3 a => D2 a b + class C a => E a b + instance D1 a b => E a [b] + The instance needs the wanted superclass (C a). We can get it + by superclass selection from + D1 a b --> D2 a [[Maybe b]] --> D3 a --> C a + But on the way we go through the too-big (D2 a [[Maybe b]]), and + we don't know that is non-bottom. + Note [Solving superclass constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -How do we ensure that every superclass witness is generated by -one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses]. +How do we ensure that every superclass witness in an instance declaration +is generated by one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses]? Answer: - * Superclass "wanted" constraints have CtOrigin of (ScOrigin size) - where 'size' is the size of the instance declaration. e.g. - class C a => D a where... - instance blah => D [a] where ... - The wanted superclass constraint for C [a] has origin - ScOrigin size, where size = size( D [a] ). + * The "given" constraints of an instance decl have CtOrigin of + (GivenOrigin (InstSkol head_size)), where head_size is the + PatersonSize of the head of the instance declaration. E.g. in + instance D a => C [a] + the `[G] D a` constraint has a CtOrigin whose head_size is the + PatersonSize of (C [a]). + * When we make a superclass selection from a Given (transitively) + we give it a CtOrigin of (GivenSCOrigin skol_info sc_depth blocked). + + The 'blocked :: Bool' flag says if the superclass can be used to + solve a superclass Wanted. The new superclass is blocked unless: + + 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 + (in the mk_given_loc helper function). + + * Superclass "Wanted" constraints have CtOrigin of (ScOrigin NakedSc) + The 'NakedSc' says that this is a naked superclass Wanted; we must + be careful when solving it. + * (sc1) When we rewrite such a wanted constraint, it retains its origin. But if we apply an instance declaration, we can set the - origin to (ScOrigin infinity), thus lifting any restrictions by - making prohibitedSuperClassSolve return False. + origin to (ScOrigin NotNakedSc), thus lifting any restrictions by + making prohibitedSuperClassSolve return False. This happens + in GHC.Tc.Solver.Interact.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.Interact.prohibitedSuperClassSolve + implemented by GHC.Tc.Solver.InertSet.prohibitedSuperClassSolve - * The "given" constraints of an instance decl have CtOrigin - GivenOrigin InstSkol. +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. - * When we make a superclass selection from InstSkol we use - a CtOrigin of (InstSCOrigin size), where 'size' is the size of - the constraint whose superclass we are taking. And similarly - when taking the superclass of an InstSCOrigin. This is implemented - in GHC.Tc.Solver.Canonical.mk_strict_superclasses (in the - mk_given_loc helper function). +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) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1702,7 +1746,7 @@ - Use tcValBinds to do the checking -} -tcMethods :: DFunId -> Class +tcMethods :: SkolemInfoAnon -> DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType] -> TcEvBinds @@ -1712,7 +1756,7 @@ -> TcM ([Id], LHsBinds GhcTc, Bag Implication) -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ... -tcMethods 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 @@ -1745,10 +1789,10 @@ 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 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 + = tcMethodBody skol_info 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 | otherwise = do { traceTc "tc_def" (ppr sel_id) ; tc_default sel_id dm_info } @@ -1759,7 +1803,7 @@ tc_default sel_id (Just (dm_name, _)) = do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name - ; tcMethodBody clas tyvars dfun_ev_vars inst_tys + ; tcMethodBody skol_info 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 } @@ -1786,7 +1830,7 @@ meth_tau = classMethodInstTy sel_id inst_tys error_string dflags = showSDoc dflags (hcat [ppr inst_loc, vbar, ppr sel_id ]) - lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars + lam_wrapper = mkWpTyLams tyvars <.> mkWpEvLams dfun_ev_vars ---------------------- -- Check if one of the minimal complete definitions is satisfied @@ -1800,7 +1844,7 @@ -- Check if any method bindings do not correspond to the class. -- See Note [Mismatched class methods and associated type families]. checkMethBindMembership - = mapM_ (addErrTc . badMethodErr clas) mismatched_meths + = mapM_ (addErrTc . TcRnBadMethodErr (className clas)) mismatched_meths where bind_nms = map unLoc $ collectMethodBinders binds cls_meth_nms = map (idName . fst) op_items @@ -1877,13 +1921,14 @@ -} ------------------------ -tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType] +tcMethodBody :: SkolemInfoAnon + -> Class -> [TcTyVar] -> [EvVar] -> [TcType] -> TcEvBinds -> Bool -> HsSigFun -> [LTcSpecPrag] -> [LSig GhcRn] -> Id -> LHsBind GhcRn -> SrcSpan -> TcM (TcId, LHsBind GhcTc, Maybe Implication) -tcMethodBody clas tyvars dfun_ev_vars inst_tys +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 @@ -1901,7 +1946,7 @@ -- taking instance signature into account might change the type of -- the local_meth_id ; (meth_implic, ev_binds_var, tc_bind) - <- checkInstConstraints $ + <- checkInstConstraints skol_info $ tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind) ; global_meth_id <- addInlinePrags global_meth_id prags @@ -1940,7 +1985,7 @@ = do { (sig_ty, hs_wrap) <- setSrcSpan (getLocA hs_sig_ty) $ do { inst_sigs <- xoptM LangExt.InstanceSigs - ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty) + ; checkTc inst_sigs (TcRnMisplacedInstSig sel_name hs_sig_ty) ; let ctxt = FunSigCtxt sel_name NoRRC ; sig_ty <- tcHsSigType ctxt hs_sig_ty ; let local_meth_ty = idType local_meth_id @@ -1957,7 +2002,7 @@ ; let ctxt = FunSigCtxt sel_name (lhsSigTypeContextSpan hs_sig_ty) -- WantRCC <=> check for redundant constraints in the -- user-specified instance signature - inner_meth_id = mkLocalId inner_meth_name Many sig_ty + 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 } @@ -2006,8 +2051,8 @@ ; local_meth_name <- newName sel_occ -- Base the local_meth_name on the selector name, because -- type errors from tcMethodBody come from here - ; let poly_meth_id = mkLocalId poly_meth_name Many poly_meth_ty - local_meth_id = mkLocalId local_meth_name Many local_meth_ty + ; let poly_meth_id = mkLocalId poly_meth_name ManyTy poly_meth_ty + local_meth_id = mkLocalId local_meth_name ManyTy local_meth_ty ; return (poly_meth_id, local_meth_id) } where @@ -2028,14 +2073,6 @@ , text " Class sig:" <+> ppr meth_ty ]) ; return (env2, msg) } -misplacedInstSig :: Name -> LHsSigType GhcRn -> TcRnMessage -misplacedInstSig name hs_ty - = TcRnUnknownMessage $ mkPlainError noHints $ - vcat [ hang (text "Illegal type signature in instance declaration:") - 2 (hang (pprPrefixName name) - 2 (dcolon <+> ppr hs_ty)) - , text "(Use InstanceSigs to allow this)" ] - {- Note [Instance method signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ With -XInstanceSigs we allow the user to supply a signature for the @@ -2050,7 +2087,7 @@ class method (in this case: Age -> Age -> Bool), but it cannot be less polymorphic. Moreover, if a signature is given, the implementation code should match the signature, and type variables bound in the -singature should scope over the method body. +signature should scope over the method body. We achieve this by building a TcSigInfo for the method, whether or not there is an instance method signature, and using that to typecheck @@ -2126,7 +2163,7 @@ fn = noLocA (idName sel_id) visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys - , tyConBinderArgFlag tcb /= Inferred ] + , tyConBinderForAllTyFlag tcb /= Inferred ] rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys bind = L (noAnnSrcSpan loc) $ mkTopFunBind Generated fn @@ -2142,8 +2179,8 @@ (_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id) mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn - mk_vta fun ty = noLocA (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy - $ noLocA $ XHsType ty)) + mk_vta fun ty = noLocA (HsAppType noExtField fun noHsTok + (mkEmptyWildCardBndrs $ nlHsParTy $ noLocA $ XHsType ty)) -- NB: use visible type application -- See Note [Default methods in instances] @@ -2158,14 +2195,9 @@ warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM () warnUnsatisfiedMinimalDefinition mindef = do { warn <- woptM Opt_WarnMissingMethods - ; let msg = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingMethods) noHints message + ; let msg = TcRnUnsatisfiedMinimalDef mindef ; diagnosticTc warn msg } - where - message = vcat [text "No explicit implementation for" - ,nest 2 $ pprBooleanFormulaNice mindef - ] {- Note [Export helper functions] @@ -2347,7 +2379,7 @@ ------------------------------ tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag -tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty) +tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty) = addErrCtxt (spec_ctxt prag) $ do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty @@ -2371,38 +2403,11 @@ instDeclCtxt2 :: Type -> SDoc instDeclCtxt2 dfun_ty - = inst_decl_ctxt (ppr (mkClassPred cls tys)) + = inst_decl_ctxt (ppr head_ty) where - (_,_,cls,tys) = tcSplitDFunTy dfun_ty + (_,_,head_ty) = tcSplitQuantPredTy dfun_ty inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = hang (text "In the instance declaration for") 2 (quotes doc) -badBootFamInstDeclErr :: TcRnMessage -badBootFamInstDeclErr - = TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal family instance in hs-boot file" - -notFamily :: TyCon -> TcRnMessage -notFamily tycon - = TcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal family instance for" <+> quotes (ppr tycon) - , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")] - -assocInClassErr :: TyCon -> TcRnMessage -assocInClassErr name - = TcRnUnknownMessage $ mkPlainError noHints $ - text "Associated type" <+> quotes (ppr name) <+> - text "must be inside a class instance" - -badFamInstDecl :: TyCon -> TcRnMessage -badFamInstDecl tc_name - = TcRnUnknownMessage $ mkPlainError noHints $ - vcat [ text "Illegal family instance for" <+> - quotes (ppr tc_name) - , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ] - -notOpenFamily :: TyCon -> TcRnMessage -notOpenFamily tc - = TcRnUnknownMessage $ mkPlainError noHints $ - text "Illegal instance for closed family" <+> quotes (ppr tc) 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 @@ -2,8 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -21,17 +19,27 @@ import GHC.Prelude import GHC.Hs + import GHC.Tc.Gen.Pat -import GHC.Core.Multiplicity -import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType, isManyDataConTy ) -import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.TcMType +import GHC.Tc.Utils.Zonk import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv , addInlinePrags, addInlinePragArity ) -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.TcMType -import GHC.Tc.Utils.Zonk +import GHC.Tc.Solver +import GHC.Tc.Utils.Unify +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence +import GHC.Tc.Types.Origin +import GHC.Tc.TyCl.Build + +import GHC.Core.Multiplicity +import GHC.Core.Type ( typeKind, tidyForAllTyBinders, tidyTypes, tidyType, isManyTy, mkTYPEapp ) +import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) +import GHC.Core.Predicate + import GHC.Builtin.Types.Prim import GHC.Types.Error import GHC.Types.Name @@ -42,21 +50,13 @@ import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Types.Var -import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSet ) +import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSetList ) import GHC.Types.Id -import GHC.Types.Id.Info( RecSelParent(..), setLevityInfoWithType ) +import GHC.Types.Id.Info( RecSelParent(..) ) import GHC.Tc.Gen.Bind import GHC.Types.Basic -import GHC.Tc.Solver -import GHC.Tc.Utils.Unify -import GHC.Core.Predicate import GHC.Builtin.Types -import GHC.Tc.Utils.TcType -import GHC.Tc.Types.Evidence -import GHC.Tc.Types.Origin -import GHC.Tc.TyCl.Build import GHC.Types.Var.Set -import GHC.Types.Id.Make import GHC.Tc.TyCl.Utils import GHC.Core.ConLike import GHC.Types.FieldLabel @@ -127,7 +127,7 @@ ones; because pattern synonyms are top-level things, we will never solve them later if we can't solve them now. And if we were to carry on, tc_patsyn_finish does zonkTcTypeToType, which defaults any -unsolved unificatdion variables to Any, which confuses the error +unsolved unification variables to Any, which confuses the error reporting no end (#15685). So we use simplifyTop to completely solve the constraint, report @@ -215,8 +215,8 @@ -- See Note [Equality evidence in pattern synonyms] mkProvEvidence ev_id | EqPred r ty1 ty2 <- classifyPredType pred - , let k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 + , let k1 = typeKind ty1 + k2 = typeKind ty2 is_homo = k1 `tcEqType` k2 homo_tys = [k1, ty1, ty2] hetero_tys = [k1, k2, ty1, ty2] @@ -242,7 +242,7 @@ -- See Note [Coercions that escape] dependentArgErr (arg, bad_cos) = failWithTc $ -- fail here: otherwise we get downstream errors - TcRnUnknownMessage $ mkPlainError noHints $ + mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ text "Iceland Jack! Iceland Jack! Stop torturing me!" , hang (text "Pattern-bound variable") 2 (ppr arg <+> dcolon <+> ppr (idType arg)) @@ -277,7 +277,7 @@ can't go in the inner forall either. (What would the matcher apply the continuation to?) -Solution: do not quantiify over any unification variable whose kind +Solution: do not quantify over any unification variable whose kind mentions the existentials. We can conveniently do that by making the "taus" passed to simplifyInfer look like forall ex_tvs. arg_ty @@ -327,7 +327,7 @@ and is not implicitly instantiated. So in mkProvEvidence we lift (a ~# b) to (a ~ b). Tiresome, and -marginally less efficient, if the builder/martcher are not inlined. +marginally less efficient, if the builder/matcher are not inlined. See also Note [Lift equality constraints when quantifying] in GHC.Tc.Solver @@ -407,7 +407,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) $ TcRnUnknownMessage $ mkPlainError noHints $ + ; 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 @@ -423,7 +423,7 @@ ex_tvs = binderVars ex_bndrs -- Pattern synonyms currently cannot be linear (#18806) - ; checkTc (all (isManyDataConTy . scaledMult) arg_tys) $ + ; checkTc (all (isManyTy . scaledMult) arg_tys) $ TcRnLinearPatSyn sig_body_ty ; skol_info <- mkSkolemInfo (SigSkol (PatSynCtxt name) pat_ty []) @@ -436,7 +436,7 @@ -- expected type. Even though the tyvars in the type are -- already skolems, this step changes their TcLevels, -- avoiding level-check errors when unifying. - ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX skol_info emptyTCvSubst univ_bndrs + ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX skol_info emptySubst univ_bndrs ; (skol_subst, skol_ex_bndrs) <- skolemiseTvBndrsX skol_info skol_subst0 ex_bndrs ; let skol_univ_tvs = binderVars skol_univ_bndrs skol_ex_tvs = binderVars skol_ex_bndrs @@ -456,8 +456,8 @@ pushLevelAndCaptureConstraints $ tcExtendNameTyVarEnv univ_tv_prs $ tcCheckPat PatSyn lpat (unrestricted skol_pat_ty) $ - do { let in_scope = mkInScopeSet (mkVarSet skol_univ_tvs) - empty_subst = mkEmptyTCvSubst in_scope + do { let in_scope = mkInScopeSetList skol_univ_tvs + empty_subst = mkEmptySubst in_scope ; (inst_subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst skol_ex_tvs -- newMetaTyVarX: see the "Existential type variables" -- part of Note [Checking against a pattern signature] @@ -494,7 +494,7 @@ (args', skol_arg_tys) skol_pat_ty rec_fields } where - tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc) + tc_arg :: Subst -> Name -> Type -> TcM (LHsExpr GhcTc) -- Look up the variable actually bound by lpat -- and check that it has the expected type tc_arg subst arg_name arg_ty @@ -515,8 +515,8 @@ -- See Note [Pattern synonyms and higher rank types] ; return (mkLHsWrap wrap $ nlHsVar arg_id) } -skolemiseTvBndrsX :: SkolemInfo -> TCvSubst -> [VarBndr TyVar flag] - -> TcM (TCvSubst, [VarBndr TcTyVar flag]) +skolemiseTvBndrsX :: SkolemInfo -> Subst -> [VarBndr TyVar flag] + -> TcM (Subst, [VarBndr TcTyVar flag]) -- Make new TcTyVars, all skolems with levels, but do not clone -- The level is one level deeper than the current level -- See Note [Skolemising when checking a pattern synonym] @@ -525,8 +525,8 @@ ; let pushed_lvl = pushTcLevel tc_lvl details = SkolemTv skol_info pushed_lvl False - mk_skol_tv_x :: TCvSubst -> VarBndr TyVar flag - -> (TCvSubst, VarBndr TcTyVar flag) + mk_skol_tv_x :: Subst -> VarBndr TyVar flag + -> (Subst, VarBndr TcTyVar flag) mk_skol_tv_x subst (Bndr tv flag) = (subst', Bndr new_tv flag) where @@ -681,7 +681,7 @@ wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a wrongNumberOfParmsErr name decl_arity missing - = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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") @@ -719,8 +719,8 @@ ; pat_ty' <- zonkTcTypeToTypeX ze pat_ty ; arg_tys' <- zonkTcTypesToTypesX ze arg_tys - ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs' - (env2, ex_tvs) = tidyTyCoVarBinders env1 ex_tvs' + ; 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' @@ -788,25 +788,25 @@ (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty = do { let loc' = locA loc - ; rr_name <- newNameAt (mkTyVarOcc "rep") loc' - ; tv_name <- newNameAt (mkTyVarOcc "r") loc' + ; rr_name <- newNameAt (mkTyVarOccFS (fsLit "rep")) loc' + ; tv_name <- newNameAt (mkTyVarOccFS (fsLit "r")) loc' ; let rr_tv = mkTyVar rr_name runtimeRepTy rr = mkTyVarTy rr_tv res_tv = mkTyVar tv_name (mkTYPEapp rr) res_ty = mkTyVarTy res_tv is_unlifted = null args && null prov_dicts (cont_args, cont_arg_tys) - | is_unlifted = ([nlHsVar voidPrimId], [unboxedUnitTy]) - | otherwise = (args, arg_tys) + | is_unlifted = ([nlHsDataCon unboxedUnitDataCon], [unboxedUnitTy]) + | otherwise = (args, arg_tys) cont_ty = mkInfSigmaTy ex_tvs prov_theta $ mkVisFunTysMany cont_arg_tys res_ty fail_ty = mkVisFunTyMany unboxedUnitTy res_ty ; matcher_name <- newImplicitBinder ps_name mkMatcherOcc - ; scrutinee <- newSysLocalId (fsLit "scrut") Many pat_ty - ; cont <- newSysLocalId (fsLit "cont") Many cont_ty - ; fail <- newSysLocalId (fsLit "fail") Many fail_ty + ; scrutinee <- newSysLocalId (fsLit "scrut") ManyTy pat_ty + ; cont <- newSysLocalId (fsLit "cont") ManyTy cont_ty + ; fail <- newSysLocalId (fsLit "fail") ManyTy fail_ty ; dflags <- getDynFlags ; let matcher_tau = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty @@ -818,7 +818,7 @@ inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args - fail' = nlHsApps fail [nlHsVar voidPrimId] + fail' = nlHsApps fail [nlHsDataCon unboxedUnitDataCon] args = map nlVarPat [scrutinee, cont, fail] lwpat = noLocA $ WildPat pat_ty @@ -830,15 +830,13 @@ L (getLoc lpat) $ HsCase noExtField (nlHsVar scrutinee) $ MG{ mg_alts = L (l2l $ getLoc lpat) cases - , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty - , mg_origin = Generated + , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty Generated } 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 - , mg_origin = Generated + , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated } match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id))) [] (mkHsLams (rr_tv:res_tv:univ_tvs) @@ -846,8 +844,7 @@ (EmptyLocalBinds noExtField) mg :: MatchGroup GhcTc (LHsExpr GhcTc) mg = MG{ mg_alts = L (l2l $ getLoc match) [match] - , mg_ext = MatchGroupTc [] res_ty - , mg_origin = Generated + , mg_ext = MatchGroupTc [] res_ty Generated } matcher_arity = length req_theta + 3 -- See Note [Pragmas for pattern synonyms] @@ -860,8 +857,8 @@ ; let bind = FunBind{ fun_id = L loc matcher_prag_id , fun_matches = mg - , fun_ext = idHsWrapper - , fun_tick = [] } + , fun_ext = (idHsWrapper, []) + } matcher_bind = unitBag (noLocA bind) ; traceTc "tcPatSynMatcher" (ppr ps_name $$ ppr (idType matcher_id)) ; traceTc "tcPatSynMatcher" (ppr matcher_bind) @@ -926,7 +923,7 @@ = return emptyBag | Left why <- mb_match_group -- Can't invert the pattern - = setSrcSpan (getLocA lpat) $ failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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 @@ -942,9 +939,7 @@ Just (builder_name, builder_ty, need_dummy_arg) -> -- Normal case do { -- Bidirectional, so patSynBuilder returns Just - let pat_ty = patSynResultType patsyn - builder_id = modifyIdInfo (`setLevityInfoWithType` pat_ty) $ - mkExportedVanillaId builder_name builder_ty + let builder_id = mkExportedVanillaId builder_name builder_ty -- See Note [Exported LocalIds] in GHC.Types.Id (_, req_theta, _, prov_theta, arg_tys, _) = patSynSigBndr patsyn @@ -964,7 +959,7 @@ bind = FunBind { fun_id = L loc (idName builder_id) , fun_matches = match_group' , fun_ext = emptyNameSet - , fun_tick = [] } + } sig = completeSigFromId (PatSynCtxt ps_name) builder_id @@ -1093,9 +1088,8 @@ = return $ unLoc $ foldl' nlHsApp (noLocA neg) [noLocA (HsOverLit noAnn n)] | otherwise = return $ HsOverLit noAnn n - go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) - = go1 pat - go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety" + go1 (SplicePat (HsUntypedSpliceTop _ pat) _) = go1 pat + go1 (SplicePat (HsUntypedSpliceNested _) _) = panic "tcPatToExpr: invalid nested splice" go1 (XPat (HsPatExpanded _ pat))= go1 pat -- See Note [Invertible view patterns] @@ -1112,9 +1106,6 @@ go1 p@(WildPat {}) = notInvertible p go1 p@(AsPat {}) = notInvertible p go1 p@(NPlusKPat {}) = notInvertible p - go1 p@(SplicePat _ (HsTypedSplice {})) = notInvertible p - go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p - go1 p@(SplicePat _ (HsQuasiQuote {})) = notInvertible p notInvertible p = Left (not_invertible_msg p) @@ -1280,7 +1271,7 @@ go1 :: Pat GhcTc -> ([TyVar], [EvVar]) go1 (LazyPat _ p) = go p - go1 (AsPat _ _ 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 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 @@ -64,8 +64,6 @@ import GHC.Unit.Module -import GHC.Rename.Utils (wrapGenSpan) - import GHC.Types.Basic import GHC.Types.Error import GHC.Types.FieldLabel @@ -83,6 +81,8 @@ import GHC.Types.TyThing import qualified GHC.LanguageExtensions as LangExt +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + import Control.Monad {- @@ -139,14 +139,15 @@ 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 (FunCo _ co_mult co co') = go_co co_mult `plusNameEnv` go_co co `plusNameEnv` go_co 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 (NthCo _ _ co) = 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 @@ -172,7 +173,7 @@ -- TODO: TyConSet is implemented as IntMap over uniques. -- But we could get away with something based on IntSet --- since we only check membershib, but never extract the +-- since we only check membership, but never extract the -- elements. type SynCycleState = TyConSet @@ -208,7 +209,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 (TcRnUnknownMessage $ mkPlainError noHints err) + Left (loc, err) -> setSrcSpan loc $ failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err) Right _ -> return () where -- Try our best to print the LTyClDecl for locally defined things @@ -500,8 +501,8 @@ | otherwise = pprPanic "initialRoleEnv1" (ppr tc) where name = tyConName tc bndrs = tyConBinders tc - argflags = map tyConBinderArgFlag bndrs - num_exps = count isVisibleArgFlag argflags + argflags = map tyConBinderForAllTyFlag bndrs + num_exps = count isVisibleForAllTyFlag argflags -- if the number of annotations in the role annotation decl -- is wrong, just ignore it. We check this in the validity check. @@ -513,7 +514,7 @@ default_roles = build_default_roles argflags role_annots build_default_roles (argf : argfs) (m_annot : ras) - | isVisibleArgFlag argf + | isVisibleForAllTyFlag argf = (m_annot `orElse` default_role) : build_default_roles argfs ras build_default_roles (_argf : argfs) ras = Nominal : build_default_roles argfs ras @@ -855,14 +856,14 @@ tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv tcRecSelBinds sel_bind_prs - = tcExtendGlobalValEnv [sel_id | (L _ (IdSig _ sel_id)) <- sigs] $ + = 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 ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } where - sigs = [ L (noAnnSrcSpan loc) (IdSig noExtField sel_id) + 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] @@ -902,14 +903,30 @@ con1 = assert (not (null cons_w_field)) $ head cons_w_field -- Selector type; Note [Polymorphic selectors] - field_ty = conLikeFieldType con1 lbl - data_tvbs = filter (\tvb -> binderVar tvb `elemVarSet` data_tv_set) $ - conLikeUserTyVarBinders con1 - data_tv_set= tyCoVarsOfTypes inst_tys - is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set) - || has_sel == NoFieldSelectors + (univ_tvs, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1 + + field_ty = conLikeFieldType con1 lbl + field_ty_tvs = tyCoVarsOfType field_ty + data_ty_tvs = tyCoVarsOfType data_ty + sel_tvs = field_ty_tvs `unionVarSet` data_ty_tvs + sel_tvbs = filter (\tvb -> binderVar tvb `elemVarSet` sel_tvs) $ + conLikeUserTyVarBinders con1 + + -- is_naughty: see Note [Naughty record selectors] + is_naughty = not ok_scoping || no_selectors + ok_scoping = case con1 of + RealDataCon {} -> field_ty_tvs `subVarSet` data_ty_tvs + PatSynCon {} -> field_ty_tvs `subVarSet` mkVarSet univ_tvs + -- In the PatSynCon case, the selector type is (data_ty -> field_ty), but + -- fvs(data_ty) are all universals (see Note [Pattern synonym result type] in + -- GHC.Core.PatSyn, so no need to check them. + + no_selectors = has_sel == NoFieldSelectors -- No field selectors => all are naughty + -- thus suppressing making a binding + -- A slight hack! + sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] - | otherwise = mkForAllTys (tyVarSpecToBinders data_tvbs) $ + | otherwise = mkForAllTys (tyVarSpecToBinders sel_tvbs) $ -- Urgh! See Note [The stupid context] in GHC.Core.DataCon mkPhiTy (conLikeStupidTheta con1) $ -- req_theta is empty for normal DataCon @@ -920,7 +937,7 @@ -- fields in all the constructor have multiplicity Many. field_ty - -- Make the binding: sel (C2 { fld = x }) = x + -- 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 @@ -937,7 +954,7 @@ { hfbAnn = noAnn , hfbLHS = L locc (FieldOcc sel_name - (L locn $ mkVarUnqual lbl)) + (L locn $ mkVarUnqual (field_label lbl))) , hfbRHS = L loc' (VarPat noExtField (L locn field_var)) , hfbPun = False }) @@ -949,11 +966,10 @@ -- 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))))] + [L loc' (WildPat noExtField)] + (mkHsApp (L loc' (HsVar noExtField + (L locn (getName rEC_SEL_ERROR_ID)))) + (L loc' (HsLit noComments msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we @@ -966,26 +982,13 @@ -- B :: { fld :: Int } -> T Int Char dealt_with :: ConLike -> Bool dealt_with (PatSynCon _) = False -- We can't predict overlap - dealt_with con@(RealDataCon dc) = - con `elem` cons_w_field || dataConCannotMatch inst_tys dc - - (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1 - - eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec) - -- inst_tys corresponds to one of the following: - -- - -- * The arguments to the user-written return type (for GADT constructors). - -- In this scenario, eq_subst provides a mapping from the universally - -- quantified type variables to the argument types. Note that eq_subst - -- does not need to be applied to any other part of the DataCon - -- (see Note [The dcEqSpec domain invariant] in GHC.Core.DataCon). - -- * The universally quantified type variables - -- (for Haskell98-style constructors and pattern synonyms). In these - -- scenarios, eq_subst is an empty substitution. - inst_tys = substTyVars eq_subst univ_tvs + dealt_with con@(RealDataCon dc) + = con `elem` cons_w_field || dataConCannotMatch inst_tys dc + where + inst_tys = dataConResRepTyArgs dc unit_rhs = mkLHsTupleExpr [] noExtField - msg_lit = HsStringPrim NoSourceText (bytesFS lbl) + msg_lit = HsStringPrim NoSourceText (bytesFS (field_label lbl)) {- Note [Polymorphic selectors] @@ -1042,16 +1045,41 @@ helpfully, rather than saying unhelpfully that 'x' is not in scope. Hence the sel_naughty flag, to identify record selectors that don't really exist. -In general, a field is "naughty" if its type mentions a type variable that -isn't in the result type of the constructor. Note that this *allows* -GADT record selectors (Note [GADT record selectors]) whose types may look -like sel :: T [a] -> a - For naughty selectors we make a dummy binding sel = () so that the later type-check will add them to the environment, and they'll be exported. The function is never called, because the typechecker spots the sel_naughty field. + +To determine naughtiness we distingish two cases: + +* For RealDataCons, a field is "naughty" if its type mentions a + type variable that isn't in the (original, user-written) result type + of the constructor. Note that this *allows* GADT record selectors + (Note [GADT record selectors]) whose types may look like sel :: T [a] -> a + +* For a PatSynCon, a field is "naughty" if its type mentions a type variable + that isn't in the universal type variables. + + This is a bit subtle. Consider test patsyn/should_run/records_run: + pattern ReadP :: forall a. ReadP a => a -> String + pattern ReadP {fld} <- (read -> readp) + 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 + 'a' from a bare String. + + Another curious case (#23038): + pattern N :: forall a. () => forall. () => a -> Any + pattern N { fld } <- ( unsafeCoerce -> fld1 ) where N = unsafeCoerce + The selector looks like this + $selNfld :: forall a. Any -> a + $selNfld @a x = unsafeCoerce @Any @a x + Pretty strange (but used in the `cleff` package). + + TL;DR for pattern synonyms, the selector is OK if the field type mentions only + the universal type variables of the pattern synonym. Note [NoFieldSelectors and naughty record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Tc/Types.hs b/GHC/Tc/Types.hs --- a/GHC/Tc/Types.hs +++ b/GHC/Tc/Types.hs @@ -31,7 +31,7 @@ Env(..), TcGblEnv(..), TcLclEnv(..), setLclEnvTcLevel, getLclEnvTcLevel, - setLclEnvLoc, getLclEnvLoc, + setLclEnvLoc, getLclEnvLoc, lclEnvInGeneratedCode, IfGblEnv(..), IfLclEnv(..), tcVisibleOrphanMods, RewriteEnv(..), @@ -102,6 +102,7 @@ import GHC.Platform import GHC.Driver.Env +import GHC.Driver.Config.Core.Lint import GHC.Driver.Session import {-# SOURCE #-} GHC.Driver.Hooks @@ -183,7 +184,7 @@ -- 'ns_module_name' @A@, defines a mapping from @{A.T}@ -- (for some 'OccName' @T@) to some arbitrary other 'Name'. -- --- The most intruiging thing about a 'NameShape', however, is +-- The most intriguing thing about a 'NameShape', however, is -- how it's constructed. A 'NameShape' is *implied* by the -- exported 'AvailInfo's of the implementor of an interface: -- if an implementor of signature @\@ exports @M.T@, you implicitly @@ -293,6 +294,7 @@ -- ^ At what role are we rewriting? -- -- See Note [Rewriter EqRels] in GHC.Tc.Solver.Rewrite + , re_rewriters :: !(TcRef RewriterSet) -- ^ See Note [Wanteds rewrite Wanteds] } -- RewriteEnv is mostly used in @GHC.Tc.Solver.Rewrite@, but it is defined @@ -400,7 +402,7 @@ -- signatures (we just generate blank object files for -- hsig files.) -- --- A corrolary of this is that the following invariant holds at any point +-- A corollary of this is that the following invariant holds at any point -- past desugaring, -- -- if I have a Module, this_mod, in hand representing the module @@ -861,6 +863,9 @@ 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 @@ -973,7 +978,7 @@ -- | Get target platform -getPlatform :: TcM Platform +getPlatform :: TcRnIf a b Platform getPlatform = targetPlatform <$> getDynFlags --------------------------- @@ -1134,7 +1139,7 @@ | ATyVar Name TcTyVar -- See Note [Type variables in the type environment] | ATcTyCon TyCon -- Used temporarily, during kind checking, for the - -- tycons and clases in this recursive group + -- 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] @@ -1147,25 +1152,6 @@ tcTyThingTyCon_maybe (ATcTyCon tc_tc) = Just tc_tc tcTyThingTyCon_maybe _ = Nothing -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 [Don't promote data constructors with - -- non-equality contexts] in GHC.Tc.Gen.HsType - | 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 - | NoDataKindsDC -- -XDataKinds not enabled (for a datacon) - instance Outputable TcTyThing where -- Debugging only ppr (AGlobal g) = ppr g ppr elt@(ATcId {}) = text "Identifier" <> @@ -1233,7 +1219,7 @@ - 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] + - 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: @@ -1350,16 +1336,6 @@ ppr (NonClosedLet fvs closed_type) = text "TopLevelLet" <+> ppr fvs <+> ppr closed_type -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" - -------------- pprTcTyThingCategory :: TcTyThing -> SDoc pprTcTyThingCategory = text . capitalise . tcTyThingCategory @@ -1371,19 +1347,6 @@ tcTyThingCategory (ATcTyCon {}) = "local tycon" tcTyThingCategory (APromotionErr pe) = peCategory pe --------------- -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" - {- ************************************************************************ * * @@ -1451,9 +1414,9 @@ imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, imp_trust_own_pkg = tself1 || tself2, imp_boot_mods = srs1 `plusModDeps` srcs2, - imp_sig_mods = sig_mods1 `unionLists` sig_mods2, - imp_orphs = orphs1 `unionLists` orphs2, - imp_finsts = finsts1 `unionLists` finsts2 } + imp_sig_mods = unionListsOrd sig_mods1 sig_mods2, + imp_orphs = unionListsOrd orphs1 orphs2, + imp_finsts = unionListsOrd finsts1 finsts2 } {- ************************************************************************ @@ -1860,7 +1823,8 @@ -- axioms, but should check other aspects, too. lintGblEnv :: Logger -> DynFlags -> TcGblEnv -> TcM () lintGblEnv logger dflags tcg_env = - liftIO $ lintAxioms logger dflags (text "TcGblEnv axioms") axioms + -- TODO empty list means no extra in scope from GHCi, is this correct? + liftIO $ lintAxioms logger (initLintConfig dflags []) (text "TcGblEnv axioms") axioms where axioms = typeEnvCoAxioms (tcg_type_env tcg_env) diff --git a/GHC/Tc/Types.hs-boot b/GHC/Tc/Types.hs-boot --- a/GHC/Tc/Types.hs-boot +++ b/GHC/Tc/Types.hs-boot @@ -1,5 +1,6 @@ module GHC.Tc.Types where +import GHC.Prelude import GHC.Tc.Utils.TcType import GHC.Types.SrcLoc import GHC.Utils.Outputable @@ -11,8 +12,13 @@ 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/Constraint.hs b/GHC/Tc/Types/Constraint.hs --- a/GHC/Tc/Types/Constraint.hs +++ b/GHC/Tc/Types/Constraint.hs @@ -3,8 +3,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- | This module defines types and simple operations over constraints, as used -- in the type-checker and constraint solver. module GHC.Tc.Types.Constraint ( @@ -126,6 +124,7 @@ 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(..) ) @@ -200,17 +199,11 @@ cc_class :: Class, cc_tyargs :: [Xi], -- cc_tyargs are rewritten w.r.t. inerts, so Xi - cc_pend_sc :: Bool, + 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 - - cc_fundeps :: Bool - -- See Note [Fundeps with instances] in GHC.Tc.Solver.Interact - -- True <=> the class has fundeps, and we have not yet - -- compared this constraint with the global - -- instances for fundep improvement } | CIrredCan { -- These stand for yet-unusable predicates @@ -235,8 +228,9 @@ -- Note [CEqCan occurs check] -- * (TyEq:F) rhs has no foralls -- (this avoids substituting a forall for the tyvar in other types) - -- * (TyEq:K) tcTypeKind lhs `tcEqKind` tcTypeKind rhs; Note [Ct kind invariant] - -- * (TyEq:N) If the equality is representational, rhs has no top-level newtype + -- * (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.) @@ -314,7 +308,7 @@ -- signatures). See Note [Holes]. data Hole = Hole { hole_sort :: HoleSort -- ^ What flavour of hole is this? - , hole_occ :: OccName -- ^ The name of this hole + , 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 @@ -385,7 +379,7 @@ | ContainsCast TcType TcCoercionN -- | The type contains a forall. - | ContainsForall TyCoVarBinder TcType + | ContainsForall ForAllTyBinder TcType -- | The type contains a 'CoercionTy'. | ContainsCoercionTy TcCoercion @@ -678,10 +672,8 @@ pp_sort = case ct of CEqCan {} -> text "CEqCan" CNonCanonical {} -> text "CNonCanonical" - CDictCan { cc_pend_sc = psc, cc_fundeps = fds } - | psc, fds -> text "CDictCan(psc,fds)" - | psc, not fds -> text "CDictCan(psc)" - | not psc, fds -> text "CDictCan(fds)" + 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 }) @@ -694,7 +686,7 @@ -- Does not look through type synonyms. canEqLHS_maybe :: Xi -> Maybe CanEqLHS canEqLHS_maybe xi - | Just tv <- tcGetTyVar_maybe xi + | Just tv <- getTyVar_maybe xi = Just $ TyVarLHS tv | Just (tc, args) <- tcSplitTyConApp_maybe xi @@ -1242,7 +1234,7 @@ -- | Does this hole represent an "out of scope" error? -- See Note [Insoluble holes] isOutOfScopeHole :: Hole -> Bool -isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore occ) +isOutOfScopeHole (Hole { hole_occ = occ }) = not (startsWithUnderscore (occName occ)) instance Outputable WantedConstraints where ppr (WC {wc_simple = s, wc_impl = i, wc_errors = e}) @@ -1411,7 +1403,7 @@ * 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 princial types) + (and hence do not affect principal types) Examples: forall a. F a ~ Int => ... forall a b. F a ~ G b => ... @@ -1564,7 +1556,7 @@ 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 freah when the + * 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...)... @@ -1698,7 +1690,7 @@ 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 (InstSkol {}) (InstSkol {}) = True go FamInstSkol FamInstSkol = True go BracketSkol BracketSkol = True go (RuleSkol n1) (RuleSkol n2) = n1==n2 @@ -1708,7 +1700,6 @@ and (zipWith eq_pr ids1 ids2) go (UnifyForAllSkol t1) (UnifyForAllSkol t2) = t1 `tcEqType` t2 go ReifySkol ReifySkol = True - go QuantCtxtSkol QuantCtxtSkol = True go RuntimeUnkSkol RuntimeUnkSkol = True go ArrowReboundIfSkol ArrowReboundIfSkol = True go (UnkSkol _) (UnkSkol _) = True @@ -1724,7 +1715,7 @@ -- 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 + 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 @@ -1899,7 +1890,7 @@ ctEvCoercion :: HasDebugCallStack => CtEvidence -> TcCoercion ctEvCoercion (CtGiven { ctev_evar = ev_id }) - = mkTcCoVarCo ev_id + = mkCoVarCo ev_id ctEvCoercion (CtWanted { ctev_dest = dest }) | HoleDest hole <- dest = -- ctEvCoercion is only called on type equalities @@ -1933,24 +1924,18 @@ -- the evidence and the ctev_pred in sync with each other. -- See Note [CtEvidence invariants]. setCtEvPredType :: HasDebugCallStack => CtEvidence -> Type -> CtEvidence -setCtEvPredType old_ctev new_pred - = case old_ctev of - CtGiven { ctev_evar = ev, ctev_loc = loc } -> - CtGiven { ctev_pred = new_pred - , ctev_evar = setVarType ev new_pred - , ctev_loc = loc - } - CtWanted { ctev_dest = dest, ctev_loc = loc, ctev_rewriters = rewriters } -> - CtWanted { ctev_pred = new_pred - , ctev_dest = new_dest - , ctev_loc = loc - , ctev_rewriters = rewriters - } - where - new_dest = case dest of - EvVarDest ev -> EvVarDest (setVarType ev new_pred) - HoleDest h -> HoleDest (setCoHoleType h new_pred) +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 @@ -2255,7 +2240,7 @@ it's actually quite easy to mistake one for another, in sufficiently involved scenarios, like ConstraintKinds.) -The flag -freduction-depth=n fixes the maximium level. +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] 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 @@ -8,7 +8,7 @@ -- * HsWrapper HsWrapper(..), (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, - mkWpLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, + mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta, collectHsWrapBinders, idHsWrapper, isIdHsWrapper, pprHsWrapper, hsWrapDictBinders, @@ -41,23 +41,7 @@ TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole, TcMCoercion, TcMCoercionN, TcMCoercionR, Role(..), LeftOrRight(..), pickLR, - mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo, - mkTcTyConAppCo, mkTcAppCo, mkTcFunCo, - mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos, - mkTcSymCo, mkTcSymMCo, - mkTcTransCo, - mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSymCo, - maybeTcSubCo, tcDowngradeRole, - mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflRightMCo, mkTcGReflLeftCo, mkTcGReflLeftMCo, - mkTcPhantomCo, - mkTcCoherenceLeftCo, - mkTcCoherenceRightCo, - mkTcKindCo, - tcCoercionKind, - mkTcCoVarCo, - mkTcFamilyTyConAppCo, - isTcReflCo, isTcReflexiveCo, - tcCoercionRole, + maybeSymCo, unwrapIP, wrapIP, -- * QuoteWrapper @@ -69,6 +53,7 @@ import GHC.Types.Unique.DFM import GHC.Types.Unique.FM import GHC.Types.Var +import GHC.Types.Id( idScaledType ) import GHC.Core.Coercion.Axiom import GHC.Core.Coercion import GHC.Core.Ppr () -- Instance OutputableBndr TyVar @@ -80,7 +65,6 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Core.Predicate -import GHC.Data.Pair import GHC.Types.Basic import GHC.Core @@ -117,99 +101,18 @@ -} -type TcCoercion = Coercion -type TcCoercionN = CoercionN -- A Nominal coercion ~N -type TcCoercionR = CoercionR -- A Representational coercion ~R -type TcCoercionP = CoercionP -- a phantom coercion +type TcCoercion = Coercion +type TcCoercionN = CoercionN -- A Nominal coercion ~N +type TcCoercionR = CoercionR -- A Representational coercion ~R +type TcCoercionP = CoercionP -- a phantom coercion type TcMCoercion = MCoercion type TcMCoercionN = MCoercionN -- nominal type TcMCoercionR = MCoercionR -- representational -mkTcReflCo :: Role -> TcType -> TcCoercion -mkTcSymCo :: TcCoercion -> TcCoercion -mkTcSymMCo :: TcMCoercion -> TcMCoercion -mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion -mkTcNomReflCo :: TcType -> TcCoercionN -mkTcRepReflCo :: TcType -> TcCoercionR -mkTcTyConAppCo :: Role -> TyCon -> [TcCoercion] -> TcCoercion -mkTcAppCo :: TcCoercion -> TcCoercionN -> TcCoercion -mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion -> TcCoercion -mkTcAxInstCo :: Role -> CoAxiom br -> BranchIndex - -> [TcType] -> [TcCoercion] -> TcCoercion -mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType] - -> [TcCoercion] -> TcCoercionR -mkTcForAllCo :: TyVar -> TcCoercionN -> TcCoercion -> TcCoercion -mkTcForAllCos :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion -mkTcNthCo :: Role -> Int -> TcCoercion -> TcCoercion -mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion -mkTcSubCo :: HasDebugCallStack => TcCoercionN -> TcCoercionR -tcDowngradeRole :: Role -> Role -> TcCoercion -> TcCoercion -mkTcAxiomRuleCo :: CoAxiomRule -> [TcCoercion] -> TcCoercionR -mkTcGReflRightCo :: Role -> TcType -> TcCoercionN -> TcCoercion -mkTcGReflRightMCo :: Role -> TcType -> TcMCoercionN -> TcCoercion -mkTcGReflLeftCo :: Role -> TcType -> TcCoercionN -> TcCoercion -mkTcGReflLeftMCo :: Role -> TcType -> TcMCoercionN -> TcCoercion -mkTcCoherenceLeftCo :: Role -> TcType -> TcCoercionN - -> TcCoercion -> TcCoercion -mkTcCoherenceRightCo :: Role -> TcType -> TcCoercionN - -> TcCoercion -> TcCoercion -mkTcPhantomCo :: TcCoercionN -> TcType -> TcType -> TcCoercionP -mkTcKindCo :: TcCoercion -> TcCoercionN -mkTcCoVarCo :: CoVar -> TcCoercion -mkTcFamilyTyConAppCo :: TyCon -> [TcCoercionN] -> TcCoercionN - -tcCoercionKind :: TcCoercion -> Pair TcType -tcCoercionRole :: TcCoercion -> Role -isTcReflCo :: TcCoercion -> Bool - --- | This version does a slow check, calculating the related types and seeing --- if they are equal. -isTcReflexiveCo :: TcCoercion -> Bool - -mkTcReflCo = mkReflCo -mkTcSymCo = mkSymCo -mkTcSymMCo = mkSymMCo -mkTcTransCo = mkTransCo -mkTcNomReflCo = mkNomReflCo -mkTcRepReflCo = mkRepReflCo -mkTcTyConAppCo = mkTyConAppCo -mkTcAppCo = mkAppCo -mkTcFunCo = mkFunCo -mkTcAxInstCo = mkAxInstCo -mkTcUnbranchedAxInstCo = mkUnbranchedAxInstCo Representational -mkTcForAllCo = mkForAllCo -mkTcForAllCos = mkForAllCos -mkTcNthCo = mkNthCo -mkTcLRCo = mkLRCo -mkTcSubCo = mkSubCo -tcDowngradeRole = downgradeRole -mkTcAxiomRuleCo = mkAxiomRuleCo -mkTcGReflRightCo = mkGReflRightCo -mkTcGReflRightMCo = mkGReflRightMCo -mkTcGReflLeftCo = mkGReflLeftCo -mkTcGReflLeftMCo = mkGReflLeftMCo -mkTcCoherenceLeftCo = mkCoherenceLeftCo -mkTcCoherenceRightCo = mkCoherenceRightCo -mkTcPhantomCo = mkPhantomCo -mkTcKindCo = mkKindCo -mkTcCoVarCo = mkCoVarCo -mkTcFamilyTyConAppCo = mkFamilyTyConAppCo - -tcCoercionKind = coercionKind -tcCoercionRole = coercionRole -isTcReflCo = isReflCo -isTcReflexiveCo = isReflexiveCo - --- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing. --- Note that the input coercion should always be nominal. -maybeTcSubCo :: HasDebugCallStack => EqRel -> TcCoercionN -> TcCoercion -maybeTcSubCo NomEq = id -maybeTcSubCo ReprEq = mkTcSubCo - -- | If a 'SwapFlag' is 'IsSwapped', flip the orientation of a coercion -maybeTcSymCo :: SwapFlag -> TcCoercion -> TcCoercion -maybeTcSymCo IsSwapped co = mkTcSymCo co -maybeTcSymCo NotSwapped co = co +maybeSymCo :: SwapFlag -> TcCoercion -> TcCoercion +maybeSymCo IsSwapped co = mkSymCo co +maybeSymCo NotSwapped co = co {- %************************************************************************ @@ -219,6 +122,8 @@ ************************************************************************ -} +-- We write wrap :: t1 ~> t2 +-- if wrap[ e::t1 ] :: t2 data HsWrapper = WpHole -- The identity coercion @@ -227,16 +132,24 @@ -- -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) -- But ([] a) `WpCompose` ([] b) = ([] b a) + -- + -- If wrap1 :: t2 ~> t3 + -- wrap2 :: t1 ~> t2 + --- Then (wrap1 `WpCompose` wrap2) :: t1 ~> t3 | WpFun HsWrapper HsWrapper (Scaled TcTypeFRR) - -- (WpFun wrap1 wrap2 (w, t1))[e] = \(x:_w t1). wrap2[ e wrap1[x] ] - -- So note that if wrap1 :: exp_arg <= act_arg - -- wrap2 :: act_res <= exp_res - -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) <= (exp_arg -> exp_res) + -- (WpFun wrap1 wrap2 (w, t1))[e] = \(x:_w exp_arg). wrap2[ e wrap1[x] ] + -- So note that if e :: act_arg -> act_res + -- wrap1 :: exp_arg ~> act_arg + -- wrap2 :: act_res ~> exp_res + -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) ~> (exp_arg -> exp_res) -- This isn't the same as for mkFunCo, but it has to be this way -- because we can't use 'sym' to flip around these HsWrappers - -- The TcType is the "from" type of the first wrapper + -- The TcType is the "from" type of the first wrapper; + -- it always a Type, not a Constraint -- + -- NB: a WpFun is always for a (->) function arrow + -- -- Use 'mkWpFun' to construct such a wrapper. | WpCast TcCoercionR -- A cast: [] `cast` co @@ -245,8 +158,11 @@ -- Evidence abstraction and application -- (both dictionaries and coercions) + -- Both WpEvLam and WpEvApp abstract and apply values + -- of kind CONSTRAINT rep | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint + -- Kind and Type abstraction and application | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) @@ -291,29 +207,42 @@ mkWpFun :: HsWrapper -> HsWrapper -> Scaled TcTypeFRR -- ^ the "from" type of the first wrapper -- MUST have a fixed RuntimeRep - -> TcType -- ^ either type of the second wrapper (used only when the - -- second wrapper is the identity) + -> 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 (mkTcFunCo Representational (multToCo w) (mkTcRepReflCo t1) co2) -mkWpFun (WpCast co1) WpHole (Scaled w _) t2 = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) (mkTcRepReflCo t2)) -mkWpFun (WpCast co1) (WpCast co2) (Scaled w _) _ = WpCast (mkTcFunCo Representational (multToCo w) (mkTcSymCo co1) co2) +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 +mkWpEta :: [Id] -> HsWrapper -> HsWrapper +-- (mkWpEta [x1, x2] wrap) [e] +-- = \x1. \x2. wrap[e x1 x2] +-- Just generates a bunch of WpFuns +mkWpEta xs wrap = foldr eta_one wrap xs + where + eta_one x wrap = WpFun idHsWrapper wrap (idScaledType x) + +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 + -- FTF_T_T: WpFun is always (->) + mkWpCastR :: TcCoercionR -> HsWrapper mkWpCastR co - | isTcReflCo co = WpHole - | otherwise = assertPpr (tcCoercionRole co == Representational) (ppr co) $ - WpCast co + | isReflCo co = WpHole + | otherwise = assertPpr (coercionRole co == Representational) (ppr co) $ + WpCast co mkWpCastN :: TcCoercionN -> HsWrapper mkWpCastN co - | isTcReflCo co = WpHole - | otherwise = assertPpr (tcCoercionRole co == Nominal) (ppr co) $ - WpCast (mkTcSubCo co) + | isReflCo co = WpHole + | otherwise = assertPpr (coercionRole co == Nominal) (ppr co) $ + WpCast (mkSubCo co) -- The mkTcSubCo converts Nominal to Representational mkWpTyApps :: [Type] -> HsWrapper @@ -328,8 +257,8 @@ mkWpTyLams :: [TyVar] -> HsWrapper mkWpTyLams ids = mk_co_lam_fn WpTyLam ids -mkWpLams :: [Var] -> HsWrapper -mkWpLams ids = mk_co_lam_fn WpEvLam ids +mkWpEvLams :: [Var] -> HsWrapper +mkWpEvLams ids = mk_co_lam_fn WpEvLam ids mkWpLet :: TcEvBinds -> HsWrapper -- This no-op is a quite a common case @@ -442,7 +371,7 @@ Class constraints etc give rise to /term/ bindings for evidence, and we have nowhere to put term bindings in /types/. So in some places we use CoEvBindsVar (see newCoTcEvBinds) to signal that no term-level -evidence bindings are allowed. Notebly (): +evidence bindings are allowed. Notably (): - Places in types where we are solving kind constraints (all of which are equalities); see solveEqualities @@ -559,7 +488,7 @@ type EvExpr = CoreExpr -- An EvTerm is (usually) constructed by any of the constructors here --- and those more complicates ones who were moved to module GHC.Tc.Types.EvTerm +-- and those more complicated ones who were moved to module GHC.Tc.Types.EvTerm -- | Any sort of evidence Id, including coercions evId :: EvId -> EvExpr @@ -665,7 +594,7 @@ dl :: Typeable [a] = EvTypeable [a] (EvTypeableTyApp (EvTypeableTyCon []) (EvId d)) where - d :: Typable a + d :: Typeable a is the lambda-bound dictionary passed into f. Note [Coercion evidence terms] @@ -851,10 +780,10 @@ mkEvCast :: EvExpr -> TcCoercion -> EvTerm mkEvCast ev lco - | assertPpr (tcCoercionRole lco == Representational) + | assertPpr (coercionRole lco == Representational) (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco]) $ - isTcReflCo lco = EvExpr ev - | otherwise = evCast ev lco + isReflCo lco = EvExpr ev + | otherwise = evCast ev lco mkEvScSelectors -- Assume class (..., D ty, ...) => C a b @@ -1032,10 +961,12 @@ = ppr (orig,loc) <+> text ":" <+> ppr tm instance Outputable EvTypeable where - ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts - ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) - ppr (EvTypeableTrFun tm t1 t2) = parens (ppr t1 <+> mulArrow (ppr tm) <+> ppr t2) - ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 + ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts + ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) + ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 + ppr (EvTypeableTrFun tm t1 t2) = parens (ppr t1 <+> arr <+> ppr t2) + where + arr = pprArrowWithMultiplicity visArgTypeLike (Right (ppr tm)) ---------------------------------------------------------------------- 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 @@ -3,9 +3,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- | Describes the provenance of types as they flow through the type-checker. -- The datatypes here are mainly used for error message generation. module GHC.Tc.Types.Origin ( @@ -16,7 +13,7 @@ -- * SkolemInfo SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo, - unkSkol, unkSkolAnon, + unkSkol, unkSkolAnon, mkClsInstSkol, -- * CtOrigin CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, @@ -31,7 +28,8 @@ -- * FixedRuntimeRep origin FixedRuntimeRepOrigin(..), FixedRuntimeRepContext(..), pprFixedRuntimeRepContext, - StmtOrigin(..), + StmtOrigin(..), RepPolyFun(..), ArgPos(..), + ClsInstOrQC(..), NakedScFlag(..), -- * Arrow command origin FRRArrowContext(..), pprFRRArrowContext, @@ -48,6 +46,7 @@ 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 ) @@ -68,6 +67,8 @@ import GHC.Types.Unique import GHC.Types.Unique.Supply +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + {- ********************************************************************* * * UserTypeCtxt @@ -211,8 +212,9 @@ -- same place in a single report. data SkolemInfo = SkolemInfo - Unique -- ^ used to common up skolem variables bound at the same location (only used in pprSkols) - SkolemInfoAnon -- ^ the information about the origin of the skolem type variable + Unique -- ^ The Unique is used to common up skolem variables bound + -- at the same location (only used in pprSkols) + SkolemInfoAnon -- ^ The information about the origin of the skolem type variable instance Uniquable SkolemInfo where getUnique (SkolemInfo u _) = u @@ -249,7 +251,9 @@ | DerivSkol Type -- Bound by a 'deriving' clause; -- the type is the instance we are trying to derive - | InstSkol -- Bound at an instance decl + | InstSkol -- Bound at an instance decl, or quantified constraint + ClsInstOrQC -- Whether class instance or quantified constraint + PatersonSize -- Head has the given PatersonSize | FamInstSkol -- Bound at a family instance decl | PatSkol -- An existential type variable bound by a pattern for @@ -265,7 +269,7 @@ | RuleSkol RuleName -- The LHS of a RULE | InferSkol [(Name,TcType)] - -- We have inferred a type for these (mutually-recursivive) + -- We have inferred a type for these (mutually recursive) -- polymorphic Ids, and are now checking that their RHS -- constraints are satisfied. @@ -281,9 +285,6 @@ | ReifySkol -- Bound during Template Haskell reification - | QuantCtxtSkol -- Quantified context, e.g. - -- f :: forall c. (forall a. c a => c [a]) => blah - | RuntimeUnkSkol -- Runtime skolem from the GHCi debugger #14628 | ArrowReboundIfSkol -- Bound by the expected type of the rebound arrow ifThenElse command. @@ -313,6 +314,8 @@ 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 @@ -328,7 +331,10 @@ pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" <+> pprWithCommas ppr ips pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) -pprSkolInfo InstSkol = text "the instance declaration" +pprSkolInfo (InstSkol IsClsInst sz) = vcat [ text "the instance declaration" + , whenPprDebug (braces (ppr sz)) ] +pprSkolInfo (InstSkol (IsQC {}) sz) = vcat [ text "a quantified context" + , whenPprDebug (braces (ppr sz)) ] pprSkolInfo FamInstSkol = text "a family instance declaration" pprSkolInfo BracketSkol = text "a Template Haskell bracket" pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name @@ -342,7 +348,6 @@ pprSkolInfo (DataConSkol name) = text "the type signature for" <+> quotes (ppr name) pprSkolInfo ReifySkol = text "the type being reified" -pprSkolInfo (QuantCtxtSkol {}) = text "a quantified context" pprSkolInfo RuntimeUnkSkol = text "Unknown type from GHCi runtime" pprSkolInfo ArrowReboundIfSkol = text "the expected type of a rebound if-then-else command" @@ -451,40 +456,26 @@ -- 'SkolemInfo' inside gives more information. GivenOrigin SkolemInfoAnon - -- The following are other origins for given constraints that cannot produce - -- new skolems -- hence no SkolemInfo. - - -- | 'InstSCOrigin' is used for a Given constraint obtained by superclass selection + -- | 'GivenSCOrigin' is used for a Given constraint obtained by superclass selection -- from the context of an instance declaration. E.g. -- instance @(Foo a, Bar a) => C [a]@ where ... -- When typechecking the instance decl itself, including producing evidence -- for the superclasses of @C@, the superclasses of @(Foo a)@ and @(Bar a)@ will - -- have 'InstSCOrigin' origin. - | InstSCOrigin ScDepth -- ^ The number of superclass selections necessary to - -- get this constraint; see Note [Replacement vs keeping] - -- and Note [Use only the best local instance], both in - -- GHC.Tc.Solver.Interact - TypeSize -- ^ If @(C ty1 .. tyn)@ is the largest class from - -- which we made a superclass selection in the chain, - -- then @TypeSize = sizeTypes [ty1, .., tyn]@ - -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + -- have 'GivenSCOrigin' origin. + | GivenSCOrigin + SkolemInfoAnon -- ^ Just like GivenOrigin - -- | 'OtherSCOrigin' is used for a Given constraint obtained by superclass - -- selection from a constraint /other than/ the context of an instance - -- declaration. (For the latter we use 'InstSCOrigin'.) E.g. - -- f :: Foo a => blah - -- f = e - -- When typechecking body of 'f', the superclasses of the Given (Foo a) - -- will have 'OtherSCOrigin'. - -- Needed for Note [Replacement vs keeping] and - -- Note [Use only the best local instance], both in GHC.Tc.Solver.Interact. - | OtherSCOrigin ScDepth -- ^ The number of superclass selections necessary to - -- get this constraint - SkolemInfoAnon -- ^ Where the sub-class constraint arose from - -- (used only for printing) + ScDepth -- ^ The number of superclass selections necessary to + -- get this constraint; see Note [Replacement vs keeping] + -- in GHC.Tc.Solver.Interact - -- All the others are for *wanted* constraints + Bool -- ^ True => "blocked": cannot use this to solve naked superclass Wanteds + -- i.e. ones with (ScOrigin _ NakedSc) + -- False => can use this to solve all Wanted constraints + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + ----------- 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 @@ -532,11 +523,10 @@ | ViewPatOrigin -- | 'ScOrigin' is used only for the Wanted constraints for the - -- superclasses of an instance declaration. - -- If the instance head is @C ty1 .. tyn@ - -- then @TypeSize = sizeTypes [ty1, .., tyn]@ - -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance - | ScOrigin TypeSize + -- superclasses of an instance declaration. + | ScOrigin + ClsInstOrQC -- Whether class instance or quantified constraint + NakedScFlag | DerivClauseOrigin -- Typechecking a deriving clause (as opposed to -- standalone deriving). @@ -581,7 +571,7 @@ PredType CtOrigin RealSrcSpan -- This constraint arising from ... PredType CtOrigin RealSrcSpan -- and this constraint arising from ... - | ExprHoleOrigin (Maybe OccName) -- from an expression hole + | ExprHoleOrigin (Maybe RdrName) -- from an expression hole | TypeHoleOrigin OccName -- from a type hole (partial type signature) | PatCheckOrigin -- normalisation of a type during pattern-match checking | ListOrigin -- An overloaded list @@ -605,6 +595,7 @@ | CycleBreakerOrigin CtOrigin -- origin of the original constraint + -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Canonical | FRROrigin FixedRuntimeRepOrigin @@ -620,11 +611,25 @@ Type -- the instantiated type of the method | AmbiguityCheckOrigin UserTypeCtxt + -- | 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 NakedScFlag = NakedSc | NotNakedSc + -- The NakedScFlag affects only GHC.Tc.Solver.InertSet.prohibitedSuperClassSolve + -- * For the original superclass constraints we use (ScOrigin _ NakedSc) + -- * But after using an instance declaration we use (ScOrigin _ NotNakedSc) + -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance + +instance Outputable NakedScFlag where + ppr NakedSc = text "NakedSc" + ppr NotNakedSc = text "NotNakedSc" + -- An origin is visible if the place where the constraint arises is manifest -- in user code. Currently, all origins are visible except for invisible -- TypeEqOrigins. This is used when choosing which error of @@ -641,11 +646,10 @@ toInvisibleOrigin orig = orig isGivenOrigin :: CtOrigin -> Bool -isGivenOrigin (GivenOrigin {}) = True -isGivenOrigin (InstSCOrigin {}) = True -isGivenOrigin (OtherSCOrigin {}) = True -isGivenOrigin (CycleBreakerOrigin o) = isGivenOrigin o -isGivenOrigin _ = False +isGivenOrigin (GivenOrigin {}) = True +isGivenOrigin (GivenSCOrigin {}) = True +isGivenOrigin (CycleBreakerOrigin o) = isGivenOrigin o +isGivenOrigin _ = False -- See Note [Suppressing confusing errors] in GHC.Tc.Errors isWantedWantedFunDepOrigin :: CtOrigin -> Bool @@ -673,10 +677,10 @@ exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name -exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (unLoc $ dfoLabel f) +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 (HsOverLabel _ _ l) = OverLabelOrigin l exprCtOrigin (ExplicitList {}) = ListOrigin exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit @@ -684,7 +688,7 @@ exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches exprCtOrigin (HsLamCase _ _ 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 @@ -705,7 +709,8 @@ exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e exprCtOrigin (HsTypedBracket {}) = Shouldn'tHappenOrigin "TH typed bracket" exprCtOrigin (HsUntypedBracket {}) = Shouldn'tHappenOrigin "TH untyped bracket" -exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice" +exprCtOrigin (HsTypedSplice {}) = Shouldn'tHappenOrigin "TH typed splice" +exprCtOrigin (HsUntypedSplice {}) = Shouldn'tHappenOrigin "TH untyped splice" exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a @@ -731,10 +736,13 @@ pprCtOrigin :: CtOrigin -> SDoc -- "arising from ..." -pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk -pprCtOrigin (InstSCOrigin {}) = ctoHerald <+> pprSkolInfo InstSkol -- keep output in sync -pprCtOrigin (OtherSCOrigin _ si) = ctoHerald <+> pprSkolInfo si +pprCtOrigin (GivenOrigin sk) + = ctoHerald <+> ppr sk +pprCtOrigin (GivenSCOrigin sk d blk) + = vcat [ ctoHerald <+> pprSkolInfo sk + , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ] + pprCtOrigin (SpecPragOrigin ctxt) = case ctxt of FunSigCtxt n _ -> text "for" <+> quotes (ppr n) @@ -817,9 +825,6 @@ pprCtOrigin (CycleBreakerOrigin orig) = pprCtOrigin orig -pprCtOrigin (FRROrigin {}) - = ctoHerald <+> text "a representation-polymorphism check" - pprCtOrigin (WantedSuperclassOrigin subclass_pred subclass_orig) = sep [ ctoHerald <+> text "a superclass required to satisfy" <+> quotes (ppr subclass_pred) <> comma , pprCtOrigin subclass_orig ] @@ -836,6 +841,15 @@ = ctoHerald <+> text "a type ambiguity check for" $$ pprUserTypeCtxt ctxt +pprCtOrigin (ScOrigin IsClsInst nkd) + = 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 simple_origin = ctoHerald <+> pprCtO simple_origin @@ -859,8 +873,8 @@ pprCtO AssocFamPatOrigin = text "the LHS of a family instance" pprCtO TupleOrigin = text "a tuple" pprCtO NegateOrigin = text "a use of syntactic negation" -pprCtO (ScOrigin n) = text "the superclasses of an instance declaration" - <> whenPprDebug (parens (ppr n)) +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" @@ -884,8 +898,7 @@ -- get here via callStackOriginFS, when doing ambiguity checks -- A bit silly, but no great harm pprCtO (GivenOrigin {}) = text "a given constraint" -pprCtO (InstSCOrigin {}) = text "the superclass of an instance constraint" -pprCtO (OtherSCOrigin {}) = text "the superclass of 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" @@ -990,10 +1003,14 @@ -- 'FixedRuntimeRepOrigin' for that. data FixedRuntimeRepContext + -- | Record fields in record construction must have a fixed runtime + -- representation. + = FRRRecordCon !RdrName !(HsExpr GhcTc) + -- | Record fields in record updates must have a fixed runtime representation. -- -- Test case: RepPolyRecordUpdate. - = FRRRecordUpdate !RdrName !(HsExpr GhcTc) + | FRRRecordUpdate !Name !(HsExpr GhcRn) -- | Variable binders must have a fixed runtime representation. -- @@ -1016,21 +1033,17 @@ -- Test cases: RepPolyCase{1,2}. | FRRCase - -- | An instantiation of a newtype/data constructor in which + -- | An instantiation of a newtype/data constructor pattern in which -- an argument type does not have a fixed runtime representation. -- - -- The argument can either be an expression or a pattern. - -- - -- Test cases: - -- Expression: UnliftedNewtypesLevityBinder. - -- Pattern: T20363. - | FRRDataConArg !ExprOrPat !DataCon !Int + -- Test case: T20363. + | FRRDataConPatArg !DataCon !Int - -- | An instantiation of an 'Id' with no binding (e.g. `coerce`, `unsafeCoerce#`) + -- | 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, UnliftedNewtypesCoerceFail. - | FRRNoBindingResArg !Id !Int + -- Test cases: RepPolyWrappedVar, T14561, UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail. + | FRRNoBindingResArg !RepPolyFun !ArgPos -- | Arguments to unboxed tuples must have fixed runtime representations. -- @@ -1053,7 +1066,7 @@ -- Test cases: RepPolyDoBody{1,2}, RepPolyMcBody. | FRRBodyStmt !StmtOrigin !Int - -- | Arguments to a guard in a monad comprehesion must have + -- | Arguments to a guard in a monad comprehension must have -- a fixed runtime representation. -- -- Test case: RepPolyMcGuard. @@ -1090,6 +1103,9 @@ -- which is not fixed. That information is stored in 'FixedRuntimeRepOrigin' -- and is reported separately. pprFixedRuntimeRepContext :: FixedRuntimeRepContext -> SDoc +pprFixedRuntimeRepContext (FRRRecordCon lbl _arg) + = sep [ text "The field", quotes (ppr lbl) + , text "of the record constructor" ] pprFixedRuntimeRepContext (FRRRecordUpdate lbl _arg) = sep [ text "The record update at field" , quotes (ppr lbl) ] @@ -1102,21 +1118,33 @@ = text "The pattern synonym argument pattern" pprFixedRuntimeRepContext FRRCase = text "The scrutinee of the case statement" -pprFixedRuntimeRepContext (FRRDataConArg expr_or_pat con i) +pprFixedRuntimeRepContext (FRRDataConPatArg con i) = text "The" <+> what where - arg, what :: SDoc - arg = case expr_or_pat of - Expression -> text "argument" - Pattern -> text "pattern" + what :: SDoc what | isNewDataCon con - = text "newtype constructor" <+> arg + = text "newtype constructor pattern" | otherwise - = text "data constructor" <+> arg <+> text "in" <+> speakNth i <+> text "position" -pprFixedRuntimeRepContext (FRRNoBindingResArg fn i) - = vcat [ text "Unsaturated use of a representation-polymorphic primitive function." - , text "The" <+> speakNth i <+> text "argument of" <+> quotes (ppr $ getName fn) ] + = 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) @@ -1152,6 +1180,30 @@ instance Outputable StmtOrigin where 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 + -- ^ Invisible argument: don't report its position to the user. + | ArgPosVis !Int + -- ^ Visible argument in i-th position. {- ********************************************************************* * * 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 @@ -7,4 +7,8 @@ data FixedRuntimeRepContext data FixedRuntimeRepOrigin +data CtOrigin +data ClsInstOrQC = IsClsInst + | IsQC CtOrigin + unkSkol :: HasCallStack => SkolemInfo 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 @@ -27,7 +27,6 @@ import GHC.Types.Fixity.Env import GHC.Types.TypeEnv import GHC.Types.Name.Reader -import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -35,6 +34,7 @@ import GHC.Types.SrcLoc import GHC.Types.SourceFile import GHC.Types.Var +import GHC.Types.Id( idType ) import GHC.Types.Unique.DSet import GHC.Types.Name.Shape import GHC.Types.PkgQual @@ -62,8 +62,6 @@ import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import GHC.Core.Type -import GHC.Core.Multiplicity import GHC.IfaceToCore import GHC.Iface.Load @@ -90,9 +88,10 @@ import {-# SOURCE #-} GHC.Tc.Module + fixityMisMatch :: TyThing -> Fixity -> Fixity -> TcRnMessage fixityMisMatch real_thing real_fixity sig_fixity = - TcRnUnknownMessage $ mkPlainError noHints $ + 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, @@ -169,7 +168,7 @@ -- tcg_env (TODO: but maybe this isn't relevant anymore). r <- tcLookupImported_maybe name case r of - Failed err -> addErr (TcRnUnknownMessage $ mkPlainError noHints err) + Failed err -> addErr (TcRnInterfaceLookupError name err) Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing -- The hsig did NOT define this function; that means it must @@ -220,32 +219,23 @@ -- (we might conclude the module exports an instance when it doesn't, see -- #9422), but we will never refuse to compile something. check_inst :: ClsInst -> TcM () -check_inst sig_inst = do +check_inst sig_inst@(ClsInst { is_dfun = dfun_id }) = do -- TODO: This could be very well generalized to support instance -- declarations in boot files. tcg_env <- getGblEnv -- 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 ty = idType (instanceDFunId sig_inst) - -- Based off of tcSplitDFunTy - (tvs, theta, pred) = - case tcSplitForAllInvisTyVars ty of { (tvs, rho) -> - case splitFunTys rho of { (theta, pred) -> - (tvs, theta, pred) }} - origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst - skol_info <- mkSkolemInfo InstSkol - (skol_subst, tvs_skols) <- tcInstSkolTyVars skol_info tvs -- Skolemize + 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 - wanted <- newWanted origin - (Just TypeLevel) - (substTy skol_subst pred) - givens <- forM theta $ \given -> do + wanted <- newWanted origin (Just TypeLevel) (mkClassPred cls inst_tys) + givens <- forM inst_theta $ \given -> do loc <- getCtLocM origin (Just TypeLevel) - let given_pred = substTy skol_subst (scaledThing given) - new_ev <- newEvVar given_pred - return CtGiven { ctev_pred = given_pred + new_ev <- newEvVar given + return CtGiven { ctev_pred = given -- Doesn't matter, make something up , ctev_evar = new_ev , ctev_loc = loc @@ -253,7 +243,7 @@ return $ wanted : givens unsolved <- simplifyWantedsTcM cts - (implic, _) <- buildImplicationFor tclvl (getSkolemInfo skol_info) tvs_skols [] unsolved + (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved reportAllUnsolved (mkImplicWC implic) -- | For a module @modname@ of type 'HscSource', determine the list @@ -687,7 +677,7 @@ -- 3(d). Extend the name substitution (performing shaping) mb_r <- extend_ns nsubst as2 case mb_r of - Left err -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints err) + Left err -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints 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)) @@ -855,7 +845,6 @@ -- we hope that we get lucky / the overlapping instances never -- get used, but it is not a very good situation to be in. -- - hsc_env <- getTopEnv let merge_inst (insts, inst_env) inst | memberInstEnv inst_env inst -- test DFun Type equality = (insts, inst_env) @@ -866,18 +855,17 @@ (insts, inst_env) = foldl' merge_inst (tcg_insts tcg_env, tcg_inst_env tcg_env) (instEnvElts $ md_insts details) - -- This is a HACK to prevent calculateAvails from including imp_mod - -- in the listing. We don't want it because a module is NOT + -- Use mi_deps directly rather than calculateAvails. + -- because a module is NOT -- supposed to include itself in its dep_orphs/dep_finsts. See #13214 - iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } } - home_unit = hsc_home_unit hsc_env - other_home_units = hsc_all_home_unit_ids hsc_env - avails = plusImportAvails (tcg_imports tcg_env) $ - calculateAvails home_unit other_home_units iface' False NotBoot ImportedBySystem + avails = tcg_imports tcg_env + deps = mi_deps iface + avails_with_trans = addTransitiveDepInfo avails deps + return tcg_env { tcg_inst_env = inst_env, tcg_insts = insts, - tcg_imports = avails, + tcg_imports = avails_with_trans, tcg_merged = if outer_mod == mi_module iface -- Don't add ourselves! @@ -911,6 +899,20 @@ return tcg_env +-- | Add on the necessary transitive information from the merged signature to +-- the 'ImportAvails' of the result of merging. This propagates the orphan instances +-- which were in the transitive closure of the signature through the merge. +addTransitiveDepInfo :: ImportAvails -- ^ From the signature resulting from the merge + -> Dependencies -- ^ From the original signature + -> ImportAvails +addTransitiveDepInfo avails deps = + -- Avails for the merged in signature + -- Add on transitive information from the signature but nothing else.. + -- because we do not "import" the signature. + avails { imp_orphs = imp_orphs avails ++ dep_orphs deps + , imp_finsts = imp_finsts avails ++ dep_finsts deps + , imp_sig_mods = imp_sig_mods avails ++ dep_sig_mods deps } + -- | Top-level driver for signature instantiation (run when compiling -- an @hsig@ file.) tcRnInstantiateSignature :: @@ -994,7 +996,7 @@ isig_mod sig_mod NotBoot isig_iface <- case mb_isig_iface of Succeeded (iface, _) -> return iface - Failed err -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ + Failed err -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ hang (text "Could not find hi interface for signature" <+> quotes (ppr isig_mod) <> colon) 4 err @@ -1002,7 +1004,7 @@ -- we need. (Notice we IGNORE the Modules in the AvailInfos.) forM_ (exportOccs (mi_exports isig_iface)) $ \occ -> case lookupGlobalRdrEnv impl_gr occ of - [] -> addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + [] -> 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) 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 @@ -18,16 +18,16 @@ import GHC.Builtin.Types ( liftedTypeKindTyCon, unliftedTypeKindTyCon ) -import GHC.Core.Coercion ( coToMCo, mkCastTyMCo ) +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, tcView +import GHC.Core.Type ( isConcrete, typeKind, tyVarKind, coreView , mkTyVarTy, mkTyConApp, mkFunTy, mkAppTy ) import GHC.Tc.Types ( TcM, ThStage(..), PendingStuff(..) ) import GHC.Tc.Types.Constraint ( NotConcreteError(..), NotConcreteReason(..) ) -import GHC.Tc.Types.Evidence ( Role(..), TcCoercionN, TcMCoercionN - , mkTcGReflRightMCo, mkTcNomReflCo ) +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 @@ -455,12 +455,12 @@ -- Otherwise: ensure that the kind 'ki' of 'ty' is concrete. | otherwise -> do { kco <- check_kind frr_orig ki - ; return ( mkTcGReflRightMCo Nominal ty kco + ; return ( mkGReflRightMCo Nominal ty kco , mkCastTyMCo ty kco ) } } where refl :: (TcCoercionN, TcType) - refl = (mkTcNomReflCo ty, ty) + refl = (mkNomReflCo ty, ty) ki :: TcKind ki = typeKind ty frr_orig :: FixedRuntimeRepOrigin @@ -634,7 +634,7 @@ where go :: TcType -> WriterT [NotConcreteReason] TcM TcType go ty - | Just ty <- tcView ty + | Just ty <- coreView ty = go ty | isConcrete ty = pure ty 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 @@ -257,7 +257,7 @@ do { mb_thing <- tcLookupImported_maybe name ; case mb_thing of Succeeded thing -> return thing - Failed msg -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints msg) + Failed msg -> failWithTc (TcRnInterfaceLookupError name msg) }}} -- Look up only in this module's global env't. Don't look in imports, etc. @@ -328,17 +328,17 @@ = do { instEnv <- tcGetInstEnvs ; case lookupUniqueInstEnv instEnv cls tys of Left err -> - failWithTc $ TcRnUnknownMessage + failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints (text "Couldn't match instance:" <+> err) Right (inst, tys) | uniqueTyVars tys -> return inst - | otherwise -> failWithTc (TcRnUnknownMessage $ mkPlainError noHints errNotExact) + | otherwise -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints errNotExact) } where errNotExact = text "Not an exact match (i.e., some variables get instantiated)" uniqueTyVars tys = all isTyVarTy tys - && hasNoDups (map (getTyVar "tcLookupInstance") tys) + && hasNoDups (map getTyVar tys) tcGetInstEnvs :: TcM InstEnvs -- Gets both the external-package inst-env @@ -553,7 +553,7 @@ names = [(name, ATyVar name tv) | (name, tv) <- binds] isTypeClosedLetBndr :: Id -> Bool --- See Note [Bindings with closed types] in GHC.Tc.Types +-- See Note [Bindings with closed types: ClosedTypeId] in GHC.Tc.Types isTypeClosedLetBndr = noFreeVarsOfType . idType tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a @@ -684,7 +684,7 @@ ; traceTc "check_then_add_usage" (ppr id_mult $$ ppr actual_u) ; wrapper <- case actual_u of Bottom -> return idHsWrapper - Zero -> tcSubMult (UsageEnvironmentOf name) Many id_mult + Zero -> tcSubMult (UsageEnvironmentOf name) ManyTy id_mult MUsage m -> do { m <- promote_mult m ; tcSubMult (UsageEnvironmentOf name) m id_mult } ; tcEmitBindingUsage (deleteUE uenv name) @@ -853,7 +853,7 @@ It is entirely reasonable to reject this, but to do so we need A to be in the kind environment when kind-checking the signature for B. -Hence tcAddPatSynPlaceholers adds a binding +Hence tcAddPatSynPlaceholders adds a binding A -> APromotionErr PatSynPE to the environment. Then GHC.Tc.Gen.HsType.tcTyVar will find A in the kind environment, and will give a 'wrongThingErr' as a result. But the @@ -899,7 +899,7 @@ | otherwise -- Badly staged = failWithTc $ -- E.g. \x -> $(f x) - TcRnUnknownMessage $ mkPlainError noHints $ + 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] @@ -907,7 +907,7 @@ stageRestrictionError :: SDoc -> TcM a stageRestrictionError pp_thing = failWithTc $ - TcRnUnknownMessage $ mkPlainError noHints $ + 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"])] @@ -961,7 +961,7 @@ -- User-supplied defaults Nothing -> do - -- No use-supplied default + -- No user-supplied default -- Use [Integer, Double], plus modifications { integer_ty <- tcMetaTy integerTyConName ; list_ty <- tcMetaTy listTyConName @@ -1125,7 +1125,7 @@ => IORef (ModuleEnv Int) -> String -> String -> m FastString -- ^ @mkWrapperName ref what nameBase@ -- --- See Note [Generating fresh names for ccall wrapper] for @ref@'s purpose. +-- See Note [Generating fresh names for FFI wrappers] for @ref@'s purpose. mkWrapperName wrapperRef what nameBase = do thisMod <- getModule let pkg = unitString (moduleUnit thisMod) @@ -1139,7 +1139,7 @@ {- Note [Generating fresh names for FFI wrappers] - +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to use a unique, rather than nextWrapperNum, to distinguish between FFI wrapper functions. However, the wrapper names that we generate are external names. This means that if a call to them ends up @@ -1175,7 +1175,7 @@ -- don't report it again (#11941) | otherwise -> stageRestrictionError (quotes (ppr name)) _ -> failWithTc $ - TcRnUnknownMessage $ mkPlainError noHints $ + 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)] @@ -1187,11 +1187,8 @@ } wrongThingErr :: String -> TcTyThing -> Name -> TcM a --- It's important that this only calls pprTcTyThingCategory, which in --- turn does not look at the details of the TcTyThing. --- See Note [Placeholder PatSyn kinds] in GHC.Tc.Gen.Bind wrongThingErr expected thing name - = let msg = TcRnUnknownMessage $ mkPlainError noHints $ + = let msg = mkTcRnUnknownMessage $ mkPlainError noHints $ (pprTcTyThingCategory thing <+> quotes (ppr name) <+> text "used as a" <+> text expected) in failWithTc msg 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,9 +1,7 @@ - -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, RecursiveDo #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The University of Glasgow 2006 @@ -179,7 +177,7 @@ topSkolemise skolem_info ty = go init_subst idHsWrapper [] [] ty where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) -- Why recursive? See Note [Skolemisation] go subst wrap tv_prs ev_vars ty @@ -188,7 +186,7 @@ = do { (subst', tvs1) <- tcInstSkolTyVarsX skolem_info subst tvs ; ev_vars1 <- newEvVars (substTheta subst' theta) ; go subst' - (wrap <.> mkWpTyLams tvs1 <.> mkWpLams ev_vars1) + (wrap <.> mkWpTyLams tvs1 <.> mkWpEvLams ev_vars1) (tv_prs ++ (map tyVarName tvs `zip` tvs1)) (ev_vars ++ ev_vars1) inner_ty } @@ -204,7 +202,7 @@ -- NB: returns a type with no (=>), -- and no invisible forall at the top topInstantiate orig sigma - | (tvs, body1) <- tcSplitSomeForAllTyVars isInvisibleArgFlag sigma + | (tvs, body1) <- tcSplitSomeForAllTyVars isInvisibleForAllTyFlag sigma , (theta, body2) <- tcSplitPhiTy body1 , not (null tvs && null theta) = do { (_, wrap1, body3) <- instantiateSigma orig tvs theta body2 @@ -220,7 +218,7 @@ instantiateSigma :: CtOrigin -> [TyVar] -> TcThetaType -> TcSigmaType -> TcM ([TcTyVar], HsWrapper, TcSigmaType) -- (instantiate orig tvs theta ty) --- instantiates the the type variables tvs, emits the (instantiated) +-- 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 @@ -241,16 +239,16 @@ where free_tvs = tyCoVarsOfType body_ty `unionVarSet` tyCoVarsOfTypes theta in_scope = mkInScopeSet (free_tvs `delVarSetList` tvs) - empty_subst = mkEmptyTCvSubst in_scope + empty_subst = mkEmptySubst in_scope -instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst +instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM Subst -- Use this when you want to instantiate (forall a b c. ty) with -- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might -- not yet match (perhaps because there are unsolved constraints; #14154) -- If they don't match, emit a kind-equality to promise that they will --- eventually do so, and thus make a kind-homongeneous substitution. +-- eventually do so, and thus make a kind-homogeneous substitution. instTyVarsWith orig tvs tys - = go emptyTCvSubst tvs tys + = go emptySubst tvs tys where go subst [] [] = return subst @@ -262,7 +260,7 @@ ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys } where tv_kind = substTy subst (tyVarKind tv) - ty_kind = tcTypeKind ty + ty_kind = typeKind ty go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys) @@ -335,11 +333,11 @@ where dfun_ty = idType dfun_id (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty)) + empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType dfun_ty)) -- With quantified constraints, the -- type of a dfun may not be closed - go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType]) + go :: Subst -> [TyVar] -> [DFunInstType] -> TcM (Subst, [TcType]) go subst [] [] = return (subst, []) go subst (tv:tvs) (Just ty : mb_tys) = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty) @@ -369,6 +367,7 @@ -- | Given ty::forall k1 k2. k, instantiate all the invisible forall-binders -- returning ty @kk1 @kk2 :: k[kk1/k1, kk2/k1] +-- Called only to instantiate kinds, in user-written type signatures tcInstInvisibleTyBinders :: TcType -> TcKind -> TcM (TcType, TcKind) tcInstInvisibleTyBinders ty kind = do { (extra_args, kind') <- tcInstInvisibleTyBindersN n_invis kind @@ -377,37 +376,40 @@ n_invis = invisibleTyBndrCount kind tcInstInvisibleTyBindersN :: Int -> TcKind -> TcM ([TcType], TcKind) +-- Called only to instantiate kinds, in user-written type signatures tcInstInvisibleTyBindersN 0 kind = return ([], kind) tcInstInvisibleTyBindersN n ty = go n empty_subst ty where - empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) + empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) go n subst kind | n > 0 , Just (bndr, body) <- tcSplitPiTy_maybe kind - , isInvisibleBinder bndr + , isInvisiblePiTyBinder bndr = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr ; (args, inner_ty) <- go (n-1) subst' body ; return (arg:args, inner_ty) } | otherwise = return ([], substTy subst kind) --- | Used only in *types* -tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) +tcInstInvisibleTyBinder :: Subst -> PiTyVarBinder -> TcM (Subst, TcType) +-- Called only to instantiate kinds, in user-written type signatures + tcInstInvisibleTyBinder subst (Named (Bndr tv _)) = do { (subst', tv') <- newMetaTyVarX subst tv ; return (subst', mkTyVarTy tv') } -tcInstInvisibleTyBinder subst (Anon af ty) +tcInstInvisibleTyBinder subst (Anon ty af) | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst (scaledThing ty)) - -- Equality is the *only* constraint currently handled in types. + -- 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 - = assert (af == InvisArg) $ + -- Equality is the *only* constraint currently handled in types. + = assert (isInvisibleFunArg af) $ do { co <- unifyKind Nothing k1 k2 - ; arg' <- mk co - ; return (subst, arg') } + ; return (subst, mk co) } | otherwise -- This should never happen -- See GHC.Core.TyCo.Rep Note [Constraints in kinds] @@ -415,9 +417,9 @@ ------------------------------- get_eq_tys_maybe :: Type - -> Maybe ( Coercion -> TcM Type - -- given a coercion proving t1 ~# t2, produce the - -- right instantiation for the TyBinder at hand + -> Maybe ( Coercion -> Type + -- Given a coercion proving t1 ~# t2, produce the + -- right instantiation for the PiTyVarBinder at hand , Type -- t1 , Type -- t2 ) @@ -426,31 +428,28 @@ -- Lifted heterogeneous equality (~~) | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty , tc `hasKey` heqTyConKey - = Just (\co -> mkHEqBoxTy co k1 k2, k1, k2) + = Just (mkHEqBoxTy k1 k2, k1, k2) -- Lifted homogeneous equality (~) | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty , tc `hasKey` eqTyConKey - = Just (\co -> mkEqBoxTy co k1 k2, k1, k2) + = Just (mkEqBoxTy k1 k2, k1, k2) | otherwise = Nothing -- | This takes @a ~# b@ and returns @a ~~ b@. -mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type --- monadic just for convenience with mkEqBoxTy -mkHEqBoxTy co ty1 ty2 - = return $ - mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co] - where k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 +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 :: TcCoercion -> Type -> Type -> TcM Type -mkEqBoxTy co ty1 ty2 - = return $ - mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co] - where k = tcTypeKind ty1 +mkEqBoxTy :: Type -> Type -> TcCoercion -> Type +mkEqBoxTy ty1 ty2 co + = mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co] + where k = typeKind ty1 {- ********************************************************************* * * @@ -458,7 +457,7 @@ * * ********************************************************************* -} -tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar])) +tcInstType :: ([TyVar] -> TcM (Subst, [TcTyVar])) -- ^ How to instantiate the type variables -> Id -- ^ Type to instantiate -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result @@ -470,50 +469,62 @@ | otherwise = do { (subst, tyvars') <- inst_tyvars tyvars ; let tv_prs = map tyVarName tyvars `zip` tyvars' - subst' = extendTCvInScopeSet subst (tyCoVarsOfType rho) + subst' = extendSubstInScopeSet subst (tyCoVarsOfType rho) ; return (tv_prs, substTheta subst' theta, substTy subst' tau) } where (tyvars, rho) = tcSplitForAllInvisTyVars (idType id) (theta, tau) = tcSplitPhiTy rho -tcInstTypeBndrs :: Id -> TcM ([(Name, InvisTVBinder)], TcThetaType, TcType) +tcInstTypeBndrs :: Type -> TcM ([(Name, InvisTVBinder)], TcThetaType, TcType) -- (type vars, preds (incl equalities), rho) -- Instantiate the binders of a type signature with TyVarTvs -tcInstTypeBndrs id +tcInstTypeBndrs poly_ty | null tyvars -- There may be overloading despite no type variables; -- (?x :: Int) => Int -> Int = return ([], theta, tau) | otherwise - = do { (subst, tyvars') <- mapAccumLM inst_invis_bndr emptyTCvSubst tyvars + = do { (subst, tyvars') <- mapAccumLM inst_invis_bndr emptySubst tyvars ; let tv_prs = map (tyVarName . binderVar) tyvars `zip` tyvars' - subst' = extendTCvInScopeSet subst (tyCoVarsOfType rho) + subst' = extendSubstInScopeSet subst (tyCoVarsOfType rho) ; return (tv_prs, substTheta subst' theta, substTy subst' tau) } where - (tyvars, rho) = splitForAllInvisTVBinders (idType id) + (tyvars, rho) = tcSplitForAllInvisTVBinders poly_ty (theta, tau) = tcSplitPhiTy rho - inst_invis_bndr :: TCvSubst -> InvisTVBinder - -> TcM (TCvSubst, InvisTVBinder) + inst_invis_bndr :: Subst -> InvisTVBinder + -> TcM (Subst, InvisTVBinder) inst_invis_bndr subst (Bndr tv spec) = do { (subst', tv') <- newMetaTyVarTyVarX subst tv ; return (subst', Bndr tv' spec) } -------------------------- -tcSkolDFunType :: SkolemInfo -> DFunId -> TcM ([TcTyVar], TcThetaType, TcType) +tcSkolDFunType :: Type -> TcM (SkolemInfoAnon, [TcTyVar], TcThetaType, Class, [TcType]) -- Instantiate a type signature with skolem constants. -- This freshens the names, but no need to do so -tcSkolDFunType skol_info dfun - = do { (tv_prs, theta, tau) <- tcInstType (tcInstSuperSkolTyVars skol_info) dfun - ; return (map snd tv_prs, theta, tau) } +tcSkolDFunType dfun_ty + = do { let (tvs, theta, cls, tys) = tcSplitDFunTy dfun_ty -tcSuperSkolTyVars :: TcLevel -> SkolemInfo -> [TyVar] -> (TCvSubst, [TcTyVar]) + -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] + -- in GHC.Tc.Utils.TcType + ; rec { skol_info <- mkSkolemInfo skol_info_anon + ; (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 } + + ; let inst_theta = substTheta subst theta + ; return (skol_info_anon, inst_tvs, inst_theta, cls, inst_tys) } + +tcSuperSkolTyVars :: TcLevel -> SkolemInfo -> [TyVar] -> (Subst, [TcTyVar]) -- 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] -- See Note [Kind substitution when instantiating] -- Precondition: tyvars should be ordered by scoping -tcSuperSkolTyVars tc_lvl skol_info = mapAccumL do_one emptyTCvSubst +tcSuperSkolTyVars tc_lvl skol_info = mapAccumL do_one emptySubst where details = SkolemTv skol_info (pushTcLevel tc_lvl) True -- The "super" bit @@ -525,29 +536,31 @@ -- | Given a list of @['TyVar']@, skolemize the type variables, -- returning a substitution mapping the original tyvars to the -- skolems, and the list of newly bound skolems. -tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (Subst, [TcTyVar]) -- See Note [Skolemising type variables] -tcInstSkolTyVars skol_info = tcInstSkolTyVarsX skol_info emptyTCvSubst +tcInstSkolTyVars skol_info = tcInstSkolTyVarsX skol_info emptySubst -tcInstSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) -- See Note [Skolemising type variables] tcInstSkolTyVarsX skol_info = tcInstSkolTyVarsPushLevel skol_info False -tcInstSuperSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSuperSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (Subst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; --- see comments around superSkolemTv. -tcInstSuperSkolTyVars skol_info = tcInstSuperSkolTyVarsX skol_info emptyTCvSubst +-- see comments around superSkolemTv. +-- Must be lazy in skol_info: +-- see Note [Keeping SkolemInfo inside a SkolemTv] in GHC.Tc.Utils.TcType +tcInstSuperSkolTyVars skol_info = tcInstSuperSkolTyVarsX skol_info emptySubst -tcInstSuperSkolTyVarsX :: SkolemInfo -> TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +tcInstSuperSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) -- See Note [Skolemising type variables] -- This version freshens the names and creates "super skolems"; -- see comments around superSkolemTv. tcInstSuperSkolTyVarsX skol_info subst = tcInstSkolTyVarsPushLevel skol_info True subst tcInstSkolTyVarsPushLevel :: SkolemInfo -> Bool -- True <=> make "super skolem" - -> TCvSubst -> [TyVar] - -> TcM (TCvSubst, [TcTyVar]) + -> Subst -> [TyVar] + -> TcM (Subst, [TcTyVar]) -- Skolemise one level deeper, hence pushTcLevel -- See Note [Skolemising type variables] tcInstSkolTyVarsPushLevel skol_info overlappable subst tvs @@ -557,8 +570,8 @@ ; tcInstSkolTyVarsAt skol_info pushed_lvl overlappable subst tvs } tcInstSkolTyVarsAt :: SkolemInfo -> TcLevel -> Bool - -> TCvSubst -> [TyVar] - -> TcM (TCvSubst, [TcTyVar]) + -> Subst -> [TyVar] + -> TcM (Subst, [TcTyVar]) tcInstSkolTyVarsAt skol_info lvl overlappable subst tvs = freshenTyCoVarsX new_skol_tv subst tvs where @@ -575,12 +588,12 @@ ; skol_info <- mkSkolemInfo skol_info ; let details = SkolemTv skol_info lvl False mk_skol_tv name kind = return (mkTcTyVar name kind details) -- No freshening - ; (subst, tvs') <- instantiateTyVarsX mk_skol_tv emptyTCvSubst tvs + ; (subst, tvs') <- instantiateTyVarsX mk_skol_tv emptySubst tvs ; return (tvs', substTy subst body_ty) } instantiateTyVarsX :: (Name -> Kind -> TcM TcTyVar) - -> TCvSubst -> [TyVar] - -> TcM (TCvSubst, [TcTyVar]) + -> Subst -> [TyVar] + -> TcM (Subst, [TcTyVar]) -- Instantiate each type variable in turn with the specified function instantiateTyVarsX mk_tv subst tvs = case tvs of @@ -592,25 +605,25 @@ ; return (subst', tv':tvs') } ------------------ -freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar]) +freshenTyVarBndrs :: [TyVar] -> TcM (Subst, [TyVar]) -- ^ Give fresh uniques to a bunch of TyVars, but they stay -- as TyVars, rather than becoming TcTyVars -- Used in 'GHC.Tc.Instance.Family.newFamInst', and 'GHC.Tc.Utils.Instantiate.newClsInst' freshenTyVarBndrs = freshenTyCoVars mkTyVar -freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar]) +freshenCoVarBndrsX :: Subst -> [CoVar] -> TcM (Subst, [CoVar]) -- ^ Give fresh uniques to a bunch of CoVars -- Used in "GHC.Tc.Instance.Family.newFamInst" freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst ------------------ freshenTyCoVars :: (Name -> Kind -> TyCoVar) - -> [TyVar] -> TcM (TCvSubst, [TyCoVar]) -freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst + -> [TyVar] -> TcM (Subst, [TyCoVar]) +freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptySubst freshenTyCoVarsX :: (Name -> Kind -> TyCoVar) - -> TCvSubst -> [TyCoVar] - -> TcM (TCvSubst, [TyCoVar]) + -> Subst -> [TyCoVar] + -> TcM (Subst, [TyCoVar]) -- This a complete freshening operation: -- the skolems have a fresh unique, and a location from the monad -- See Note [Skolemising type variables] @@ -670,7 +683,7 @@ from old variables to the new variables, then instantiate the type variables substituting the original kind. -Exemple: If we want to instantiate +Example: If we want to instantiate [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)] we want [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)] 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 @@ -4,7 +4,6 @@ {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The University of Glasgow 2006 @@ -47,7 +46,7 @@ -- * Debugging traceTc, traceRn, traceOptTcRn, dumpOptTcRn, dumpTcRn, - getPrintUnqualified, + getNamePprCtx, printForUserTcRn, traceIf, traceOptIf, debugTc, @@ -70,7 +69,7 @@ addErrAt, addErrs, checkErr, addMessages, - discardWarnings, + discardWarnings, mkDetailedMessage, -- * Usage environment tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage, @@ -848,11 +847,11 @@ dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () dumpTcRn useUserStyle flag title fmt doc = do logger <- getLogger - printer <- getPrintUnqualified + name_ppr_ctx <- getNamePprCtx real_doc <- wrapDocLoc doc let sty = if useUserStyle - then mkUserStyle printer AllTheWay - else mkDumpStyle printer + then mkUserStyle name_ppr_ctx AllTheWay + else mkDumpStyle name_ppr_ctx liftIO $ logDumpFile logger sty flag title fmt real_doc -- | Add current location if -dppr-debug @@ -867,18 +866,19 @@ else return doc -getPrintUnqualified :: TcRn PrintUnqualified -getPrintUnqualified - = do { rdr_env <- getGlobalRdrEnv +getNamePprCtx :: TcRn NamePprCtx +getNamePprCtx + = do { ptc <- initPromotionTickContext <$> getDynFlags + ; rdr_env <- getGlobalRdrEnv ; hsc_env <- getTopEnv - ; return $ mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env } + ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env } -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn () printForUserTcRn doc = do logger <- getLogger - printer <- getPrintUnqualified - liftIO (printOutputForUser logger printer doc) + name_ppr_ctx <- getNamePprCtx + liftIO (printOutputForUser logger name_ppr_ctx doc) {- traceIf works in the TcRnIf monad, where no RdrEnv is @@ -1068,8 +1068,13 @@ addErrAt loc msg = do { ctxt <- getErrCtxt ; tidy_env <- tcInitTidyEnv ; err_info <- mkErrInfo tidy_env ctxt - ; add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) } + ; let detailed_msg = mkDetailedMessage (ErrInfo err_info Outputable.empty) msg + ; add_long_err_at loc detailed_msg } +mkDetailedMessage :: ErrInfo -> TcRnMessage -> TcRnMessageDetailed +mkDetailedMessage err_info msg = + TcRnMessageDetailed err_info msg + addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn () addErrs msgs = mapM_ add msgs where @@ -1113,9 +1118,9 @@ where mk_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage) mk_long_err_at loc msg - = do { printer <- getPrintUnqualified ; + = do { name_ppr_ctx <- getNamePprCtx ; unit_state <- hsc_units <$> getTopEnv ; - return $ mkErrorMsgEnvelope loc printer + return $ mkErrorMsgEnvelope loc name_ppr_ctx $ TcRnMessageWithInfo unit_state msg } @@ -1123,16 +1128,16 @@ -> TcRnMessage -> TcRn (MsgEnvelope TcRnMessage) mkTcRnMessage loc msg - = do { printer <- getPrintUnqualified ; + = do { name_ppr_ctx <- getNamePprCtx ; diag_opts <- initDiagOpts <$> getDynFlags ; - return $ mkMsgEnvelope diag_opts loc printer msg } + return $ mkMsgEnvelope diag_opts loc name_ppr_ctx msg } reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM () reportDiagnostics = mapM_ reportDiagnostic reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn () reportDiagnostic msg - = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ; + = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelopeDefault msg) ; errs_var <- getErrsVar ; msgs <- readTcRef errs_var ; writeTcRef errs_var (msg `addMessage` msgs) } @@ -1191,7 +1196,7 @@ This reliance on delicate inlining and Called Arity is not good. See #18202 for a more general approach. But meanwhile, these -ininings seem unobjectional, and they solve the immediate +inlinings seem unobjectional, and they solve the immediate problem. Note [Error contexts in generated code] @@ -1601,19 +1606,20 @@ = do { ctxt <- getErrCtxt ; extra <- mkErrInfo env0 ctxt ; let err_info = ErrInfo extra Outputable.empty - ; add_diagnostic (TcRnMessageDetailed err_info msg) } + detailed_msg = mkDetailedMessage err_info 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 mkMsg = do loc <- getSrcSpanM - printer <- getPrintUnqualified + name_ppr_ctx <- getNamePprCtx !diag_opts <- initDiagOpts <$> getDynFlags env0 <- tcInitTidyEnv ctxt <- getErrCtxt err_info <- mkErrInfo env0 ctxt - reportDiagnostic (mkMsgEnvelope diag_opts loc printer (mkMsg (ErrInfo err_info empty))) + reportDiagnostic (mkMsgEnvelope diag_opts loc name_ppr_ctx (mkMsg (ErrInfo err_info empty))) addTcRnDiagnostic :: TcRnMessage -> TcM () addTcRnDiagnostic msg = do @@ -1623,14 +1629,14 @@ -- | Display a diagnostic for the current source location, taken from -- the 'TcRn' monad. addDiagnostic :: TcRnMessage -> TcRn () -addDiagnostic msg = add_diagnostic (TcRnMessageDetailed no_err_info msg) +addDiagnostic msg = add_diagnostic (mkDetailedMessage no_err_info msg) -- | Display a diagnostic for a given source location. addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn () addDiagnosticAt loc msg = do unit_state <- hsc_units <$> getTopEnv - let dia = TcRnMessageDetailed no_err_info msg - mkTcRnMessage loc (TcRnMessageWithInfo unit_state dia) >>= reportDiagnostic + let detailed_msg = mkDetailedMessage no_err_info msg + mkTcRnMessage loc (TcRnMessageWithInfo unit_state detailed_msg) >>= reportDiagnostic -- | Display a diagnostic, with an optional flag, for the current source -- location. @@ -1652,7 +1658,7 @@ -> TcM () add_err_tcm tidy_env msg loc ctxt = do { err_info <- mkErrInfo tidy_env ctxt ; - add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) } + add_long_err_at loc (mkDetailedMessage (ErrInfo err_info Outputable.empty) msg) } mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts @@ -1910,12 +1916,12 @@ emitAnonTypeHole extra_constraints tv = do { ct_loc <- getCtLocM (TypeHoleOrigin occ) Nothing ; let hole = Hole { hole_sort = sort - , hole_occ = occ + , hole_occ = mkRdrUnqual occ , hole_ty = mkTyVarTy tv , hole_loc = ct_loc } ; emitHole hole } where - occ = mkTyVarOcc "_" + occ = mkTyVarOccFS (fsLit "_") sort | YesExtraConstraint <- extra_constraints = ConstraintHole | otherwise = TypeHole @@ -1924,7 +1930,7 @@ = do { ct_loc <- setSrcSpan (nameSrcSpan name) $ getCtLocM (TypeHoleOrigin occ) Nothing ; let hole = Hole { hole_sort = TypeHole - , hole_occ = occ + , hole_occ = nameRdrName name , hole_ty = mkTyVarTy tv , hole_loc = ct_loc } ; emitHole hole } @@ -1970,7 +1976,7 @@ It's distressingly delicate though: * If we discard too /many/ constraints we may fail to report the error - that led us to interrupte the constraint gathering process. + that led us to interrupt the constraint gathering process. One particular example "variable out of scope" Hole constraints. For example (#12529): diff --git a/GHC/Tc/Utils/TcMType.hs b/GHC/Tc/Utils/TcMType.hs --- a/GHC/Tc/Utils/TcMType.hs +++ b/GHC/Tc/Utils/TcMType.hs @@ -1,6 +1,4 @@ - {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -113,9 +111,9 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Tc.Types.Origin -import GHC.Tc.Utils.Monad -- TcType, amongst others 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 @@ -151,11 +149,11 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) -import GHC.Utils.Trace import Control.Monad import GHC.Data.Maybe import qualified Data.Semigroup as Semi +import GHC.Types.Name.Reader {- ************************************************************************ @@ -194,7 +192,7 @@ newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar -- Creates new *rigid* variables for predicates newEvVar ty = do { name <- newSysName (predTypeOccName ty) - ; return (mkLocalIdOrCoVar name Many ty) } + ; return (mkLocalIdOrCoVar name ManyTy ty) } -- | Create a new Wanted constraint with the given 'CtLoc'. newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence @@ -303,7 +301,7 @@ emitWantedEvVars orig = mapM (emitWantedEvVar orig) -- | Emit a new wanted expression hole -emitNewExprHole :: OccName -- of the hole +emitNewExprHole :: RdrName -- of the hole -> Type -> TcM HoleExprRef emitNewExprHole occ ty = do { u <- newUnique @@ -322,7 +320,7 @@ newDict :: Class -> [TcType] -> TcM DictId newDict cls tys = do { name <- newSysName (mkDictOcc (getOccName cls)) - ; return (mkLocalId name Many (mkClassPred cls tys)) } + ; return (mkLocalId name ManyTy (mkClassPred cls tys)) } predTypeOccName :: PredType -> OccName predTypeOccName ty = case classifyPredType ty of @@ -502,16 +500,7 @@ 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) } +newInferExpTypeFRR frr_orig = new_inferExpType (Just frr_orig) new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType new_inferExpType mb_frr_orig @@ -567,28 +556,20 @@ inferResultToType :: InferResult -> TcM Type inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl - , ir_ref = ref - , ir_frr = mb_frr }) + , ir_ref = ref }) = 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 + Nothing -> do { rr <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy + ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr) + -- See Note [TcLevel of ExpType] ; 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -633,7 +614,7 @@ -- 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 --- varibles and type-function applications stand for monotypes), but +-- 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 @@ -663,7 +644,7 @@ promoteTcType dest_lvl ty = do { cur_lvl <- getTcLevel ; if (cur_lvl `sameDepthAs` dest_lvl) - then return (mkTcNomReflCo ty, ty) + then return (mkNomReflCo ty, ty) else promote_it } where promote_it :: TcM (TcCoercion, TcType) @@ -765,7 +746,7 @@ 1. In kind signatures, see GHC.Tc.TyCl Note [Inferring kinds for type declarations] - and Note [Kind checking for GADTs] + and Note [Using TyVarTvs for kind-checking GADTs] 2. In partial type signatures. See GHC.Tc.Types Note [Quantified variables in partial type signatures] @@ -911,13 +892,6 @@ , 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) $ @@ -963,7 +937,7 @@ -------------------- -- Works with both type and kind variables -writeMetaTyVar :: HasDebugCallStack => TcTyVar -> TcType -> TcM () +writeMetaTyVar :: TcTyVar -> TcType -> TcM () -- Write into a currently-empty MetaTyVar writeMetaTyVar tyvar ty @@ -981,7 +955,7 @@ = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar) -------------------- -writeMetaTyVarRef :: HasDebugCallStack => TcTyVar -> TcRef MetaDetails -> TcType -> TcM () +writeMetaTyVarRef :: 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 @@ -998,13 +972,11 @@ -- Zonk kinds to allow the error check to work ; zonked_tv_kind <- zonkTcType tv_kind ; zonked_ty <- zonkTcType ty - ; let zonked_ty_kind = tcTypeKind zonked_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 - -- Hack alert! eqType, not tcEqType. see: - -- Note [coreView vs tcView] in GHC.Core.Type -- Note [Extra-constraint holes in partial type signatures] in GHC.Tc.Gen.HsType kind_msg = hang (text "Ill-kinded update to meta tyvar") @@ -1097,35 +1069,35 @@ ; let rr = mkTyConApp boxedRepDataConTyCon [lev] ; return (mkTYPEapp rr) } -newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +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 emptyTCvSubst - -- emptyTCvSubst has an empty in-scope set, but that's fine here +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 :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) +newMetaTyVarsX :: Subst -> [TyVar] -> TcM (Subst, [TcTyVar]) -- Just like newMetaTyVars, but start with an existing substitution. newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst -newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +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 :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +newMetaTyVarTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar) -- Just like newMetaTyVarX, but make a TyVarTv newMetaTyVarTyVarX = new_meta_tv_x TyVarTv -newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +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 -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +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 @@ -1148,13 +1120,6 @@ ; 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 @@ -1535,24 +1500,24 @@ -> 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 (NthCo _ _ 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 (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 @@ -1768,12 +1733,6 @@ = return Nothing -- this can happen for a covar that's associated with -- a coercion hole. Test case: typecheck/should_compile/T2494 --- Omit: no TyVars now --- | not (isTcTyVar tkv) --- = return (Just tkv) -- For associated types in a class with a standalone --- -- kind signature, we have the class variables in --- -- scope, and they are TyVars not TcTyVars - | otherwise = Just <$> skolemiseQuantifiedTyVar skol_info tkv @@ -1818,13 +1777,19 @@ skolemiseQuantifiedTyVar skol_info tv = case tcTyVarDetails tv of - SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv) - ; return (setTyVarKind tv kind) } - -- It might be a skolem type variable, - -- for example from a user type signature - 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. @@ -1858,17 +1823,6 @@ ; 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 @@ -1889,7 +1843,7 @@ ; writeMetaTyVar kv liftedTypeKind ; return True } | otherwise - = do { addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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" ]) @@ -2013,7 +1967,7 @@ D. We could error. We choose (D), as described in #17567, and implement this choice in -doNotQuantifyTyVars. Dicsussion of alternativs A-C is below. +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] @@ -2109,7 +2063,7 @@ ; unless (null leftover_metas) $ do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas ; (tidy_env2, where_doc) <- where_found tidy_env1 - ; let msg = TcRnUnknownMessage $ + ; let msg = mkTcRnUnknownMessage $ mkPlainError noHints $ pprWithExplicitKindsWhen True $ vcat [ text "Uninferrable type variable" @@ -2283,7 +2237,7 @@ * * ********************************************************************* -} -promoteMetaTyVarTo :: HasDebugCallStack => TcLevel -> TcTyVar -> TcM Bool +promoteMetaTyVarTo :: 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 @@ -2301,7 +2255,7 @@ = return False -- Returns whether or not *any* tyvar is defaulted -promoteTyVarSet :: HasDebugCallStack => TcTyVarSet -> TcM Bool +promoteTyVarSet :: TcTyVarSet -> TcM Bool promoteTyVarSet tvs = do { tclvl <- getTcLevel ; bools <- mapM (promoteMetaTyVarTo tclvl) $ @@ -2531,9 +2485,9 @@ -- A non-poly TcTyCon may have unification -- variables that need zonking, but poly ones cannot zonkTcTyCon tc - | tcTyConIsPoly tc = return tc - | otherwise = do { tck' <- zonkTcType (tyConKind tc) + | isMonoTcTyCon tc = do { tck' <- zonkTcType (tyConKind tc) ; return (setTcTyConKind tc tck') } + | otherwise = return tc zonkTcTyVar :: TcTyVar -> TcM TcType -- Simply look through all Flexis @@ -2565,7 +2519,7 @@ zonkTcTyVarToTcTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar zonkTcTyVarToTcTyVar tv = do { ty <- zonkTcTyVar tv - ; let tv' = case tcGetTyVar_maybe ty of + ; let tv' = case getTyVar_maybe ty of Just tv' -> tv' Nothing -> pprPanic "zonkTcTyVarToTcTyVar" (ppr tv $$ ppr ty) @@ -2625,10 +2579,10 @@ = do { skol_info1 <- zonkSkolemInfoAnon skol_info ; let skol_info2 = tidySkolemInfoAnon env skol_info1 ; return (env, GivenOrigin skol_info2) } -zonkTidyOrigin env (OtherSCOrigin sc_depth skol_info) +zonkTidyOrigin env (GivenSCOrigin skol_info sc_depth blocked) = do { skol_info1 <- zonkSkolemInfoAnon skol_info ; let skol_info2 = tidySkolemInfoAnon env skol_info1 - ; return (env, OtherSCOrigin sc_depth skol_info2) } + ; return (env, GivenSCOrigin skol_info2 sc_depth blocked) } zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act , uo_expected = exp }) = do { (env1, act') <- zonkTidyTcType env act @@ -2779,7 +2733,7 @@ orig_ty' = tidyType env orig_ty1 ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env) - msg = TcRnUnknownMessage $ mkPlainError noHints $ + msg = mkTcRnUnknownMessage $ mkPlainError noHints $ pprWithExplicitKindsWhen True $ vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees' , quotes $ ppr_tidied escapees' 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 @@ -1,10 +1,8 @@ - +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -36,10 +34,12 @@ SyntaxOpType(..), synKnownType, mkSynFunTys, + -------------------------------- -- TcLevel TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, strictlyDeeperThan, deeperThanOrSame, sameDepthAs, tcTypeLevel, tcTyVarLevel, maxTcLevel, + -------------------------------- -- MetaDetails TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTvUnk, @@ -56,13 +56,12 @@ -------------------------------- -- Builders - mkPhiTy, mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy, - mkTcAppTy, mkTcAppTys, mkTcCastTy, + mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy, mkPhiTy, tcMkPhiTy, + tcMkDFunSigmaTy, tcMkDFunPhiTy, -------------------------------- -- Splitters - -- These are important because they do not look through newtypes - getTyVar, + getTyVar, getTyVar_maybe, getCastedTyVar_maybe, tcSplitForAllTyVarBinder_maybe, tcSplitForAllTyVars, tcSplitForAllInvisTyVars, tcSplitSomeForAllTyVars, tcSplitForAllReqTVBinders, tcSplitForAllInvisTVBinders, @@ -72,26 +71,28 @@ tcSplitFunTysN, tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, - tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe, - tcRepGetNumAppTys, - tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, + tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitAppTyNoView_maybe, tcSplitSigmaTy, tcSplitNestedSigmaTys, --------------------------------- -- Predicates. -- Again, newtypes are opaque - eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, - pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, - tcEqTyConApps, isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy, isFloatingPrimTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isNaturalTy, isBoolTy, isUnitTy, isCharTy, - isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, + isTauTy, isTauTyCon, tcIsTyVarTy, isPredTy, isTyVarClassPred, checkValidClsArgs, hasTyVarHead, isRigidTy, + + -- Re-exported from GHC.Core.TyCo.Compare + -- mainly just for back-compat reasons + eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, + tcEqTyConApps, eqForAllVis, eqVarBndrs, + --------------------------------- -- Misc type manipulators @@ -130,43 +131,54 @@ isFunPtrTy, -- :: Type -> Bool tcSplitIOType_maybe, -- :: Type -> Maybe Type + --------------------------------- + -- Patersons sizes + PatersonSize(..), PatersonSizeFailure(..), + ltPatersonSize, + pSizeZero, pSizeOne, + pSizeType, pSizeTypeX, pSizeTypes, + pSizeClassPred, pSizeClassPredX, + pSizeTyConApp, + noMoreTyVars, allDistinctTyVars, + TypeSize, sizeType, sizeTypes, scopedSort, + isTerminatingClass, isStuckTypeFamily, + -------------------------------- -- Reexported from Kind - Kind, tcTypeKind, - liftedTypeKind, - constraintKind, - isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues, + Kind, liftedTypeKind, constraintKind, + isLiftedTypeKind, isUnliftedTypeKind, isTYPEorCONSTRAINT, -------------------------------- -- Reexported from Type - Type, PredType, ThetaType, TyCoBinder, - ArgFlag(..), AnonArgFlag(..), + Type, PredType, ThetaType, PiTyBinder, + ForAllTyFlag(..), FunTyFlag(..), mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy, mkInfForAllTy, mkInfForAllTys, - mkVisFunTy, mkVisFunTys, mkInvisFunTy, mkInvisFunTyMany, - mkVisFunTyMany, mkVisFunTysMany, mkInvisFunTysMany, + mkVisFunTy, mkVisFunTyMany, mkVisFunTysMany, + mkScaledFunTys, + mkInvisFunTy, mkInvisFunTys, mkTyConApp, mkAppTy, mkAppTys, mkTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, isClassPred, isEqPrimPred, isIPLikePred, isEqPred, isEqPredClass, mkClassPred, - tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, + tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, isRuntimeRepVar, isFixedRuntimeRepKind, - isVisibleBinder, isInvisibleBinder, + isVisiblePiTyBinder, isInvisiblePiTyBinder, -- Type substitutions - TCvSubst(..), -- Representation visible to a few friends - TvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, + Subst(..), -- Representation visible to a few friends + TvSubstEnv, emptySubst, mkEmptySubst, zipTvSubst, - mkTvSubstPrs, notElemTCvSubst, unionTCvSubst, - getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope, - extendTCvInScopeList, extendTCvInScopeSet, extendTvSubstAndInScope, + mkTvSubstPrs, notElemSubst, unionSubst, + getTvSubstEnv, getSubstInScope, extendSubstInScope, + extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope, Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, Type.extendTvSubst, - isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, + isInScope, mkSubst, mkTvSubst, zipTyEnv, zipCoEnv, Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars, substTyAddInScope, substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, @@ -175,11 +187,11 @@ substCoUnchecked, substCoWithUnchecked, substTheta, - isUnliftedType, -- Source types are always lifted - isUnboxedTupleType, -- Ditto + isUnliftedType, + isUnboxedTupleType, isPrimitiveType, - tcView, coreView, + coreView, tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds, tyCoFVsOfType, tyCoFVsOfTypes, @@ -193,8 +205,6 @@ pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred, pprTCvBndr, pprTCvBndrs, - TypeSize, sizeType, sizeTypes, scopedSort, - --------------------------------- -- argument visibility tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible @@ -206,6 +216,7 @@ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst ( mkTvSubst, substTyWithCoVars ) +import GHC.Core.TyCo.Compare import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr import GHC.Core.Class @@ -229,7 +240,6 @@ -- We use this to make dictionaries for type literals. -- Perhaps there's a better way to do this? import GHC.Types.Name.Set -import GHC.Types.Var.Env import GHC.Builtin.Names import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey , listTyCon, constraintKind ) @@ -245,8 +255,9 @@ import Data.IORef import Data.List.NonEmpty( NonEmpty(..) ) -import Data.List ( partition ) +import Data.List ( partition, nub, (\\) ) +import GHC.Generics ( Generic ) {- ************************************************************************ @@ -328,7 +339,7 @@ of Var.Var. The "tc" prefix means "a type variable that can be encountered by the typechecker". -This is a bit of a change from an earlier era when we remoselessly +This is a bit of a change from an earlier era when we remorselessly insisted on real TcTyVars in the type checker. But that seems unnecessary (for skolems, TyVars are fine) and it's now very hard to guarantee, with the advent of kind equalities. @@ -427,7 +438,7 @@ - Flag tcTyConIsPoly = True; this is used only to short-cut zonking - tyConBinders are still TcTyConBinders, but they are /skolem/ TcTyVars, - with fixed kinds: no unification variables here + with fixed kinds, and accurate skolem info: no unification variables here tyConBinders includes the Inferred binders if any @@ -583,15 +594,34 @@ (historically but still there) Var.tcTyVarDetails returns vanillaSkolemTv for a TyVar. -But ultimately I want to seeparate Type from TcType, and in that case +But ultimately I want to separate Type from TcType, and in that case we would need to enforce the separation. + +Note [Keeping SkolemInfo inside a SkolemTv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A SkolemTv contains a SkolemInfo, which describes the binding side of that +TcTyVar. This is very convenient to a consumer of a SkolemTv, but it is +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 +`SkolemInfo` is `SigSkol`, whose arguments in turn mention the newly-created +SkolemTvs. So we a RecrusiveDo idiom, like this: + + rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty + ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } + +Note that the `skol_info` can't be created until we have the `tv_prs` returned +by `skolemise`. Note also that `skolemise` had better be lazy in `skol_info`. + +All uses of this idiom should be flagged with a reference to this Note. -} -- A TyVarDetails is inside a TyVar --- See Note [TyVars and TcTyVars] +-- See Note [TyVars and TcTyVars during type checking] data TcTyVarDetails = SkolemTv -- A skolem - SkolemInfo + SkolemInfo -- See Note [Keeping SkolemInfo inside a SkolemTv] TcLevel -- Level of the implication that binds it -- See GHC.Tc.Utils.Unify Note [Deeper level on the left] for -- how this level number is used @@ -764,7 +794,7 @@ (forall[3] b. alpha[3] ~ b) We can unify alpha:=b in the inner implication, because 'alpha' is -touchable; but then 'b' has excaped its scope into the outer implication. +touchable; but then 'b' has escaped its scope into the outer implication. -} maxTcLevel :: TcLevel -> TcLevel -> TcLevel @@ -882,7 +912,7 @@ tcTyFamInstsAndVisX = go where go is_invis_arg ty - | Just exp_ty <- tcView ty = go is_invis_arg exp_ty + | Just exp_ty <- coreView ty = go is_invis_arg exp_ty go _ (TyVarTy _) = [] go is_invis_arg (TyConApp tc tys) | isTypeFamilyTyCon tc @@ -897,9 +927,9 @@ ++ go is_invis_arg ty2 go is_invis_arg ty@(AppTy _ _) = let (ty_head, ty_args) = splitAppTys ty - ty_arg_flags = appTyArgFlags ty_head ty_args + ty_arg_flags = appTyForAllTyFlags ty_head ty_args in go is_invis_arg ty_head - ++ concat (zipWith (\flag -> go (isInvisibleArgFlag flag)) + ++ concat (zipWith (\flag -> go (isInvisibleForAllTyFlag flag)) ty_arg_flags ty_args) go is_invis_arg (CastTy ty _) = go is_invis_arg ty go _ (CoercionTy _) = [] -- don't count tyfams in coercions, @@ -953,7 +983,7 @@ go rl bvs ty@(TyConApp tc tys) | isTypeSynonymTyCon tc , should_expand tc - , Just ty' <- tcView ty -- should always match + , Just ty' <- coreView ty -- should always match = go rl bvs ty' | tc_pred rl tc tys @@ -975,7 +1005,7 @@ go_tc NomEq bvs _ tys = any (go NomEq bvs) tys go_tc ReprEq bvs tc tys = any (go_arg bvs) - (tyConRolesRepresentational tc `zip` tys) + (tyConRoleListRepresentational tc `zip` tys) go_arg bvs (Nominal, ty) = go NomEq bvs ty go_arg bvs (Representational, ty) = go ReprEq bvs ty @@ -1042,7 +1072,7 @@ occasionally -- see the calls to exactTyCoVarsOfType. We place this function here in GHC.Tc.Utils.TcType, not in GHC.Core.TyCo.FVs, -because we want to "see" tcView (efficiency issue only). +because we want to "see" coreView (efficiency issue only). -} exactTyCoVarsOfType :: Type -> TyCoVarSet @@ -1058,7 +1088,7 @@ (exact_ty, exact_tys, _, _) = foldTyCo exactTcvFolder emptyVarSet exactTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet) -exactTcvFolder = deepTcvFolder { tcf_view = tcView } +exactTcvFolder = deepTcvFolder { tcf_view = coreView } -- This is the key line {- @@ -1279,22 +1309,39 @@ ************************************************************************ -} -mkSigmaTy :: [TyCoVarBinder] -> [PredType] -> Type -> Type -mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) - -- | Make a sigma ty where all type variables are 'Inferred'. That is, -- they cannot be used with visible type application. -mkInfSigmaTy :: [TyCoVar] -> [PredType] -> Type -> Type -mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkTyCoVarBinders Inferred tyvars) theta ty +mkInfSigmaTy :: HasDebugCallStack => [TyCoVar] -> [PredType] -> Type -> Type +mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkForAllTyBinders Inferred tyvars) theta ty -- | Make a sigma ty where all type variables are "specified". That is, -- they can be used with visible type application -mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type -mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkTyCoVarBinders Specified tyvars) preds ty +mkSpecSigmaTy :: HasDebugCallStack => [TyVar] -> [PredType] -> Type -> Type +mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkForAllTyBinders Specified tyvars) preds ty -mkPhiTy :: [PredType] -> Type -> Type -mkPhiTy = mkInvisFunTysMany +mkSigmaTy :: HasDebugCallStack => [ForAllTyBinder] -> [PredType] -> Type -> Type +-- Result is TypeLike +mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) +tcMkDFunSigmaTy :: [TyVar] -> ThetaType -> Type -> Type +tcMkDFunSigmaTy tvs theta res_ty + = mkForAllTys (mkForAllTyBinders Specified tvs) $ + tcMkDFunPhiTy theta res_ty + +mkPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type +-- Result type is TypeLike +mkPhiTy = mkInvisFunTys + +tcMkPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type +-- Like mkPhiTy, but with no assertion checks; it is called +-- by the type checker and the result kind may not be zonked yet +-- But the result kind is TypeLike +tcMkPhiTy tys ty = foldr (tcMkInvisFunTy TypeLike) ty tys + +tcMkDFunPhiTy :: HasDebugCallStack => [PredType] -> Type -> Type +-- Just like tcMkPhiTy, but result type is ConstraintLike +tcMkDFunPhiTy preds res = foldr (tcMkInvisFunTy ConstraintLike) res preds + --------------- getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to -- construct a dictionary function name @@ -1303,7 +1350,7 @@ getDFunTyKey (TyConApp tc _) = getOccName tc getDFunTyKey (LitTy x) = getDFunTyLitKey x getDFunTyKey (AppTy fun _) = getDFunTyKey fun -getDFunTyKey (FunTy {}) = getOccName funTyCon +getDFunTyKey (FunTy { ft_af = af }) = getOccName (funTyFlagTyCon af) getDFunTyKey (ForAllTy _ t) = getDFunTyKey t getDFunTyKey (CastTy ty _) = getDFunTyKey ty getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t) @@ -1313,58 +1360,34 @@ getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm getDFunTyLitKey (CharTyLit n) = mkOccName Name.varName (show n) -{- ********************************************************************* -* * - Building types -* * -********************************************************************* -} - --- ToDo: I think we need Tc versions of these --- Reason: mkCastTy checks isReflexiveCastTy, which checks --- for equality; and that has a different answer --- depending on whether or not Type = Constraint - -mkTcAppTys :: Type -> [Type] -> Type -mkTcAppTys = mkAppTys - -mkTcAppTy :: Type -> Type -> Type -mkTcAppTy = mkAppTy - -mkTcCastTy :: Type -> Coercion -> Type -mkTcCastTy = mkCastTy -- Do we need a tc version of mkCastTy? - {- ************************************************************************ * * Expanding and splitting * * ************************************************************************ - -These tcSplit functions are like their non-Tc analogues, but - *) they do not look through newtypes - -However, they are non-monadic and do not follow through mutable type -variables. It's up to you to make sure this doesn't matter. -} --- | Splits a forall type into a list of 'TyBinder's and the inner type. +-- | Splits a forall type into a list of 'PiTyVarBinder's and the inner type. -- Always succeeds, even if it returns an empty list. -tcSplitPiTys :: Type -> ([TyBinder], Type) +tcSplitPiTys :: Type -> ([PiTyVarBinder], Type) tcSplitPiTys ty - = assert (all isTyBinder (fst sty) ) sty + = assert (all isTyBinder (fst sty) ) -- No CoVar binders here + sty where sty = splitPiTys ty --- | Splits a type into a TyBinder and a body, if possible. Panics otherwise -tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type) +-- | Splits a type into a PiTyVarBinder and a body, if possible. +tcSplitPiTy_maybe :: Type -> Maybe (PiTyVarBinder, Type) tcSplitPiTy_maybe ty - = assert (isMaybeTyBinder sty ) sty + = assert (isMaybeTyBinder sty) -- No CoVar binders here + sty where sty = splitPiTy_maybe ty isMaybeTyBinder (Just (t,_)) = isTyBinder t isMaybeTyBinder _ = True tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type) -tcSplitForAllTyVarBinder_maybe ty | Just ty' <- tcView ty = tcSplitForAllTyVarBinder_maybe ty' +tcSplitForAllTyVarBinder_maybe ty | Just ty' <- coreView ty = tcSplitForAllTyVarBinder_maybe ty' tcSplitForAllTyVarBinder_maybe (ForAllTy tv ty) = assert (isTyVarBinder tv ) Just (tv, ty) tcSplitForAllTyVarBinder_maybe _ = Nothing @@ -1378,13 +1401,13 @@ -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' -- type variable binders. tcSplitForAllInvisTyVars :: Type -> ([TyVar], Type) -tcSplitForAllInvisTyVars ty = tcSplitSomeForAllTyVars isInvisibleArgFlag ty +tcSplitForAllInvisTyVars ty = tcSplitSomeForAllTyVars isInvisibleForAllTyFlag ty -- | Like 'tcSplitForAllTyVars', but only splits a 'ForAllTy' if @argf_pred argf@ -- is 'True', where @argf@ is the visibility of the @ForAllTy@'s binder and -- @argf_pred@ is a predicate over visibilities provided as an argument to this -- function. -tcSplitSomeForAllTyVars :: (ArgFlag -> Bool) -> Type -> ([TyVar], Type) +tcSplitSomeForAllTyVars :: (ForAllTyFlag -> Bool) -> Type -> ([TyVar], Type) tcSplitSomeForAllTyVars argf_pred ty = split ty ty [] where @@ -1396,32 +1419,26 @@ -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Required' type -- variable binders. All split tyvars are annotated with '()'. tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type) -tcSplitForAllReqTVBinders ty = assert (all (isTyVar . binderVar) (fst sty) ) sty - where sty = splitForAllReqTVBinders ty +tcSplitForAllReqTVBinders ty = assert (all isTyVarBinder (fst sty) ) sty + where sty = splitForAllReqTyBinders ty -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' type -- variable binders. All split tyvars are annotated with their 'Specificity'. tcSplitForAllInvisTVBinders :: Type -> ([TcInvisTVBinder], Type) -tcSplitForAllInvisTVBinders ty = assert (all (isTyVar . binderVar) (fst sty) ) sty - where sty = splitForAllInvisTVBinders ty +tcSplitForAllInvisTVBinders ty = assert (all (isTyVar . binderVar) (fst sty)) sty + where sty = splitForAllInvisTyBinders ty -- | Like 'tcSplitForAllTyVars', but splits off only named binders. tcSplitForAllTyVarBinders :: Type -> ([TyVarBinder], Type) tcSplitForAllTyVarBinders ty = assert (all isTyVarBinder (fst sty)) sty - where sty = splitForAllTyCoVarBinders ty - --- | Is this a ForAllTy with a named binder? -tcIsForAllTy :: Type -> Bool -tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' -tcIsForAllTy (ForAllTy {}) = True -tcIsForAllTy _ = False + where sty = splitForAllForAllTyBinders ty tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) -- Split off the first predicate argument from a type tcSplitPredFunTy_maybe ty - | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' -tcSplitPredFunTy_maybe (FunTy { ft_af = InvisArg - , ft_arg = arg, ft_res = res }) + | Just ty' <- coreView ty = tcSplitPredFunTy_maybe ty' +tcSplitPredFunTy_maybe (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) + | isInvisibleFunArg af = Just (arg, res) tcSplitPredFunTy_maybe _ = Nothing @@ -1456,7 +1473,7 @@ , (tvs1, theta1, rho1) <- tcSplitSigmaTy body_ty , not (null tvs1 && null theta1) = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1 - in (tvs1 ++ tvs2, theta1 ++ theta2, mkVisFunTys arg_tys rho2) + in (tvs1 ++ tvs2, theta1 ++ theta2, mkScaledFunTys arg_tys rho2) -- If there's no forall, we're done. | otherwise = ([], [], ty) @@ -1497,26 +1514,16 @@ -- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'. tcTyConAppTyCon_maybe :: Type -> Maybe TyCon -tcTyConAppTyCon_maybe ty - | Just ty' <- tcView ty = tcTyConAppTyCon_maybe ty' -tcTyConAppTyCon_maybe (TyConApp tc _) - = Just tc -tcTyConAppTyCon_maybe (FunTy { ft_af = VisArg }) - = Just funTyCon -- (=>) is /not/ a TyCon in its own right - -- C.f. tcRepSplitAppTy_maybe -tcTyConAppTyCon_maybe _ - = Nothing +tcTyConAppTyCon_maybe ty | Just ty' <- coreView ty = tcTyConAppTyCon_maybe ty' +tcTyConAppTyCon_maybe (TyConApp tc _) = Just tc +tcTyConAppTyCon_maybe (FunTy { ft_af = af }) = Just (funTyFlagTyCon af) +tcTyConAppTyCon_maybe _ = Nothing tcTyConAppArgs :: Type -> [Type] tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of Just (_, args) -> args Nothing -> pprPanic "tcTyConAppArgs" (pprType ty) -tcSplitTyConApp :: Type -> (TyCon, [Type]) -tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of - Just stuff -> stuff - Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) - ----------------------- tcSplitFunTys :: Type -> ([Scaled Type], Type) tcSplitFunTys ty = case tcSplitFunTy_maybe ty of @@ -1526,12 +1533,13 @@ (args,res') = tcSplitFunTys res tcSplitFunTy_maybe :: Type -> Maybe (Scaled Type, Type) +-- Only splits function (->) and (-=>), not (=>) or (==>) tcSplitFunTy_maybe ty - | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' + | Just ty' <- coreView ty = tcSplitFunTy_maybe ty' tcSplitFunTy_maybe (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) - | VisArg <- af = Just (Scaled w arg, res) -tcSplitFunTy_maybe _ = Nothing - -- Note the VisArg guard + | isVisibleFunArg af = Just (Scaled w arg, res) +tcSplitFunTy_maybe _ = Nothing + -- Note the isVisibleFunArg guard -- Consider (?x::Int) => Bool -- We don't want to treat this as a function type! -- A concrete example is test tc230: @@ -1562,7 +1570,7 @@ tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty) tcFunArgTy :: Type -> Scaled Type -tcFunArgTy ty = fst (tcSplitFunTy ty) +tcFunArgTy ty = fst (tcSplitFunTy ty) tcFunResultTy :: Type -> Type tcFunResultTy ty = snd (tcSplitFunTy ty) @@ -1577,8 +1585,8 @@ ----------------------- tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) -tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty' -tcSplitAppTy_maybe ty = tcRepSplitAppTy_maybe ty +tcSplitAppTy_maybe ty | Just ty' <- coreView ty = tcSplitAppTy_maybe ty' +tcSplitAppTy_maybe ty = tcSplitAppTyNoView_maybe ty tcSplitAppTy :: Type -> (Type, Type) tcSplitAppTy ty = case tcSplitAppTy_maybe ty of @@ -1593,34 +1601,9 @@ Just (ty', arg) -> go ty' (arg:args) Nothing -> (ty,args) --- | Returns the number of arguments in the given type, without --- looking through synonyms. This is used only for error reporting. --- We don't look through synonyms because of #11313. -tcRepGetNumAppTys :: Type -> Arity -tcRepGetNumAppTys = length . snd . repSplitAppTys - ----------------------- --- | If the type is a tyvar, possibly under a cast, returns it, along --- with the coercion. Thus, the co is :: kind tv ~N kind type -tcGetCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) -tcGetCastedTyVar_maybe ty | Just ty' <- tcView ty = tcGetCastedTyVar_maybe ty' -tcGetCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) -tcGetCastedTyVar_maybe (TyVarTy tv) = Just (tv, mkNomReflCo (tyVarKind tv)) -tcGetCastedTyVar_maybe _ = Nothing - -tcGetTyVar_maybe :: Type -> Maybe TyVar -tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty' -tcGetTyVar_maybe (TyVarTy tv) = Just tv -tcGetTyVar_maybe _ = Nothing - -tcGetTyVar :: String -> Type -> TyVar -tcGetTyVar msg ty - = case tcGetTyVar_maybe ty of - Just tv -> tv - Nothing -> pprPanic msg (ppr ty) - tcIsTyVarTy :: Type -> Bool -tcIsTyVarTy ty | Just ty' <- tcView ty = tcIsTyVarTy ty' +tcIsTyVarTy ty | Just ty' <- coreView ty = tcIsTyVarTy ty' tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty -- look through casts, as -- this is only used for -- e.g., FlexibleContexts @@ -1628,21 +1611,24 @@ tcIsTyVarTy _ = False ----------------------- -tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) --- Split the type of a dictionary function --- We don't use tcSplitSigmaTy, because a DFun may (with NDP) --- have non-Pred arguments, such as --- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m --- --- Also NB splitFunTys, not tcSplitFunTys; +tcSplitQuantPredTy :: Type -> ([TyVar], [Type], PredType) +-- Split up the type of a quantified predicate +-- forall tys, theta => head +-- NB splitFunTys, not tcSplitFunTys; -- the latter specifically stops at PredTy arguments, -- and we don't want to do that here -tcSplitDFunTy ty +tcSplitQuantPredTy ty = case tcSplitForAllInvisTyVars ty of { (tvs, rho) -> - case splitFunTys rho of { (theta, tau) -> - case tcSplitDFunHead tau of { (clas, tys) -> - (tvs, map scaledThing theta, clas, tys) }}} + case splitFunTys rho of { (theta, head) -> + (tvs, map scaledThing theta, head) }} +tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) +-- Split the type of a dictionary function +tcSplitDFunTy ty + = case tcSplitQuantPredTy ty of { (tvs, theta, head) -> + case tcSplitDFunHead head of { (clas, tys) -> + (tvs, theta, clas, tys) }} + tcSplitDFunHead :: Type -> (Class, [Type]) tcSplitDFunHead = getClassPredTys @@ -1667,178 +1653,6 @@ {- ********************************************************************* * * - Type equalities -* * -********************************************************************* -} - -tcEqKind :: HasDebugCallStack => TcKind -> TcKind -> Bool -tcEqKind = tcEqType - -tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool --- ^ tcEqType implements typechecker equality, as described in --- @Note [Typechecker equality vs definitional equality]@. -tcEqType ty1 ty2 - = tcEqTypeNoSyns ki1 ki2 - && tcEqTypeNoSyns ty1 ty2 - where - ki1 = tcTypeKind ty1 - ki2 = tcTypeKind ty2 - --- | Just like 'tcEqType', but will return True for types of different kinds --- as long as their non-coercion structure is identical. -tcEqTypeNoKindCheck :: TcType -> TcType -> Bool -tcEqTypeNoKindCheck ty1 ty2 - = tcEqTypeNoSyns ty1 ty2 - --- | 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) - -- 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 TcType are hit pretty hard during typechecking. -Consequently we take pains to ensure that these paths are compiled to -efficient, minimally-allocating code. - -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. - -See #19226. --} - --- | Type equality comparing both visible and invisible arguments and expanding --- type synonyms. -tcEqTypeNoSyns :: TcType -> TcType -> Bool -tcEqTypeNoSyns ta tb = tc_eq_type False False ta tb - --- | 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 :: TcType -> TcType -> Bool -tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2 - --- | Like 'pickyEqTypeVis', but returns a Bool for convenience -pickyEqType :: TcType -> TcType -> 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 - --- | 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 --- 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' <- tcView t1 = go env t1' t2 - go env t1 t2 | not keep_syns, Just t2' <- tcView 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 (ForAllTy (Bndr tv1 vis1) ty1) - (ForAllTy (Bndr tv2 vis2) ty2) - = vis1 `sameVis` vis2 - -- See Note [ForAllTy and typechecker equality] in - -- GHC.Tc.Solver.Canonical for why we use `sameVis` here - && (vis_only || go env (varType tv1) (varType tv2)) - && go (rnBndr2 env tv1 tv2) ty1 ty2 - - -- Make sure we handle all FunTy cases since falling through to the - -- AppTy case means that tcRepSplitAppTy_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) - - -- See Note [Equality on AppTys] in GHC.Core.Type - go env (AppTy s1 t1) ty2 - | Just (s2, t2) <- tcRepSplitAppTy_maybe ty2 - = go env s1 s2 && go env t1 t2 - go env ty1 (AppTy s2 t2) - | Just (s1, t1) <- tcRepSplitAppTy_maybe ty1 - = go env s1 s2 && go env t1 t2 - - go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) - = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2 - - go env (CastTy t1 _) t2 = go env t1 t2 - go env t1 (CastTy t2 _) = go env t1 t2 - go _ (CoercionTy {}) (CoercionTy {}) = True - - go _ _ _ = False - - gos _ _ [] [] = True - gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2) - && gos env igs ts1 ts2 - gos _ _ _ _ = False - - 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]. - -{- Note [Typechecker equality vs definitional equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC has two notions of equality over Core types: - -* Definitional equality, as implemented by GHC.Core.Type.eqType. - See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. -* Typechecker equality, as implemented by tcEqType (in GHC.Tc.Utils.TcType). - GHC.Tc.Solver.Canonical.canEqNC also respects typechecker equality. - -Typechecker equality implies definitional equality: if two types are equal -according to typechecker equality, then they are also equal according to -definitional equality. The converse is not always true, as typechecker equality -is more finer-grained than definitional equality in two places: - -* Unlike definitional equality, which equates Type and Constraint, typechecker - treats them as distinct types. See Note [Kind Constraint and kind Type] in - GHC.Core.Type. -* Unlike definitional equality, which does not care about the ArgFlag of a - ForAllTy, typechecker equality treats Required type variable binders as - distinct from Invisible type variable binders. - See Note [ForAllTy and typechecker equality] in GHC.Tc.Solver.Canonical. --} - -{- ********************************************************************* -* * Predicate types * * ************************************************************************ @@ -1864,8 +1678,8 @@ -- If the Bool is True (flexible contexts), return True (i.e. ok) -- Otherwise, check that the type (not kind) args are all headed by a tyvar -- E.g. (Eq a) accepted, (Eq (f a)) accepted, but (Eq Int) rejected --- This function is here rather than in GHC.Tc.Validity because it is --- called from GHC.Tc.Solver, which itself is imported by GHC.Tc.Validity +-- This function is here in GHC.Tc.Utils.TcType, rather than in GHC.Tc.Validity, +-- because it is called from GHC.Tc.Solver, which itself is imported by GHC.Tc.Validity checkValidClsArgs flexible_contexts cls kts | flexible_contexts = True | otherwise = all hasTyVarHead tys @@ -1900,12 +1714,12 @@ NomEq | homo_kind -> Just (eqClass, [k1, ty1, ty2]) | otherwise -> Just (heqClass, [k1, k2, ty1, ty2]) ReprEq | homo_kind -> Just (coercibleClass, [k1, ty1, ty2]) - | otherwise -> Nothing -- Sigh: we do not have hererogeneous Coercible + | otherwise -> Nothing -- Sigh: we do not have heterogeneous Coercible -- so we can't abstract over it -- Nothing fundamental: we could add it where - k1 = tcTypeKind ty1 - k2 = tcTypeKind ty2 + k1 = typeKind ty1 + k2 = typeKind ty2 homo_kind = k1 `tcEqType` k2 pickCapturedPreds @@ -2076,15 +1890,15 @@ -- 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' <- tcView ty = isSigmaTy ty' +isSigmaTy ty | Just ty' <- coreView ty = isSigmaTy ty' isSigmaTy (ForAllTy {}) = True -isSigmaTy (FunTy { ft_af = InvisArg }) = True +isSigmaTy (FunTy { ft_af = af }) = isInvisibleFunArg af isSigmaTy _ = False isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType] -isRhoTy ty | Just ty' <- tcView ty = isRhoTy ty' +isRhoTy ty | Just ty' <- coreView ty = isRhoTy ty' isRhoTy (ForAllTy {}) = False -isRhoTy (FunTy { ft_af = InvisArg }) = False +isRhoTy (FunTy { ft_af = af }) = isVisibleFunArg af isRhoTy _ = True -- | Like 'isRhoTy', but also says 'True' for 'Infer' types @@ -2095,16 +1909,16 @@ isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing -- Used only by bindLocalMethods -isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' +isOverloadedTy ty | Just ty' <- coreView ty = isOverloadedTy ty' isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty -isOverloadedTy (FunTy { ft_af = InvisArg }) = True +isOverloadedTy (FunTy { ft_af = af }) = isInvisibleFunArg af isOverloadedTy _ = False isFloatTy, isDoubleTy, isFloatPrimTy, isDoublePrimTy, isIntegerTy, isNaturalTy, isIntTy, isWordTy, isBoolTy, - isUnitTy, isCharTy, isAnyTy :: Type -> Bool + isUnitTy, isCharTy :: Type -> Bool isFloatTy = is_tc floatTyConKey isDoubleTy = is_tc doubleTyConKey isFloatPrimTy = is_tc floatPrimTyConKey @@ -2116,8 +1930,17 @@ isBoolTy = is_tc boolTyConKey isUnitTy = is_tc unitTyConKey isCharTy = is_tc charTyConKey -isAnyTy = is_tc anyTyConKey +-- | Check whether the type is of the form @Any :: k@, +-- returning the kind @k@. +anyTy_maybe :: Type -> Maybe Kind +anyTy_maybe ty + | Just (tc, [k]) <- splitTyConApp_maybe ty + , getUnique tc == anyTyConKey + = Just k + | otherwise + = Nothing + -- | Is the type inhabited by machine floating-point numbers? -- -- Used to check that we don't use floating-point literal patterns @@ -2186,7 +2009,7 @@ visible type application. Tracking specified vs. inferred variables is done conveniently by a field -in TyBinder. +in PiTyVarBinder. -} @@ -2236,6 +2059,7 @@ | LinearTypesNotAllowed | OneArgExpected | AtLeastOneArgExpected + deriving Generic -- | Reason why a type cannot be marshalled through the FFI. data TypeCannotBeMarshaledReason @@ -2245,6 +2069,8 @@ | NotABoxedMarshalableTyCon | ForeignLabelNotAPtr | NotSimpleUnliftedType + | NotBoxedKindAny + deriving Generic isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason -- Checks for valid argument type for a 'foreign import' @@ -2287,22 +2113,44 @@ | 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 the well-known type --- Any, which can be used to pass the address to a Haskell object on the heap to +-- 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 - | isAnyTy ty = IsValid - | otherwise = checkRepTyCon (legalFIPrimArgTyCon 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. +-- sums, or the well-known type Any (at kind Type or UnliftedType). isFFIPrimResultTy dflags ty - | isAnyTy ty = IsValid - | otherwise = checkRepTyCon (legalFIPrimResultTyCon dflags) ty + | Just validity <- checkAnyTy ty + = validity + | otherwise + = checkRepTyCon (legalFIPrimResultTyCon dflags) ty isFunPtrTy :: Type -> Bool isFunPtrTy ty @@ -2446,71 +2294,11 @@ {- ************************************************************************ * * - The "Paterson size" of a type + Visiblities * * ************************************************************************ -} -{- -Note [Paterson conditions on PredTypes] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We are considering whether *class* constraints terminate -(see Note [Paterson conditions]). Precisely, the Paterson conditions -would have us check that "the constraint has fewer constructors and variables -(taken together and counting repetitions) than the head.". - -However, we can be a bit more refined by looking at which kind of constraint -this actually is. There are two main tricks: - - 1. It seems like it should be OK not to count the tuple type constructor - for a PredType like (Show a, Eq a) :: Constraint, since we don't - count the "implicit" tuple in the ThetaType itself. - - In fact, the Paterson test just checks *each component* of the top level - ThetaType against the size bound, one at a time. By analogy, it should be - OK to return the size of the *largest* tuple component as the size of the - whole tuple. - - 2. Once we get into an implicit parameter or equality we - can't get back to a class constraint, so it's safe - to say "size 0". See #4200. - -NB: we don't want to detect PredTypes in sizeType (and then call -sizePred on them), or we might get an infinite loop if that PredType -is irreducible. See #5581. --} - -type TypeSize = IntWithInf - -sizeType :: Type -> TypeSize --- Size of a type: the number of variables and constructors --- Ignore kinds altogether -sizeType = go - where - go ty | Just exp_ty <- tcView ty = go exp_ty - go (TyVarTy {}) = 1 - go (TyConApp tc tys) - | isTypeFamilyTyCon tc = infinity -- Type-family applications can - -- expand to any arbitrary size - | otherwise = sizeTypes (filterOutInvisibleTypes tc tys) + 1 - -- Why filter out invisible args? I suppose any - -- size ordering is sound, but why is this better? - -- I came across this when investigating #14010. - go (LitTy {}) = 1 - go (FunTy _ w arg res) = go w + go arg + go res + 1 - go (AppTy fun arg) = go fun + go arg - go (ForAllTy (Bndr tv vis) ty) - | isVisibleArgFlag vis = go (tyVarKind tv) + go ty + 1 - | otherwise = go ty + 1 - go (CastTy ty _) = go ty - go (CoercionTy {}) = 0 - -sizeTypes :: [Type] -> TypeSize -sizeTypes tys = sum (map sizeType tys) - ------------------------------------------------------------------------------------ ------------------------------------------------------------------------------------ ------------------------ -- | 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. @@ -2518,7 +2306,7 @@ tcTyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True where tc_binder_viss = map isVisibleTyConBinder (tyConBinders tc) - tc_return_kind_viss = map isVisibleBinder (fst $ tcSplitPiTys (tyConResKind tc)) + tc_return_kind_viss = map isVisiblePiTyBinder (fst $ tcSplitPiTys (tyConResKind tc)) -- | If the tycon is applied to the types, is the next argument visible? isNextTyConArgVisible :: TyCon -> [Type] -> Bool @@ -2528,7 +2316,235 @@ -- | Should this type be applied to a visible argument? isNextArgVisible :: TcType -> Bool isNextArgVisible ty - | Just (bndr, _) <- tcSplitPiTy_maybe ty = isVisibleBinder bndr + | Just (bndr, _) <- tcSplitPiTy_maybe 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 + +{- +************************************************************************ +* * + Paterson sizes +* * +************************************************************************ +-} + +{- Note [The PatersonSize of a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The PatersonSize of type is something we can compare, with `ltPatersonSize`, +to determine if the Paterson conditions are satisfied for an instance +declaration. See Note [Paterson conditions] in GHC.Tc.Validity. + +There are some wrinkles + +(PS1) Once we get into an implicit parameter or equality we + can't get back to a class constraint, so it's safe + to say "size 0". See #4200. + + We do this with isTerminatingClass + +Note [Invisible arguments and termination] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When checking the ​Paterson conditions for termination an instance +declaration, we check for the number of "constructors and variables" +in the instance head and constraints. Question: Do we look at + + * All the arguments, visible or invisible? + * Just the visible arguments? + +I think both will ensure termination, provided we are consistent. +Currently we are /not/ consistent, which is really a bug. It's +described in #15177, which contains a number of examples. +The suspicious bits are the calls to filterOutInvisibleTypes. +See also #11833. + +Note [Stuck type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type-family application generally has infinite size (PS_TyFam); +see (PC3) in Note [Paterson conditions] in GHC.Tc.Validity. + +But a couple of built-in type families have no axioms, and can never +expand into anything else. They are: + +* (TypeError "stuff"). E.g. consider + + type family F a where + F Int = Bool + F Bool = Char + F _ = TypeError "Bad" + + We don't want to complain about possible non-termination of F, in + GHC.Tc.Validity.checkFamInstRhs. cf indexed-types/should_fail/T13271 + +* (Any @k). + +For now we treat them as being size zero, but (#22696) I think we should +actually treat them as big (like any other ype family) because we don't +want to abstract over them in e.g. validDerivPred. + +The type-family termination test, in GHC.Tc.Validity.checkFamInstRhs, already +has a separate call to isStuckTypeFamily, so the `F` above will still be accepted. +-} + + +data PatersonSizeFailure + = PSF_TyFam TyCon -- Type family + | PSF_Size -- Too many type constructors/variables + | PSF_TyVar [TyVar] -- These type variables appear more often than in instance head; + -- no duplicates in this list + +-------------------------------------- + +data PatersonSize -- See Note [Paterson conditions] in GHC.Tc.Validity + = PS_TyFam TyCon -- Mentions a type family; infinite size + + | PS_Vanilla { ps_tvs :: [TyVar] -- Free tyvars, including repetitions; + , ps_size :: Int -- Number of type constructors and variables + } + -- Always after expanding synonyms + -- Always ignore coercions (not user written) + -- ToDo: ignore invisible arguments? See Note [Invisible arguments and termination] + +instance Outputable PatersonSize where + ppr (PS_TyFam tc) = text "PS_TyFam" <+> ppr tc + ppr (PS_Vanilla { ps_tvs = tvs, ps_size = size }) + = text "PS_Vanilla" <> braces (sep [ text "ps_tvs =" <+> ppr tvs <> comma + , text "ps_size =" <+> int size ]) + +pSizeZero, pSizeOne :: PatersonSize +pSizeZero = PS_Vanilla { ps_tvs = [], ps_size = 0 } +pSizeOne = PS_Vanilla { ps_tvs = [], ps_size = 1 } + +ltPatersonSize :: PatersonSize -- Size of constraint + -> PatersonSize -- Size of instance head; never PS_TyFam + -> Maybe PatersonSizeFailure +-- (ps1 `ltPatersonSize` ps2) returns +-- Nothing iff ps1 is strictly smaller than p2 +-- Just ps_fail says what went wrong +ltPatersonSize (PS_TyFam tc) _ = Just (PSF_TyFam tc) +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) + | otherwise = Nothing -- OK! +ltPatersonSize (PS_Vanilla {}) (PS_TyFam tc) + = pprPanic "ltPSize" (ppr tc) + -- Impossible because we never have a type family in an instance head + +noMoreTyVars :: [TyVar] -- Free vars (with repetitions) of the constraint C + -> [TyVar] -- Free vars (with repetitions) of the head H + -> [TyVar] -- TyVars that appear more often in C than H; + -- no repetitions in this list +noMoreTyVars tvs head_tvs + = nub (tvs \\ head_tvs) -- The (\\) is list difference; e.g. + -- [a,b,a,a] \\ [a,a] = [b,a] + -- So we are counting repetitions + +addPSize :: PatersonSize -> PatersonSize -> PatersonSize +addPSize ps1@(PS_TyFam {}) _ = ps1 +addPSize _ ps2@(PS_TyFam {}) = ps2 +addPSize (PS_Vanilla { ps_tvs = tvs1, ps_size = s1 }) + (PS_Vanilla { ps_tvs = tvs2, ps_size = s2 }) + = PS_Vanilla { ps_tvs = tvs1 ++ tvs2, ps_size = s1 + s2 } + -- (++) is not very performant, but the types + -- are user-written and never large + +pSizeType :: Type -> PatersonSize +pSizeType = pSizeTypeX emptyVarSet + +pSizeTypes :: [Type] -> PatersonSize +pSizeTypes = pSizeTypesX emptyVarSet pSizeZero + +-- Paterson size of a type, retaining repetitions, and expanding synonyms +-- This ignores coercions, as coercions aren't user-written +pSizeTypeX :: VarSet -> Type -> PatersonSize +pSizeTypeX bvs ty | Just exp_ty <- coreView ty = pSizeTypeX bvs exp_ty +pSizeTypeX bvs (TyVarTy tv) + | tv `elemVarSet` bvs = pSizeOne + | otherwise = PS_Vanilla { ps_tvs = [tv], ps_size = 1 } +pSizeTypeX _ (LitTy {}) = pSizeOne +pSizeTypeX bvs (TyConApp tc tys) = pSizeTyConAppX bvs tc tys +pSizeTypeX bvs (AppTy fun arg) = pSizeTypeX bvs fun `addPSize` pSizeTypeX bvs arg +pSizeTypeX bvs (FunTy _ w arg res) = pSizeTypeX bvs w `addPSize` pSizeTypeX bvs arg `addPSize` + pSizeTypeX bvs res +pSizeTypeX bvs (ForAllTy (Bndr tv _) ty) = pSizeTypeX bvs (tyVarKind tv) `addPSize` + pSizeTypeX (bvs `extendVarSet` tv) ty +pSizeTypeX bvs (CastTy ty _) = pSizeTypeX bvs ty +pSizeTypeX _ (CoercionTy {}) = pSizeOne + +pSizeTypesX :: VarSet -> PatersonSize -> [Type] -> PatersonSize +pSizeTypesX bvs sz tys = foldr (addPSize . pSizeTypeX bvs) sz tys + +pSizeTyConApp :: TyCon -> [Type] -> PatersonSize +pSizeTyConApp = pSizeTyConAppX emptyVarSet + +pSizeTyConAppX :: VarSet -> TyCon -> [Type] -> PatersonSize +-- Open question: do we count all args, or just the visible ones? +-- See Note [Invisible arguments and termination] +pSizeTyConAppX bvs tc tys + | isTypeFamilyTyCon tc = pSizeTyFamApp tc + | otherwise = pSizeTypesX bvs pSizeOne tys + +pSizeTyFamApp :: TyCon -> PatersonSize +-- See Note [Stuck type families] +pSizeTyFamApp tc + | isStuckTypeFamily tc = pSizeZero + | otherwise = PS_TyFam tc + +pSizeClassPred :: Class -> [Type] -> PatersonSize +pSizeClassPred = pSizeClassPredX emptyVarSet + +pSizeClassPredX :: VarSet -> Class -> [Type] -> PatersonSize +pSizeClassPredX bvs cls tys + | isTerminatingClass cls -- See (PS1) in Note [The PatersonSize of a type] + = pSizeZero + | otherwise + = pSizeTypesX bvs pSizeOne $ + filterOutInvisibleTypes (classTyCon cls) tys + -- filterOutInvisibleTypes Yuk! See Note [Invisible arguments and termination] + +isStuckTypeFamily :: TyCon -> Bool +-- See Note [Stuck type families] +isStuckTypeFamily tc + = tc `hasKey` errorMessageTypeErrorFamKey + || tc `hasKey` anyTyConKey + +-- | When this says "True", ignore this class constraint during +-- a termination check +-- See (PS1) in Note [The PatersonSize of a type] +isTerminatingClass :: Class -> Bool +isTerminatingClass cls + = 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 + || 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 + +allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool +-- (allDistinctTyVars tvs tys) returns True if tys are +-- a) all tyvars +-- b) all distinct +-- c) disjoint from tvs +allDistinctTyVars _ [] = True +allDistinctTyVars tkvs (ty : tys) + = case getTyVar_maybe ty of + Nothing -> False + Just tv | tv `elemVarSet` tkvs -> False + | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys + +----------------------- +type TypeSize = IntWithInf + +sizeType :: Type -> TypeSize +-- Size of a type: the number of variables and constructors +sizeType ty = toTypeSize (pSizeType ty) + +sizeTypes :: [Type] -> TypeSize +sizeTypes tys = toTypeSize (foldr (addPSize . pSizeType) pSizeZero tys) + +toTypeSize :: PatersonSize -> TypeSize +toTypeSize (PS_TyFam {}) = infinity +toTypeSize (PS_Vanilla { ps_size = size }) = mkIntWithInf size 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 @@ -2,8 +2,6 @@ import GHC.Utils.Outputable( SDoc ) import GHC.Prelude ( Bool ) import {-# SOURCE #-} GHC.Types.Var ( TcTyVar ) -import {-# SOURCE #-} GHC.Core.TyCo.Rep -import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Stack data MetaDetails @@ -14,6 +12,4 @@ isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar :: TcTyVar -> Bool isConcreteTyVar :: TcTyVar -> Bool - -tcEqType :: HasDebugCallStack => Type -> Type -> Bool 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 @@ -2,9 +2,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecursiveDo #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -15,7 +12,7 @@ -- Full-blown subsumption tcWrapResult, tcWrapResultO, tcWrapResultMono, tcTopSkolemise, tcSkolemiseScoped, tcSkolemiseExpType, - tcSubType, tcSubTypeNC, tcSubTypeSigma, tcSubTypePat, + tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS, tcSubTypeAmbiguity, tcSubMult, checkConstraints, checkTvConstraints, buildImplicationFor, buildTvImplication, emitResidualTvConstraint, @@ -42,8 +39,7 @@ import GHC.Prelude import GHC.Hs -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr( debugPprType ) + import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep, makeTypeConcrete, hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Instantiate @@ -52,6 +48,9 @@ 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 @@ -60,10 +59,9 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin +import GHC.Types.Name( Name, isSystemName ) -import GHC.Core.TyCon import GHC.Builtin.Types -import GHC.Types.Name( Name, isSystemName ) import GHC.Types.Var as Var import GHC.Types.Var.Set import GHC.Types.Var.Env @@ -132,10 +130,10 @@ go :: TcRhoType -- The type we're processing, perhaps after -- expanding type synonyms -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType) - go ty | Just ty' <- tcView ty = go ty' + 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 (af == VisArg) $ + = assert (isVisibleFunArg af) $ do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty ; return (idHsWrapper, Scaled w arg_ty, res_ty) } @@ -168,7 +166,7 @@ = do { arg_ty <- newOpenFlexiTyVarTy ; res_ty <- newOpenFlexiTyVarTy ; mult <- newFlexiTyVarTy multiplicityTy - ; let unif_fun_ty = mkVisFunTy mult arg_ty res_ty + ; 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) } @@ -205,7 +203,7 @@ -- | Like 'matchExpectedFunTys', but used when you have an "actual" type, -- for example in function application. -- --- INVARIANT: the returned arguemnt types all have a syntactically fixed RuntimeRep +-- 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] @@ -387,17 +385,17 @@ go acc_arg_tys n ty' ; return (wrap_gen <.> wrap_res, result) } - -- No more args; do this /before/ tcView, so + -- 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' <- tcView ty = go acc_arg_tys n ty' + | Just ty' <- coreView ty = go acc_arg_tys n ty' - go acc_arg_tys n (FunTy { ft_mult = mult, ft_af = af, ft_arg = arg_ty, ft_res = res_ty }) - = assert (af == VisArg) $ + 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) @@ -440,7 +438,7 @@ ; 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 = mkVisFunTys more_arg_tys 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) } @@ -465,7 +463,7 @@ -> TcM (TidyEnv, SDoc) mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call = do { (env', fun_rho) <- zonkTidyTcType env $ - mkVisFunTys arg_tys res_ty + mkScaledFunTys arg_tys res_ty ; let (all_arg_tys, _) = splitFunTys fun_rho n_fun_args = length all_arg_tys @@ -502,15 +500,16 @@ -- Postcondition: (T k1 k2 k3 a b c) is well-kinded matchExpectedTyConApp tc orig_ty - = assert (not $ isFunTyCon tc) $ go orig_ty + = assertPpr (isAlgTyCon tc) (ppr tc) $ + go orig_ty where go ty - | Just ty' <- tcView ty + | Just ty' <- coreView ty = go ty' go ty@(TyConApp tycon args) | tc == tycon -- Common case - = return (mkTcNomReflCo ty, args) + = return (mkNomReflCo ty, args) go (TyVarTy tv) | isMetaTyVar tv @@ -550,10 +549,10 @@ = go orig_ty where go ty - | Just ty' <- tcView ty = go ty' + | Just ty' <- coreView ty = go ty' | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty - = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty)) + = return (mkNomReflCo orig_ty, (fun_ty, arg_ty)) go (TyVarTy tv) | isMetaTyVar tv @@ -571,7 +570,7 @@ ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty ; return (co, (ty1, ty2)) } - orig_kind = tcTypeKind orig_ty + orig_kind = typeKind orig_ty kind1 = mkVisFunTyMany liftedTypeKind orig_kind kind2 = liftedTypeKind -- m :: * -> k -- arg type :: * @@ -651,7 +650,7 @@ Just frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty -- Compose the two coercions. - ; let final_co = prom_co `mkTcTransCo` frr_co + ; let final_co = prom_co `mkTransCo` frr_co ; writeTcRef ref (Just act_res_ty) @@ -721,7 +720,7 @@ 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 supppose the +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 @@ -840,7 +839,7 @@ = do { co <- fillInferResult ty_expected inf_res -- In patterns we do not instantatiate - ; return (mkWpCastN (mkTcSymCo co)) } + ; return (mkWpCastN (mkSymCo co)) } --------------- tcSubType :: CtOrigin -> UserTypeCtxt @@ -854,6 +853,24 @@ ; 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) @@ -1138,7 +1155,7 @@ https://github.com/ghc-proposals/ghc-proposals/pull/511. makes a best-efforts attempt implement deep subsumption as it was -prior to the the Simplify Subsumption proposal: +prior to the Simplify Subsumption proposal: https://github.com/ghc-proposals/ghc-proposals/pull/287 @@ -1154,7 +1171,7 @@ 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 tcSubTypeNC to match the result +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/. @@ -1260,9 +1277,9 @@ , text "ty_expected =" <+> ppr ty_expected ] ; go ty_actual ty_expected } where - -- NB: 'go' is not recursive, except for doing tcView - go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e - | Just ty_e' <- tcView ty_e = go ty_a ty_e' + -- 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 @@ -1273,13 +1290,13 @@ ; 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 = VisArg, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res }) - ty_e@(FunTy { ft_af = VisArg, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res }) - | isTauTy ty_a, isTauTy ty_e -- Short cut common case to avoid - = just_unify ty_actual ty_expected -- unnecessary eta expansion - - | otherwise - = -- This is where we do the co/contra thing, and generate a WpFun, which in turn + 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] @@ -1352,7 +1369,7 @@ deeplySkolemise skol_info ty = go init_subst ty where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) go subst ty | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty @@ -1362,14 +1379,12 @@ ; ev_vars1 <- newEvVars (substTheta subst' theta) ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty' ; let tv_prs1 = map tyVarName tvs `zip` tvs1 - ; return ( mkWpLams ids1 - <.> mkWpTyLams tvs1 - <.> mkWpLams ev_vars1 - <.> wrap - <.> mkWpEvVarApps ids1 + ; return ( mkWpEta ids1 (mkWpTyLams tvs1 + <.> mkWpEvLams ev_vars1 + <.> wrap) , tv_prs1 ++ tvs_prs2 , ev_vars1 ++ ev_vars2 - , mkVisFunTys arg_tys' rho ) } + , mkScaledFunTys arg_tys' rho ) } | otherwise = return (idHsWrapper, [], [], substTy subst ty) @@ -1379,7 +1394,7 @@ deeplyInstantiate orig ty = go init_subst ty where - init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)) + init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty)) go subst ty | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty @@ -1389,11 +1404,8 @@ ; ids1 <- newSysLocalIds (fsLit "di") arg_tys' ; wrap1 <- instCall orig (mkTyVarTys tvs') theta' ; (wrap2, rho2) <- go subst' rho - ; return (mkWpLams ids1 - <.> wrap2 - <.> wrap1 - <.> mkWpEvVarApps ids1, - mkVisFunTys arg_tys' rho2) } + ; return (mkWpEta ids1 (wrap2 <.> wrap1), + mkScaledFunTys arg_tys' rho2) } | otherwise = do { let ty' = substTy subst ty @@ -1465,8 +1477,8 @@ = do { deep_subsumption <- xoptM LangExt.DeepSubsumption ; let skolemise | deep_subsumption = deeplySkolemise | otherwise = topSkolemise - ; -- 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 {..}: 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) } @@ -1483,7 +1495,9 @@ = do { res <- thing_inside expected_ty ; return (idHsWrapper, res) } | otherwise - = do { rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty + = 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 @@ -1685,7 +1699,7 @@ -} unifyType :: Maybe TypedThing -- ^ If present, the thing that has type ty1 - -> TcTauType -> TcTauType -- ty1, ty2 + -> TcTauType -> TcTauType -- ty1 (actual), ty2 (expected) -> TcM TcCoercionN -- :: ty1 ~# ty2 -- Actual and expected types -- Returns a coercion : ty1 ~ ty2 @@ -1739,6 +1753,8 @@ -------------- -- 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 @@ -1815,17 +1831,18 @@ -- 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' <- tcView ty1 = go ty1' ty2 - | Just ty2' <- tcView ty2 = 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 = VisArg, ft_mult = w1, ft_arg = arg1, ft_res = res1 }) - (FunTy { ft_af = VisArg, ft_mult = w2, ft_arg = arg2, ft_res = res2 }) + 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 $ mkFunCo Nominal co_w co_l co_r } + ; 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.) @@ -1856,12 +1873,12 @@ go (AppTy s1 t1) (TyConApp tc2 ts2) | Just (ts2', t2') <- snocView ts2 - = assert (not (mustBeSaturated tc2)) $ + = 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 (mustBeSaturated tc1)) $ + = assert (not (tyConMustBeSaturated tc1)) $ go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2 go (CoercionTy co1) (CoercionTy co2) @@ -2012,7 +2029,7 @@ -> TcTauType -- Type 2, zonked -> TcM Coercion uUnfilledVar1 origin t_or_k swapped tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 + | Just tv2 <- getTyVar_maybe ty2 = go tv2 | otherwise @@ -2055,26 +2072,26 @@ -- 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 (tcTypeKind ty2) (tyVarKind tv1) + = do { can_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2 + ; if not can_continue_solving + then not_ok_so_defer + else + 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 (tcTypeKind ty2) - , ppr (isTcReflCo co_k), ppr co_k ] + , ppr ty2 <+> dcolon <+> ppr (typeKind ty2) + , ppr (isReflCo co_k), ppr co_k ] - ; if isTcReflCo 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 (mkTcNomReflCo 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 + 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 @@ -2094,38 +2111,39 @@ -- | 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 :: MetaInfo -> TcType -- zonked + -> TcM Bool startSolvingByUnification _ xi | hasCoercionHoleTy xi -- (COERCION-HOLE) check - = return Nothing + = return False startSolvingByUnification info xi = case info of - CycleBreakerTv -> return Nothing + CycleBreakerTv -> return False ConcreteTv conc_orig -> - do { (xi, not_conc_reasons) <- makeTypeConcrete conc_orig xi + do { (_, 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. + -- We don't need to track these unifications for the purposes + -- of constraint solving (e.g. updating tcs_unified or tcs_unif_lvl), + -- as they don't unlock any further progress. ; case not_conc_reasons of - [] -> return $ Just xi - _ -> return Nothing } + [] -> return True + _ -> return False } TyVarTv -> - case tcGetTyVar_maybe xi of - Nothing -> return Nothing + case getTyVar_maybe xi of + Nothing -> return False Just tv -> case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle - SkolemTv {} -> return $ Just xi - RuntimeUnk -> return $ Just xi + SkolemTv {} -> return True + RuntimeUnk -> return True MetaTv { mtv_info = info } -> case info of - TyVarTv -> return $ Just xi - _ -> return Nothing - _ -> return $ Just xi + TyVarTv -> return True + _ -> return False + _ -> return True swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool swapOverTyVars is_given tv1 tv2 @@ -2200,7 +2218,7 @@ assumptions", section 2.2. We say that alpha[1] is "untouchable" inside this implication. - Bottom line: at amibient level 'l', when looking at a constraint + 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'. @@ -2242,7 +2260,7 @@ 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 mechansim in + 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. @@ -2291,6 +2309,9 @@ 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). @@ -2497,14 +2518,14 @@ matchExpectedFunKind :: TypedThing -- ^ type, only for errors -> Arity -- ^ n: number of desired arrows - -> TcKind -- ^ fun_ kind + -> 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' <- tcView k = go n k' + go n k | Just k' <- coreView k = go n k' go n k@(TyVarTy kvar) | isMetaTyVar kvar @@ -2513,9 +2534,10 @@ Indirect fun_kind -> go n fun_kind Flexi -> defer n k } - go n (FunTy { ft_mult = w, ft_arg = arg, ft_res = res }) + go n (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) + | isVisibleFunArg af = do { co <- go (n-1) res - ; return (mkTcFunCo Nominal (mkTcNomReflCo w) (mkTcNomReflCo arg) co) } + ; return (mkNakedFunCo1 Nominal af (mkNomReflCo w) (mkNomReflCo arg) co) } go n other = defer n other @@ -2639,7 +2661,7 @@ 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 && af == InvisArg + if not ghci_tv && isInvisibleFunArg af then impredicative else cteOK go (AppTy fun arg) = go fun S.<> go arg diff --git a/GHC/Tc/Utils/Zonk.hs b/GHC/Tc/Utils/Zonk.hs --- a/GHC/Tc/Utils/Zonk.hs +++ b/GHC/Tc/Utils/Zonk.hs @@ -56,9 +56,8 @@ 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.TyCo.Ppr ( pprTyVar ) import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion @@ -79,7 +78,6 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Id -import GHC.Types.Id.Info import GHC.Types.TypeEnv import GHC.Types.SourceText import GHC.Types.Basic @@ -355,7 +353,7 @@ -- immediately by creating a TypeEnv zonkLIdOcc :: ZonkEnv -> LocatedN TcId -> LocatedN Id -zonkLIdOcc env = mapLoc (zonkIdOcc env) +zonkLIdOcc env = fmap (zonkIdOcc env) zonkIdOcc :: ZonkEnv -> TcId -> Id -- Ids defined in this module should be in the envt; @@ -386,7 +384,7 @@ zonkIdBndr :: ZonkEnv -> TcId -> TcM Id zonkIdBndr env v = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v) - return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdMult (setIdType v ty') w')) + return (setIdMult (setIdType v ty') w') zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id] zonkIdBndrs env ids = mapM (zonkIdBndr env) ids @@ -537,12 +535,12 @@ zonk_bind :: ZonkEnv -> HsBind GhcTc -> TcM (HsBind GhcTc) zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss - , pat_ext = ty}) + , 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 }) } + , pat_ext = (new_ty, ticks) }) } zonk_bind env (VarBind { var_ext = x , var_id = var, var_rhs = expr }) @@ -554,13 +552,13 @@ zonk_bind env bind@(FunBind { fun_id = L loc var , fun_matches = ms - , fun_ext = co_fn }) + , 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 }) } + , fun_ext = (new_co_fn, ticks) }) } zonk_bind env (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , abs_ev_binds = ev_binds @@ -587,7 +585,7 @@ | has_sig , (L loc bind@(FunBind { fun_id = (L mloc mono_id) , fun_matches = ms - , fun_ext = co_fn })) <- lbind + , 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 @@ -596,7 +594,7 @@ ; return $ L loc $ bind { fun_id = L mloc new_mono_id , fun_matches = new_ms - , fun_ext = new_co_fn } } + , fun_ext = (new_co_fn, ticks) } } | otherwise = zonk_lbind env lbind -- The normal case @@ -676,14 +674,14 @@ -> 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 - , mg_origin = origin }) + , 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' - , mg_origin = origin }) } + , mg_ext = MatchGroupTc arg_tys' res_ty' origin + }) } zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns => ZonkEnv @@ -747,7 +745,7 @@ zonkExpr _ (HsIPVar x _) = dataConCantHappen x -zonkExpr _ (HsOverLabel x _) = dataConCantHappen x +zonkExpr _ (HsOverLabel x _ _) = dataConCantHappen x zonkExpr env (HsLit x (HsRat e f ty)) = do new_ty <- zonkTcTypeToTypeX env ty @@ -773,10 +771,10 @@ new_e2 <- zonkLExpr env e2 return (HsApp x new_e1 new_e2) -zonkExpr env (HsAppType ty e t) +zonkExpr env (HsAppType ty e at t) = do new_e <- zonkLExpr env e new_ty <- zonkTcTypeToTypeX env ty - return (HsAppType new_ty new_e t) + return (HsAppType new_ty new_e at t) -- NB: the type is an HsType; can't zonk that! zonkExpr env (HsTypedBracket hsb_tc body) @@ -785,10 +783,9 @@ zonkExpr env (HsUntypedBracket hsb_tc body) = (\x -> HsUntypedBracket x body) <$> zonkBracket env hsb_tc -zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) = - runTopSplice s >>= zonkExpr env +zonkExpr env (HsTypedSplice s _) = runTopSplice s >>= zonkExpr env -zonkExpr _ e@(HsSpliceE _ _) = pprPanic "zonkExpr: HsSpliceE" (ppr e) +zonkExpr _ e@(HsUntypedSplice _ _) = pprPanic "zonkExpr: HsUntypedSplice" (ppr e) zonkExpr _ (OpApp x _ _ _) = dataConCantHappen x @@ -859,32 +856,6 @@ ; return (expr { rcon_ext = new_con_expr , rcon_flds = new_rbinds }) } --- Record updates via dot syntax are replaced by desugared expressions --- in the renamer. See Note [Rebindable syntax and HsExpansion]. This --- is why we match on 'rupd_flds = Left rbinds' here and panic otherwise. -zonkExpr env (RecordUpd { rupd_flds = Left rbinds - , rupd_expr = expr - , rupd_ext = RecordUpdTc { - rupd_cons = cons - , rupd_in_tys = in_tys - , rupd_out_tys = out_tys - , rupd_wrap = req_wrap }}) - = do { new_expr <- zonkLExpr env expr - ; new_in_tys <- mapM (zonkTcTypeToTypeX env) in_tys - ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys - ; new_rbinds <- zonkRecUpdFields env rbinds - ; (_, new_recwrap) <- zonkCoFn env req_wrap - ; return ( - RecordUpd { - rupd_expr = new_expr - , rupd_flds = Left new_rbinds - , rupd_ext = RecordUpdTc { - rupd_cons = cons - , rupd_in_tys = new_in_tys - , rupd_out_tys = new_out_tys - , rupd_wrap = new_recwrap }}) } -zonkExpr _ (RecordUpd {}) = panic "GHC.Tc.Utils.Zonk: zonkExpr: The impossible happened!" - zonkExpr env (ExprWithTySig _ e ty) = do { e' <- zonkLExpr env e ; return (ExprWithTySig noExtField e' ty) } @@ -1038,7 +1009,7 @@ new_ty <- zonkTcTypeToTypeX env ty new_ids <- mapSndM (zonkExpr env) ids - massert (isLiftedTypeKind (tcTypeKind new_stack_tys)) + 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 @@ -1207,7 +1178,7 @@ ; (env1, bind_op') <- zonkSyntaxExpr env bind_op ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts - ; by' <- fmapMaybeM (zonkLExpr env2) by + ; by' <- traverse (zonkLExpr env2) by ; using' <- zonkLExpr env2 using ; (env3, return_op') <- zonkSyntaxExpr env2 return_op @@ -1311,16 +1282,6 @@ ; return (L l (fld { hfbLHS = new_id , hfbRHS = new_expr })) } -zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTc] - -> TcM [LHsRecUpdField GhcTc] -zonkRecUpdFields env = mapM zonk_rbind - where - zonk_rbind (L l fld) - = do { new_id <- wrapLocMA (zonkFieldOcc env) (hsRecUpdFieldOcc fld) - ; new_expr <- zonkLExpr env (hfbRHS fld) - ; return (L l (fld { hfbLHS = fmap ambiguousFieldOcc new_id - , hfbRHS = new_expr })) } - {- ************************************************************************ * * @@ -1356,10 +1317,10 @@ = do { (env', pat') <- zonkPat env pat ; return (env', BangPat x pat') } -zonk_pat env (AsPat x (L loc v) 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') pat') } + ; return (env', AsPat x (L loc v') at pat') } zonk_pat env (ViewPat ty expr pat) = do { expr' <- zonkLExpr env expr @@ -1673,7 +1634,7 @@ ; term' <- case getEqPredTys_maybe (idType var') of Just (r, ty1, ty2) | ty1 `eqType` ty2 - -> return (evCoercion (mkTcReflCo r ty1)) + -> return (evCoercion (mkReflCo r ty1)) _other -> zonkEvTerm env term ; return (bind { eb_lhs = var', eb_rhs = term' }) } @@ -1772,7 +1733,7 @@ T9198 and #19668. So yes, it seems worth it. -} -zonkTyVarOcc :: HasDebugCallStack => ZonkEnv -> TcTyVar -> TcM Type +zonkTyVarOcc :: ZonkEnv -> TcTyVar -> TcM Type zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi , ze_tv_env = tv_env , ze_meta_tv_env = mtv_env_ref }) tv @@ -1845,9 +1806,6 @@ | 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) } diff --git a/GHC/Tc/Validity.hs b/GHC/Tc/Validity.hs --- a/GHC/Tc/Validity.hs +++ b/GHC/Tc/Validity.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE DerivingStrategies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -18,10 +17,10 @@ checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst, arityErr, checkTyConTelescope, - allDistinctTyVars ) where import GHC.Prelude +import GHC.Data.FastString import GHC.Data.Maybe @@ -29,12 +28,19 @@ import GHC.Tc.Utils.Unify ( tcSubTypeAmbiguity ) import GHC.Tc.Solver ( simplifyAmbiguityCheck ) import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) -import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr -import GHC.Tc.Utils.TcType hiding ( sizeType, sizeTypes ) +import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Origin +import GHC.Tc.Types.Rank +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Env ( tcInitTidyEnv, tcInitOpenTidyEnv ) +import GHC.Tc.Instance.FunDeps +import GHC.Tc.Instance.Family + 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.Coercion @@ -42,41 +48,41 @@ import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Predicate -import GHC.Tc.Types.Origin -import GHC.Tc.Types.Rank -import GHC.Tc.Errors.Types -import GHC.Types.Error +import GHC.Core.TyCo.FVs +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr +import GHC.Core.FamInstEnv ( isDominatedBy, injectiveBranches + , InjectivityCheckResult(..) ) --- others: import GHC.Iface.Type ( pprIfaceType, pprIfaceTypeApp ) import GHC.CoreToIface ( toIfaceTyCon, toIfaceTcArgs, toIfaceType ) import GHC.Hs -import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.Env ( tcInitTidyEnv, tcInitOpenTidyEnv ) -import GHC.Tc.Instance.FunDeps -import GHC.Core.FamInstEnv - ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) ) -import GHC.Tc.Instance.Family +import GHC.Driver.Session +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Types.Error import GHC.Types.Basic ( UnboxedTupleOrSum(..), unboxedTupleOrSumExtension ) import GHC.Types.Name import GHC.Types.Var.Env import GHC.Types.Var.Set -import GHC.Types.Var ( VarBndr(..), mkTyVar ) +import GHC.Types.Var ( VarBndr(..), isInvisibleFunArg, mkTyVar ) +import GHC.Types.SrcLoc +import GHC.Types.Unique.Set( isEmptyUniqSet ) + import GHC.Utils.FV import GHC.Utils.Error -import GHC.Driver.Session import GHC.Utils.Misc -import GHC.Data.List.SetOps -import GHC.Types.SrcLoc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Builtin.Uniques ( mkAlphaTyVarUnique ) -import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.List.SetOps + +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + import Control.Monad import Data.Foldable import Data.Function -import Data.List ( (\\), nub ) +import Data.List ( (\\) ) import qualified Data.List.NonEmpty as NE {- @@ -361,11 +367,11 @@ checkValidType :: UserTypeCtxt -> Type -> TcM () -- Checks that a user-written type is valid for the given context -- Assumes argument is fully zonked --- Assumes arugment is well-kinded; +-- Assumes argument is well-kinded; -- that is, checkValidType doesn't need to do kind checking -- Not used for instance decls; checkValidInstance instead checkValidType ctxt ty - = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) + = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) ; rankn_flag <- xoptM LangExt.RankNTypes ; impred_flag <- xoptM LangExt.ImpredicativeTypes ; let gen_rank :: Rank -> Rank @@ -431,7 +437,7 @@ -- and there may be nested foralls for the subtype test to examine ; checkAmbiguity ctxt ty - ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) } + ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) } checkValidMonoType :: Type -> TcM () -- Assumes argument is fully zonked @@ -444,10 +450,10 @@ checkTySynRhs :: UserTypeCtxt -> TcType -> TcM () checkTySynRhs ctxt ty - | tcReturnsConstraintKind actual_kind + | returnsConstraintKind actual_kind = do { ck <- xoptM LangExt.ConstraintKinds ; if ck - then when (tcIsConstraintKind actual_kind) + then when (isConstraintLikeKind actual_kind) (do { dflags <- getDynFlags ; expand <- initialExpandMode ; check_pred_ty emptyTidyEnv dflags ctxt expand ty }) @@ -458,7 +464,7 @@ | otherwise = return () where - actual_kind = tcTypeKind ty + actual_kind = typeKind ty {- Note [Check for escaping result kind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -779,7 +785,7 @@ -- -- Critically, this case must come *after* the case for TyConApp. -- See Note [Liberal type synonyms]. -check_type ve@(ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt +check_type ve@(ValidityEnv{ ve_tidy_env = env , ve_rank = rank, ve_expand = expand }) ty | not (null tvbs && null theta) = do { traceTc "check_type" (ppr ty $$ ppr rank) @@ -791,9 +797,7 @@ -- Reject forall (a :: Eq b => b). blah -- In a kind signature we don't allow constraints - ; checkTcM (all (isInvisibleArgFlag . binderArgFlag) tvbs - || vdqAllowed ctxt) - (env, TcRnVDQInTermType (tidyType env ty)) + ; checkVdqOK ve tvbs ty -- Reject visible, dependent quantification in the type of a -- term (e.g., `f :: forall a -> a -> Maybe a`) @@ -811,12 +815,12 @@ where (tvbs, phi) = tcSplitForAllTyVarBinders ty (theta, tau) = tcSplitPhiTy phi - (env', _) = tidyTyCoVarBinders env tvbs + (env', _) = tidyForAllTyBinders env tvbs check_type (ve@ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt , ve_rank = rank }) ty@(FunTy _ mult arg_ty res_ty) - = do { failIfTcM (not (linearityAllowed ctxt) && not (isManyDataConTy mult)) + = do { failIfTcM (not (linearityAllowed ctxt) && not (isManyTy mult)) (env, TcRnLinearFuncInKind (tidyType env ty)) ; check_type (ve{ve_rank = arg_rank}) arg_ty ; check_type (ve{ve_rank = res_rank}) res_ty } @@ -868,7 +872,7 @@ check_expansion_only expand = assertPpr (isTypeSynonymTyCon tc) (ppr tc) $ - case tcView ty of + case coreView ty of Just ty' -> let err_ctxt = text "In the expansion of type synonym" <+> quotes (ppr tc) in addErrCtxt err_ctxt $ @@ -987,6 +991,14 @@ checkTcM (all isEqPred theta) (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) + (env, TcRnVDQInTermType (Just (tidyType env ty))) + where + no_vdq = all (isInvisibleForAllTyFlag . binderFlag) tvbs + ValidityEnv{ve_tidy_env = env, ve_ctxt = ctxt} = ve + {- Note [Liberal type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1128,7 +1140,7 @@ -> DynFlags -> UserTypeCtxt -> PredType -> TcM () check_pred_help under_syn env dflags ctxt pred - | Just pred' <- tcView pred -- Switch on under_syn when going under a + | Just pred' <- coreView pred -- Switch on under_syn when going under a -- synonym (#9838, yuk) = check_pred_help True env dflags ctxt pred' @@ -1140,7 +1152,7 @@ | otherwise -> check_class_pred env dflags ctxt pred cls tys EqPred _ _ _ -> pprPanic "check_pred_help" (ppr pred) - -- EqPreds, such as (t1 ~ #t2) or (t1 ~R# t2), don't even have kind Constraint + -- EqPreds, such as (t1 ~# t2) or (t1 ~R# t2), don't even have kind Constraint -- and should never appear before the '=>' of a type. Thus -- f :: (a ~# b) => blah -- is wrong. For user written signatures, it'll be rejected by kind-checking @@ -1248,7 +1260,7 @@ = do { result <- matchGlobalInst dflags False cls tys ; case result of OneInst { cir_what = what } - -> let dia = TcRnUnknownMessage $ + -> let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnSimplifiableClassConstraints) noHints (simplifiable_constraint_warn what) @@ -1376,7 +1388,7 @@ arityErr :: Outputable a => SDoc -> a -> Int -> Int -> TcRnMessage arityErr what name n m - = TcRnUnknownMessage $ mkPlainError noHints $ + = 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] @@ -1428,7 +1440,7 @@ instance KnownNat T That says that any module satisfying M.hsig must provide a KnownNat -instance for T. We absolultely need that instance when compiling a +instance for T. We absolutely need that instance when compiling a module that imports M.hsig: see #15379 and Note [Fabricating Evidence for Literals in Backpack] in GHC.Tc.Instance.Class. @@ -1587,7 +1599,9 @@ tcInstHeadTyAppAllTyVars ty | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty) = let tys' = filterOutInvisibleTypes tc tys -- avoid kinds - tys'' | tc == funTyCon, tys_h:tys_t <- tys', tys_h `eqType` manyDataConTy = tys_t + tys'' | tc `hasKey` fUNTyConKey + , ManyTy : tys_t <- tys' + = tys_t | otherwise = tys' in ok tys'' | LitTy _ <- ty = True -- accept type literals (#13833) @@ -1598,7 +1612,7 @@ -- and that each is distinct ok tys = equalLength tvs tys && hasNoDups tvs where - tvs = mapMaybe tcGetTyVar_maybe tys + tvs = mapMaybe getTyVar_maybe tys dropCasts :: Type -> Type -- See Note [Casts during validity checking] @@ -1617,7 +1631,7 @@ instTypeErr :: Class -> [Type] -> SDoc -> TcRnMessage instTypeErr cls tys msg - = TcRnUnknownMessage $ mkPlainError noHints $ + = mkTcRnUnknownMessage $ mkPlainError noHints $ hang (hang (text "Illegal instance declaration for") 2 (quotes (pprClassPred cls tys))) 2 msg @@ -1632,7 +1646,7 @@ -> whoops (text "Record data type may not be a data family") | otherwise -> case isStrLitTy x_ty of Just lbl - | isJust (lookupTyConFieldLabel lbl tc) + | isJust (lookupTyConFieldLabel (FieldLabelString lbl) tc) -> whoops (ppr tc <+> text "already has a field" <+> quotes (ppr lbl)) | otherwise -> return () @@ -1680,68 +1694,67 @@ Note [Valid 'deriving' predicate] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -validDerivPred checks for OK 'deriving' context. See Note [Exotic -derived instance contexts] in GHC.Tc.Deriv. However the predicate is -here because it uses sizeTypes, fvTypes. +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. -It checks for three things +It checks for two things: -(VD1) No repeated variables (hasNoDups fvs) +(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 -(VD2) No type constructors. This is done by comparing - sizeTypes tys == length (fvTypes tys) - sizeTypes counts variables and constructors; fvTypes returns variables. - So if they are the same, there must be no constructors. But there - might be applications thus (f (g x)). +(VD2) No type constructors; no foralls, no equalities: + see Note [Exotic derived instance contexts] in GHC.Tc.Deriv.Infer - Note that tys only includes the visible arguments of the class type + 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 sizeTypes - would count as a constructor! See #11833. + since the first argument to Category is a non-visible *, which has a + type constructor! See #11833. -(VD3) Also check for a bizarre corner case, when the derived instance decl - would look like - 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 Note [Equality class instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can't have users writing instances for the equality classes. But we still need to be able to write instances for them ourselves. So we allow instances only in the defining module. - -} -validDerivPred :: TyVarSet -> PredType -> Bool +validDerivPred :: PatersonSize -> PredType -> Bool -- See Note [Valid 'deriving' predicate] -validDerivPred tv_set pred - | not (tyCoVarsOfType pred `subVarSet` tv_set) - = False -- Check (VD3) - - | otherwise +validDerivPred head_size pred = case classifyPredType pred of + EqPred {} -> False -- Reject equality constraints + ForAllPred {} -> False -- Rejects quantified predicates - ClassPred cls tys - | isTerminatingClass cls -> True - -- Typeable constraints are bigger than they appear due - -- to kind polymorphism, but that's OK + ClassPred cls tys -> check_size (pSizeClassPred cls tys) + && isEmptyUniqSet (tyConsOfTypes visible_tys) + where + visible_tys = filterOutInvisibleTypes (classTyCon cls) tys -- (VD2) - | otherwise -> hasNoDups visible_fvs -- Check (VD1) - && lengthIs visible_fvs (sizeTypes visible_tys) -- Check (VD2) - where - visible_tys = filterOutInvisibleTypes (classTyCon cls) tys - visible_fvs = fvTypes visible_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 {} -> True -- Accept (f a) - EqPred {} -> False -- Reject equality constraints - ForAllPred {} -> False -- Rejects quantified predicates + where + check_size pred_size = isNothing (pred_size `ltPatersonSize` head_size) + -- Check (VD1) {- ************************************************************************ @@ -1751,38 +1764,80 @@ ************************************************************************ -} -{- Note [Instances and constraint synonyms] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Currently, we don't allow instances for constraint synonyms at all. -Consider these (#13267): - type C1 a = Show (a -> Bool) - instance C1 Int where -- I1 - show _ = "ur" +{- Note [Paterson conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Paterson Conditions ensure termination of instance resolution. +Given an instance declaration + instance (..., C t1.. tn, ...) => D s1 .. sm -This elicits "show is not a (visible) method of class C1", which isn't -a great message. But it comes from the renamer, so it's hard to improve. +we check that each constraint in the context of the instance is +"Paterson-smaller" than the instance head. The underlying idea of +Paterson-smaller is that -This needs a bit more care: - type C2 a = (Show a, Show Int) - instance C2 Int -- I2 + For any ground substitution S, for each constraint P in the + context, S(P) has fewer type constructors, counting repetitions, + than the head S(H) -If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose -the instance head, we'll expand the synonym on fly, and it'll look like - instance (%,%) (Show Int, Show Int) -and we /really/ don't want that. So we carefully do /not/ expand -synonyms, by matching on TyConApp directly. --} +We implement this check by checking the following syntactic conditions: -checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () -checkValidInstance ctxt hs_type ty - | not is_tc_app - = failWithTc (TcRnNoClassInstHead tau) +(PC1) No type variable has more (shallow) occurrences in P than in H. - | isNothing mb_cls - = failWithTc (TcRnIllegalClassInst (tyConFlavour tc)) + (If not, a substitution that replaces that variable with a big type + would make P have many more type constructors than H. Side note: we + could in principle skip this test for a variable of kind Bool, + since there are no big ground types we can substitute for it.) - | otherwise - = do { setSrcSpanA head_loc $ +(PC2) The constraint P has fewer constructors and variables (taken + together and counting repetitions) than the head H. This size + metric is computed by sizeType. + + (A substitution that replaces each variable with Int demonstrates + the need.) + +(PC3) The constraint P mentions no type functions. + + (A type function application can in principle expand to a type of + arbitrary size, and so are rejected out of hand. See #15172.) + +(See Section 5 of "Understanding functional dependencies via Constraint +Handling Rules", JFP Jan 2007; and the user manual section "Instance +termination rules".) + +We measure "size" with the data type PatersonSize, in GHC.Tc.Utils.TcType. + data PatersonSize + = PS_TyFam TyCon + | PS_Vanilla { ps_tvs :: [TyVar] -- Free tyvars, including repetitions; + , ps_size :: Int} -- Number of type constructors and variables + +* ps_tvs deals with (PC1) +* ps_size deals with (PC2) +* PS_TyFam deals with (PC3) + +Note [Tuples in checkInstTermination] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these two ways of giving the same instance decl (#8359): + + instance (Eq a, Num a) => C (T a) + + type X a = (Eq a, Num a) + instance X a => C (T a) + +In the former, `checkInstTermination` will check the size of two predicates: +(Eq a) and (Num a). In the latter, it will see only one: (X a). But we want +to treat the latter like the former. + +So the `check` function in `checkInstTermination`, we simply recurse +if we find a constraint tuple. +-} + + +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 + { setSrcSpanA head_loc $ checkValidInstHead ctxt clas inst_tys ; traceTc "checkValidInstance {" (ppr ty) @@ -1791,7 +1846,7 @@ ; expand <- initialExpandMode ; check_valid_theta env0 ctxt expand theta - -- The Termination and Coverate Conditions + -- The Termination and Coverage Conditions -- Check that instance inference will terminate (if we care) -- For Haskell 98 this will already have been done by checkValidTheta, -- but as we may be using other extensions we need to check. @@ -1815,43 +1870,45 @@ ; traceTc "End checkValidInstance }" empty ; return () } + _ -> failWithTc (TcRnNoClassInstHead tau) where - (_tvs, theta, tau) = tcSplitSigmaTy ty - is_tc_app = case tau of { TyConApp {} -> True; _ -> False } - TyConApp tc inst_tys = tau -- See Note [Instances and constraint synonyms] - mb_cls = tyConClass_maybe tc - Just clas = mb_cls + (theta, tau) = splitInstTyForValidity ty -- The location of the "head" of the instance head_loc = getLoc (getLHsInstDeclHead hs_type) -{- -Note [Paterson conditions] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Termination test: the so-called "Paterson conditions" (see Section 5 of -"Understanding functional dependencies via Constraint Handling Rules, -JFP Jan 2007). - -We check that each assertion in the context satisfies: - (1) no variable has more occurrences in the assertion than in the head, and - (2) the assertion has fewer constructors and variables (taken together - and counting repetitions) than the head. -This is only needed with -fglasgow-exts, as Haskell 98 restrictions -(which have already been checked) guarantee termination. - -The underlying idea is that +-- | Split an instance type of the form @forall tvbs. inst_ctxt => inst_head@ +-- and return @(inst_ctxt, inst_head)@. This function makes no attempt to look +-- through type synonyms. See @Note [Instances and constraint synonyms]@. +splitInstTyForValidity :: Type -> (ThetaType, Type) +splitInstTyForValidity = split_context [] . drop_foralls + where + -- This is like 'dropForAlls', except that it does not look through type + -- synonyms. + drop_foralls :: Type -> Type + drop_foralls (ForAllTy (Bndr _tv argf) ty) + | isInvisibleForAllTyFlag argf = drop_foralls ty + drop_foralls ty = ty - for any ground substitution, each assertion in the - context has fewer type constructors than the head. --} + -- This is like 'tcSplitPhiTy', except that it does not look through type + -- synonyms. + split_context :: ThetaType -> Type -> (ThetaType, Type) + split_context preds (FunTy { ft_af = af, ft_arg = pred, ft_res = tau }) + | isInvisibleFunArg af = split_context (pred:preds) tau + split_context preds ty = (reverse preds, ty) checkInstTermination :: ThetaType -> TcPredType -> TcM () -- See Note [Paterson conditions] checkInstTermination theta head_pred = check_preds emptyVarSet theta where - head_fvs = fvType head_pred - head_size = sizeType head_pred + head_size = pSizeType head_pred + -- This is inconsistent and probably wrong. pSizeType does not filter out + -- invisible type args (making the instance head look big), whereas the use of + -- pSizeClassPredX below /does/ filter them out (making the tested constraints + -- look smaller). I'm sure there is non termination lurking here, but see #15177 + -- for why I didn't change it. See Note [Invisible arguments and termination] + -- in GHC.Tc.Utils.TcType check_preds :: VarSet -> [PredType] -> TcM () check_preds foralld_tvs preds = mapM_ (check foralld_tvs) preds @@ -1860,86 +1917,84 @@ check foralld_tvs pred = case classifyPredType pred of EqPred {} -> return () -- See #4200. - IrredPred {} -> check2 foralld_tvs pred (sizeType pred) - ClassPred cls tys - | isTerminatingClass cls - -> return () + IrredPred {} -> check2 (pSizeTypeX foralld_tvs pred) - | isCTupleClass cls -- Look inside tuple predicates; #8359 + ClassPred cls tys + | isCTupleClass cls -- See Note [Tuples in checkInstTermination] -> check_preds foralld_tvs tys | otherwise -- Other ClassPreds - -> check2 foralld_tvs pred bogus_size - where - bogus_size = 1 + sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys) - -- See Note [Invisible arguments and termination] + -> check2 (pSizeClassPredX foralld_tvs cls tys) ForAllPred tvs _ head_pred' -> check (foralld_tvs `extendVarSetList` tvs) head_pred' -- Termination of the quantified predicate itself is checked -- when the predicates are individually checked for validity - check2 foralld_tvs pred pred_size - | not (null bad_tvs) = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (noMoreMsg bad_tvs what (ppr head_pred)) - | not (isTyFamFree pred) = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (nestedMsg what) - | pred_size >= head_size = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (smallerMsg what (ppr head_pred)) - | otherwise = return () - -- isTyFamFree: see Note [Type families in instance contexts] - where - what = text "constraint" <+> quotes (ppr pred) - bad_tvs = filterOut (`elemVarSet` foralld_tvs) (fvType pred) - \\ head_fvs + where + check2 pred_size + = case pred_size `ltPatersonSize` head_size of + Just ps_failure -> failWithTc $ mkInstSizeError ps_failure head_pred pred + Nothing -> return () -smallerMsg :: SDoc -> SDoc -> SDoc -smallerMsg what inst_head - = vcat [ hang (text "The" <+> what) - 2 (sep [ text "is no smaller than" - , text "the instance head" <+> quotes inst_head ]) - , parens undecidableMsg ] -noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc -noMoreMsg tvs what inst_head - = vcat [ hang (text "Variable" <> plural tvs1 <+> quotes (pprWithCommas ppr tvs1) - <+> occurs <+> text "more often") - 2 (sep [ text "in the" <+> what - , text "than in the instance head" <+> quotes inst_head ]) +mkInstSizeError :: PatersonSizeFailure -> TcPredType -> TcPredType -> TcRnMessage +mkInstSizeError ps_failure head_pred pred + = mkTcRnUnknownMessage $ mkPlainError noHints $ + vcat [ main_msg , parens undecidableMsg ] where - tvs1 = nub tvs - occurs = if isSingleton tvs1 then text "occurs" - else text "occur" + 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 [Type families in instance contexts] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Are these OK? - type family F a - instance F a => C (Maybe [a]) where ... - instance C (F a) => C [[[a]]] where ... -No: the type family in the instance head might blow up to an -arbitrarily large type, depending on how 'a' is instantiated. -So we require UndecidableInstances if we have a type family -in the instance head. #15172. +{- Note [Instances and constraint synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently, we don't allow instances for constraint synonyms at all. +Consider these (#13267): + type C1 a = Show (a -> Bool) + instance C1 Int where -- I1 + show _ = "ur" -Note [Invisible arguments and termination] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When checking the ​Paterson conditions for termination an instance -declaration, we check for the number of "constructors and variables" -in the instance head and constraints. Question: Do we look at +This elicits "show is not a (visible) method of class C1", which isn't +a great message. But it comes from the renamer, so it's hard to improve. - * All the arguments, visible or invisible? - * Just the visible arguments? +This needs a bit more care: + type C2 a = (Show a, Show Int) + instance C2 Int -- I2 -I think both will ensure termination, provided we are consistent. -Currently we are /not/ consistent, which is really a bug. It's -described in #15177, which contains a number of examples. -The suspicious bits are the calls to filterOutInvisibleTypes. +If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose +the instance head, we'll expand the synonym on fly, and it'll look like + instance (%,%) (Show Int, Show Int) +and we /really/ don't want that. So we carefully do /not/ expand +synonyms, by matching on TyConApp directly. + +For similar reasons, we do not use tcSplitSigmaTy when decomposing the instance +context, as the looks through type synonyms. If we looked through type +synonyms, then it could be possible to write an instance for a type synonym +involving a quantified constraint (see #22570). Instead, we define +splitInstTyForValidity, a specialized version of tcSplitSigmaTy (local to +GHC.Tc.Validity) that does not expand type synonyms. -} @@ -1967,7 +2022,7 @@ -- (b) failure of injectivity check_branch_compat prev_branches cur_branch | cur_branch `isDominatedBy` prev_branches - = do { let dia = TcRnUnknownMessage $ + = do { let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints (inaccessibleCoAxBranch fam_tc cur_branch) ; addDiagnosticAt (coAxBranchSpan cur_branch) dia ; return prev_branches } @@ -2069,23 +2124,23 @@ do { cpt_tvs <- zipWithM extract_tv pats pats_vis ; check_all_distinct_tvs $ zip cpt_tvs pats_vis } where - pats_vis :: [ArgFlag] - pats_vis = tyConArgFlags fam_tc pats + pats_vis :: [ForAllTyFlag] + pats_vis = tyConForAllTyFlags fam_tc pats -- Checks that a pattern on the LHS of a default is a type -- variable. If so, return the underlying type variable, and if -- not, throw an error. -- See Note [Type-checking default assoc decls] - extract_tv :: Type -- The particular type pattern from which to extract - -- its underlying type variable - -> ArgFlag -- The visibility of the type pattern - -- (only used for error message purposes) + extract_tv :: Type -- The particular type pattern from which to + -- extrace its underlying type variable + -> ForAllTyFlag -- The visibility of the type pattern + -- (only used for error message purposes) -> TcM TyVar extract_tv pat pat_vis = case getTyVar_maybe pat of Just tv -> pure tv - Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ + Nothing -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ + pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $ hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:") 2 (vcat [ppr_eqn, suggestion]) @@ -2093,7 +2148,7 @@ -- duplicated. If that is the case, throw an error. -- See Note [Type-checking default assoc decls] check_all_distinct_tvs :: - [(TyVar, ArgFlag)] -- The type variable arguments in the associated + [(TyVar, ForAllTyFlag)] -- The type variable arguments in the associated -- default declaration, along with their respective -- visibilities (the latter are only used for error -- message purposes) @@ -2102,8 +2157,8 @@ let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in traverse_ (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $ - TcRnUnknownMessage $ mkPlainError noHints $ - pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $ + mkTcRnUnknownMessage $ mkPlainError noHints $ + pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $ hang (text "Illegal duplicate variable" <+> quotes (ppr pat_tv) <+> text "in:") 2 (vcat [ppr_eqn, suggestion])) @@ -2118,34 +2173,47 @@ suggestion = text "The arguments to" <+> quotes (ppr fam_tc) <+> text "must all be distinct type variables" --- Make sure that each type family application is --- (1) strictly smaller than the lhs, --- (2) mentions no type variable more often than the lhs, and --- (3) does not contain any further type family instances. --- checkFamInstRhs :: TyCon -> [Type] -- LHS -> [(TyCon, [Type])] -- type family calls in RHS -> [TcRnMessage] +-- Ensure that the type family instance terminates. Specifically: +-- ensure that each type family application in the RHS is +-- (TF1) a call to a stuck family like (TypeError ...) or Any +-- See Note [Stuck type families] in GHC.Tc.Utils.TcType +-- or (TF2) obeys the Paterson conditions, namely: +-- - strictly smaller than the lhs, +-- - mentions no type variable more often than the lhs, and +-- - does not contain any further type family applications checkFamInstRhs lhs_tc lhs_tys famInsts - = map (TcRnUnknownMessage . mkPlainError noHints) $ mapMaybe check famInsts + = mapMaybe check famInsts where - lhs_size = sizeTyConAppArgs lhs_tc lhs_tys - inst_head = pprType (TyConApp lhs_tc lhs_tys) - lhs_fvs = fvTypes lhs_tys + lhs_size = pSizeTypes lhs_tys check (tc, tys) - | not (all isTyFamFree tys) = Just (nestedMsg what) - | not (null bad_tvs) = Just (noMoreMsg bad_tvs what inst_head) - | lhs_size <= fam_app_size = Just (smallerMsg what inst_head) - | otherwise = Nothing - where - what = text "type family application" - <+> quotes (pprType (TyConApp tc tys)) - fam_app_size = sizeTyConAppArgs tc tys - bad_tvs = fvTypes tys \\ lhs_fvs - -- The (\\) is list difference; e.g. - -- [a,b,a,a] \\ [a,a] = [b,a] - -- So we are counting repetitions + | 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) + | 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 ]) + ----------------- checkFamPatBinders :: TyCon -> [TcTyVar] -- Bound on LHS of family instance @@ -2198,7 +2266,7 @@ dodgy_tvs = cpt_tvs `minusVarSet` inj_cpt_tvs check_tvs tvs what what2 - = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ TcRnUnknownMessage $ mkPlainError noHints $ + = 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" @@ -2229,7 +2297,7 @@ -- 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 $ TcRnUnknownMessage $ mkPlainError noHints $ + ((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) } where @@ -2249,11 +2317,6 @@ = text "Type family instance equation is overlapped:" $$ nest 2 (pprCoAxBranchUser fam_tc cur_branch) -nestedMsg :: SDoc -> SDoc -nestedMsg what - = sep [ text "Illegal nested" <+> what - , parens undecidableMsg ] - ------------------------- checkConsistentFamInst :: AssocInstInfo -> TyCon -- ^ Family tycon @@ -2285,16 +2348,16 @@ where (ax_tvs, ax_arg_tys, _) = etaExpandCoAxBranch branch - arg_triples :: [(Type,Type, ArgFlag)] + arg_triples :: [(Type,Type, ForAllTyFlag)] arg_triples = [ (cls_arg_ty, at_arg_ty, vis) | (fam_tc_tv, vis, at_arg_ty) <- zip3 (tyConTyVars fam_tc) - (tyConArgFlags fam_tc ax_arg_tys) + (tyConForAllTyFlags fam_tc ax_arg_tys) ax_arg_tys , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ] pp_wrong_at_arg vis - = pprWithExplicitKindsWhen (isInvisibleArgFlag vis) $ + = pprWithExplicitKindsWhen (isInvisibleForAllTyFlag vis) $ vcat [ text "Type indexes must match class instance head" , text "Expected:" <+> pp_expected_ty , text " Actual:" <+> pp_actual_ty ] @@ -2317,12 +2380,12 @@ tidyTypes tidy_env2 ax_arg_tys mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv)) - tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "_") noSrcSpan + tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOccFS (fsLit "_")) noSrcSpan -- For check_match, bind_me, see -- Note [Matching in the consistent-instantiation check] - check_match :: [(Type,Type,ArgFlag)] -> TcM () - check_match triples = go emptyTCvSubst emptyTCvSubst triples + check_match :: [(Type,Type,ForAllTyFlag)] -> TcM () + check_match triples = go emptySubst emptySubst triples go _ _ [] = return () go lr_subst rl_subst ((ty1,ty2,vis):triples) @@ -2330,7 +2393,7 @@ , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1 = go lr_subst1 rl_subst1 triples | otherwise - = addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ pp_wrong_at_arg vis) + = addErrTc (mkTcRnUnknownMessage $ mkPlainError noHints $ pp_wrong_at_arg vis) -- The /scoped/ type variables from the class-instance header -- should not be alpha-renamed. Inferred ones can be. @@ -2554,7 +2617,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's remarkably painful to give a decent error message for conflicts with the class header. Consider - clase C b where + class C b where type F a b c instance C [b] where type F x Int _ _ = ... @@ -2606,7 +2669,7 @@ first is caught by the renamer, but we catch the last two here. Perhaps one could argue that the second should be accepted, albeit with a warning, but consider the fact that in a type family instance, there is no way to interact -with such a varable. At least with @x :: forall a. Int@ we can use visibile +with such a variable. At least with @x :: forall a. Int@ we can use visible type application, like @x \@Bool 1@. (Of course it does nothing, but it is permissible.) In the type family case, the only sensible explanation is that the user has made a mistake -- thus we throw an error. @@ -2758,7 +2821,7 @@ checkTyConTelescope tc | bad_scope = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes] - addErr $ TcRnUnknownMessage $ mkPlainError noHints $ + addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped") 2 pp_tc_kind , extra @@ -2783,9 +2846,9 @@ fkvs = tyCoVarsOfType (tyVarKind tv) inferred_tvs = [ binderVar tcb - | tcb <- tcbs, Inferred == tyConBinderArgFlag tcb ] + | tcb <- tcbs, Inferred == tyConBinderForAllTyFlag tcb ] specified_tvs = [ binderVar tcb - | tcb <- tcbs, Specified == tyConBinderArgFlag tcb ] + | tcb <- tcbs, Specified == tyConBinderForAllTyFlag tcb ] pp_inf = parens (text "namely:" <+> pprTyVars inferred_tvs) pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs) @@ -2812,70 +2875,3 @@ 2 (vcat [ sep [ pp_inf, text "always come first"] , sep [text "then Specified variables", pp_spec]]) -{- -************************************************************************ -* * -\subsection{Auxiliary functions} -* * -************************************************************************ --} - --- Free variables of a type, retaining repetitions, and expanding synonyms --- This ignores coercions, as coercions aren't user-written -fvType :: Type -> [TyCoVar] -fvType ty | Just exp_ty <- tcView ty = fvType exp_ty -fvType (TyVarTy tv) = [tv] -fvType (TyConApp _ tys) = fvTypes tys -fvType (LitTy {}) = [] -fvType (AppTy fun arg) = fvType fun ++ fvType arg -fvType (FunTy _ w arg res) = fvType w ++ fvType arg ++ fvType res -fvType (ForAllTy (Bndr tv _) ty) - = fvType (tyVarKind tv) ++ - filter (/= tv) (fvType ty) -fvType (CastTy ty _) = fvType ty -fvType (CoercionTy {}) = [] - -fvTypes :: [Type] -> [TyVar] -fvTypes tys = concatMap fvType tys - -sizeType :: Type -> Int --- Size of a type: the number of variables and constructors -sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty -sizeType (TyVarTy {}) = 1 -sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys -sizeType (LitTy {}) = 1 -sizeType (AppTy fun arg) = sizeType fun + sizeType arg -sizeType (FunTy _ w arg res) = sizeType w + sizeType arg + sizeType res + 1 -sizeType (ForAllTy _ ty) = sizeType ty -sizeType (CastTy ty _) = sizeType ty -sizeType (CoercionTy _) = 0 - -sizeTypes :: [Type] -> Int -sizeTypes = foldr ((+) . sizeType) 0 - -sizeTyConAppArgs :: TyCon -> [Type] -> Int -sizeTyConAppArgs _tc tys = sizeTypes tys -- (filterOutInvisibleTypes tc tys) - -- See Note [Invisible arguments and termination] - --- | When this says "True", ignore this class constraint during --- a termination check -isTerminatingClass :: Class -> Bool -isTerminatingClass cls - = 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 - || cls `hasKey` typeableClassKey - || cls `hasKey` coercibleTyConKey - -allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool --- (allDistinctTyVars tvs tys) returns True if tys are --- a) all tyvars --- b) all distinct --- c) disjoint from tvs -allDistinctTyVars _ [] = True -allDistinctTyVars tkvs (ty : tys) - = case getTyVar_maybe ty of - Nothing -> False - Just tv | tv `elemVarSet` tkvs -> False - | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys diff --git a/GHC/ThToHs.hs b/GHC/ThToHs.hs --- a/GHC/ThToHs.hs +++ b/GHC/ThToHs.hs @@ -3,14 +3,12 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- (c) The University of Glasgow 2006 @@ -29,10 +27,11 @@ ) where -import GHC.Prelude +import GHC.Prelude hiding (head, init, last, tail) import GHC.Hs as Hs import GHC.Builtin.Names +import GHC.Tc.Errors.Types import GHC.Types.Name.Reader import qualified GHC.Types.Name as Name import GHC.Unit.Module @@ -42,21 +41,27 @@ import GHC.Core.Type as Hs import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import GHC.Builtin.Types +import GHC.Builtin.Types.Prim( fUNTyCon ) import GHC.Types.Basic as Hs import GHC.Types.Fixity as Hs import GHC.Types.ForeignCall import GHC.Types.Unique import GHC.Types.SourceText -import GHC.Utils.Error import GHC.Data.Bag import GHC.Utils.Lexeme import GHC.Utils.Misc import GHC.Data.FastString -import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + import qualified Data.ByteString as BS import Control.Monad( unless, ap ) +import Control.Applicative( (<|>) ) +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 Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH @@ -67,30 +72,34 @@ ------------------------------------------------------------------- -- The external interface -convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either SDoc [LHsDecl GhcPs] -convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds)) +convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either RunSpliceFailReason [LHsDecl GhcPs] +convertToHsDecls origin loc ds = + initCvt origin loc $ fmap catMaybes (mapM cvt_dec ds) where - cvt_dec d = wrapMsg "declaration" d (cvtDec d) + cvt_dec d = + wrapMsg (ConvDec d) $ cvtDec d -convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either SDoc (LHsExpr GhcPs) +convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either RunSpliceFailReason (LHsExpr GhcPs) convertToHsExpr origin loc e - = initCvt origin loc $ wrapMsg "expression" e $ cvtl e + = initCvt origin loc $ wrapMsg (ConvExp e) $ cvtl e -convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either SDoc (LPat GhcPs) +convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either RunSpliceFailReason (LPat GhcPs) convertToPat origin loc p - = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p + = initCvt origin loc $ wrapMsg (ConvPat p) $ cvtPat p -convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either SDoc (LHsType GhcPs) +convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either RunSpliceFailReason (LHsType GhcPs) convertToHsType origin loc t - = initCvt origin loc $ wrapMsg "type" t $ cvtType t + = initCvt origin loc $ wrapMsg (ConvType t) $ cvtType t ------------------------------------------------------------------- -newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either SDoc (SrcSpan, a) } +newtype CvtM' err a = CvtM { unCvtM :: Origin -> SrcSpan -> Either err (SrcSpan, a) } deriving (Functor) -- Push down the Origin (that is configurable by -- -fenable-th-splice-warnings) and source location; -- Can fail, with a single error message +type CvtM = CvtM' ConversionFailReason + -- NB: If the conversion succeeds with (Right x), there should -- be no exception values hiding in x -- Reason: so a (head []) in TH code doesn't subsequently @@ -99,22 +108,25 @@ -- Use the SrcSpan everywhere, for lack of anything better. -- See Note [Source locations within TH splices]. -instance Applicative CvtM where +instance Applicative (CvtM' err) where pure x = CvtM $ \_ loc -> Right (loc,x) (<*>) = ap -instance Monad CvtM where +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' -initCvt :: Origin -> SrcSpan -> CvtM a -> Either SDoc a +mapCvtMError :: (err1 -> err2) -> CvtM' err1 a -> CvtM' err2 a +mapCvtMError f (CvtM m) = CvtM $ \origin loc -> first f $ m origin loc + +initCvt :: Origin -> SrcSpan -> CvtM' err a -> Either err a initCvt origin loc (CvtM m) = fmap snd (m origin loc) force :: a -> CvtM () force a = a `seq` return () -failWith :: SDoc -> CvtM a +failWith :: ConversionFailReason -> CvtM a failWith m = CvtM (\_ _ -> Left m) getOrigin :: CvtM Origin @@ -137,19 +149,8 @@ wrapParLA :: (LocatedAn ann a -> b) -> a -> CvtM b wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x))) -wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b --- E.g wrapMsg "declaration" dec thing -wrapMsg what item (CvtM m) - = CvtM $ \origin loc -> case m origin loc of - Left err -> Left (err $$ msg) - Right v -> Right v - where - -- Show the item in pretty syntax normally, - -- but with all its constructors if you say -dppr-debug - msg = hang (text "When splicing a TH" <+> text what <> colon) - 2 (getPprDebug $ \case - True -> text (show item) - False -> text (pprint item)) +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 @@ -216,18 +217,16 @@ | otherwise = do { pat' <- cvtPat pat ; body' <- cvtGuard body - ; ds' <- cvtLocalDecs (text "a where clause") ds + ; ds' <- cvtLocalDecs WhereClause ds ; returnJustLA $ Hs.ValD noExtField $ PatBind { pat_lhs = pat' , pat_rhs = GRHSs emptyComments body' ds' , pat_ext = noAnn - , pat_ticks = ([],[]) } } + } } cvtDec (TH.FunD nm cls) | null cls - = failWith (text "Function binding for" - <+> quotes (text (TH.pprint nm)) - <+> text "has no equations") + = failWith $ FunBindLacksEquations nm | otherwise = do { nm' <- vNameN nm ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls @@ -271,42 +270,18 @@ , tcdRhs = rhs' } } cvtDec (DataD ctxt tc tvs ksig constrs derivs) - = do { let isGadtCon (GadtC _ _ _) = True - isGadtCon (RecGadtC _ _ _) = True - isGadtCon (ForallC _ _ c) = isGadtCon c - isGadtCon _ = False - isGadtDecl = all isGadtCon constrs - isH98Decl = all (not . isGadtCon) constrs - ; unless (isGadtDecl || isH98Decl) - (failWith (text "Cannot mix GADT constructors with Haskell 98" - <+> text "constructors")) - ; unless (isNothing ksig || isGadtDecl) - (failWith (text "Kind signatures are only allowed on GADTs")) - ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs - ; ksig' <- cvtKind `traverse` ksig - ; cons' <- mapM cvtConstr constrs - ; derivs' <- cvtDerivs derivs - ; let defn = HsDataDefn { dd_ext = noExtField - , dd_ND = DataType, dd_cType = Nothing - , dd_ctxt = mkHsContextMaybe ctxt' - , dd_kindSig = ksig' - , dd_cons = cons', dd_derivs = derivs' } - ; returnJustLA $ TyClD noExtField $ - DataDecl { tcdDExt = noAnn - , tcdLName = tc', tcdTyVars = tvs' - , tcdFixity = Prefix - , tcdDataDefn = defn } } + = cvtDataDec ctxt tc tvs ksig constrs derivs cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; ksig' <- cvtKind `traverse` ksig - ; con' <- cvtConstr constr + ; con' <- cvtConstr cNameN constr ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField - , dd_ND = NewType, dd_cType = Nothing + , dd_cType = Nothing , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' - , dd_cons = [con'] + , dd_cons = NewTypeCon con' , dd_derivs = derivs' } ; returnJustLA $ TyClD noExtField $ DataDecl { tcdDExt = noAnn @@ -314,16 +289,17 @@ , tcdFixity = Prefix , tcdDataDefn = defn } } +cvtDec (TypeDataD tc tvs ksig constrs) + = cvtTypeDataDec tc tvs ksig constrs + cvtDec (ClassD ctxt cl tvs fds decs) = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs ; fds' <- mapM cvt_fundep fds - ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs + ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs ClssDecl decs ; unless (null adts') - (failWith $ (text "Default data instance declarations" - <+> text "are not allowed:") - $$ (Outputable.ppr adts')) + (failWith $ DefaultDataInstDecl adts') ; returnJustLA $ TyClD noExtField $ - ClassDecl { tcdCExt = (noAnn, NoAnnSortKey, NoLayoutInfo) + ClassDecl { tcdCExt = (noAnn, NoAnnSortKey), tcdLayout = NoLayoutInfo , tcdCtxt = mkHsContextMaybe cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' @@ -333,9 +309,9 @@ } cvtDec (InstanceD o ctxt ty decs) - = do { let doc = text "an instance declaration" - ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs - ; unless (null fams') (failWith (mkBadDecMsg doc fams')) + = do { (binds', sigs', fams', ats', adts') <- cvt_ci_decs InstanceDecl decs + ; for_ (nonEmpty fams') $ \ bad_fams -> + failWith (IllegalDeclaration InstanceDecl $ IllegalFamDecls bad_fams) ; ctxt' <- cvtContext funPrec ctxt ; (L loc ty') <- cvtType ty ; let inst_ty' = L loc $ mkHsImplicitSigType $ @@ -371,13 +347,14 @@ 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 constrs + ; cons' <- mapM (cvtConstr cNameN) constrs ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField - , dd_ND = DataType, dd_cType = Nothing + , dd_cType = Nothing , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' - , dd_cons = cons', dd_derivs = derivs' } + , dd_cons = DataTypeCons False cons' + , dd_derivs = derivs' } ; returnJustLA $ InstD noExtField $ DataFamInstD { dfid_ext = noExtField @@ -392,13 +369,13 @@ 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 constr + ; con' <- cvtConstr cNameN constr ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField - , dd_ND = NewType, dd_cType = Nothing + , dd_cType = Nothing , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' - , dd_cons = [con'], dd_derivs = derivs' } + , dd_cons = NewTypeCon con', dd_derivs = derivs' } ; returnJustLA $ InstD noExtField $ DataFamInstD { dfid_ext = noExtField , dfid_inst = DataFamInstDecl { dfid_eqn = @@ -484,8 +461,61 @@ -- cvtImplicitParamBind. They are not allowed in any other scope, so -- reaching this case indicates an error. cvtDec (TH.ImplicitParamBindD _ _) - = failWith (text "Implicit parameter binding only allowed in let or where") + = failWith InvalidImplicitParamBinding +-- Convert a @data@ declaration. +cvtDataDec :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()] + -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause] + -> CvtM (Maybe (LHsDecl GhcPs)) +cvtDataDec = cvtGenDataDec False + +-- 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] + -> 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 ()] + -> Maybe TH.Kind -> [TH.Con] -> [TH.DerivClause] + -> CvtM (Maybe (LHsDecl GhcPs)) +cvtGenDataDec type_data ctxt tc tvs ksig constrs derivs + = do { let isGadtCon (GadtC _ _ _) = True + isGadtCon (RecGadtC _ _ _) = True + isGadtCon (ForallC _ _ c) = isGadtCon c + isGadtCon _ = False + isGadtDecl = all isGadtCon constrs + isH98Decl = all (not . isGadtCon) constrs + -- A constructor in a @data@ or @newtype@ declaration is + -- a data constructor. A constructor in a @type data@ + -- declaration is a type constructor. + -- See Note [Type data declarations] in GHC.Rename.Module. + con_name + | type_data = tconNameN + | otherwise = cNameN + ; unless (isGadtDecl || isH98Decl) + (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 } } + ---------------- cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs) cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) @@ -514,12 +544,11 @@ (map HsValArg args') ++ args , feqn_fixity = Hs.Infix , feqn_rhs = rhs' } } - _ -> failWith $ text "Invalid type family instance LHS:" - <+> text (show lhs) + _ -> failWith $ InvalidTyFamInstLHS lhs } ---------------- -cvt_ci_decs :: SDoc -> [TH.Dec] +cvt_ci_decs :: THDeclDescriptor -> [TH.Dec] -> CvtM (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], @@ -527,14 +556,15 @@ [LDataFamInstDecl GhcPs]) -- Convert the declarations inside a class or instance decl -- ie signatures, bindings, and associated types -cvt_ci_decs doc decs +cvt_ci_decs declDescr decs = do { decs' <- cvtDecs decs ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs' ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs' ; let (sigs', prob_binds') = partitionWith is_sig no_ats' ; let (binds', prob_fams') = partitionWith is_bind prob_binds' ; let (fams', bads) = partitionWith is_fam_decl prob_fams' - ; unless (null bads) (failWith (mkBadDecMsg doc bads)) + ; for_ (nonEmpty bads) $ \ bad_decls -> + failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls) ; return (listToBag binds', sigs', fams', ats', adts') } ---------------- @@ -567,8 +597,7 @@ ; args' <- mapM cvtType [t1,t2] ; return (cxt', nm', outer_bndrs, ((map HsValArg args') ++ args)) } - _ -> failWith $ text "Invalid type instance header:" - <+> text (show tys) } + _ -> failWith $ InvalidTypeInstanceHeader tys } ---------------- cvt_tyfam_head :: TypeFamilyHead @@ -578,7 +607,7 @@ , Maybe (Hs.LInjectivityAnn GhcPs)) cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity) - = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars + = do { (_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars ; result' <- cvtFamilyResultSig result ; injectivity' <- traverse cvtInjectivityAnnotation injectivity ; return (tc', tyvars', result', injectivity') } @@ -616,39 +645,35 @@ is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e) is_ip_bind decl = Right decl -mkBadDecMsg :: Outputable a => SDoc -> [a] -> SDoc -mkBadDecMsg doc bads - = sep [ text "Illegal declaration(s) in" <+> doc <> colon - , nest 2 (vcat (map Outputable.ppr bads)) ] - --------------------------------------------------- -- Data types --------------------------------------------------- -cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs) +cvtConstr :: (TH.Name -> CvtM (LocatedN RdrName)) -- ^ convert constructor name + -> TH.Con -> CvtM (LConDecl GhcPs) -cvtConstr (NormalC c strtys) - = do { c' <- cNameN c +cvtConstr con_name (NormalC c strtys) + = do { c' <- con_name c ; tys' <- mapM cvt_arg strtys ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) } -cvtConstr (RecC c varstrtys) - = do { c' <- cNameN c +cvtConstr con_name (RecC c varstrtys) + = do { c' <- con_name c ; args' <- mapM cvt_id_arg varstrtys ; con_decl <- wrapParLA (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args' ; returnLA con_decl } -cvtConstr (InfixC st1 c st2) - = do { c' <- cNameN c +cvtConstr con_name (InfixC st1 c st2) + = do { c' <- con_name c ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (InfixCon (hsLinear st1') (hsLinear st2')) } -cvtConstr (ForallC tvs ctxt con) +cvtConstr con_name (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; ctxt' <- cvtContext funPrec ctxt - ; L _ con' <- cvtConstr con + ; L _ con' <- cvtConstr con_name con ; returnLA $ add_forall tvs' ctxt' con' } where add_cxt lcxt Nothing = mkHsContextMaybe lcxt @@ -676,32 +701,31 @@ where all_tvs = tvs' ++ ex_tvs -cvtConstr (GadtC [] _strtys _ty) - = failWith (text "GadtC must have at least one constructor name") - -cvtConstr (GadtC c strtys ty) - = do { c' <- mapM cNameN c +cvtConstr con_name (GadtC c strtys ty) = case nonEmpty c of + Nothing -> failWith GadtNoCons + Just c -> do + { c' <- mapM con_name c ; args <- mapM cvt_arg strtys ; ty' <- cvtType ty ; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'} -cvtConstr (RecGadtC [] _varstrtys _ty) - = failWith (text "RecGadtC must have at least one constructor name") - -cvtConstr (RecGadtC c varstrtys ty) - = do { c' <- mapM cNameN c +cvtConstr con_name (RecGadtC c varstrtys ty) = case nonEmpty c of + Nothing -> failWith RecGadtNoCons + Just c -> do + { c' <- mapM con_name c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys ; lrec_flds <- returnLA rec_flds ; mk_gadt_decl c' (RecConGADT lrec_flds noHsUniTok) ty' } -mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs +mk_gadt_decl :: NonEmpty (LocatedN RdrName) -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> CvtM (LConDecl GhcPs) mk_gadt_decl names args res_ty = do bndrs <- returnLA mkHsOuterImplicit returnLA $ ConDeclGADT { con_g_ext = noAnn , con_names = names + , con_dcolon = noHsUniTok , con_bndrs = bndrs , con_mb_cxt = Nothing , con_g_args = args @@ -756,17 +780,16 @@ ; 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 (cvt_conv callconv)) (L l safety') Nothing + -> mk_imp (CImport (L l $ quotedSourceText from) (L l (cvt_conv callconv)) (L l safety') Nothing (CFunction (StaticTarget (SourceText from) (mkFastString from) Nothing - True)) - (L l $ quotedSourceText from)) + True))) | Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety') (mkFastString (TH.nameBase nm)) from (L l $ quotedSourceText from) -> mk_imp impspec | otherwise - -> failWith $ text (show from) <+> text "is not a valid ccall impent" } + -> failWith $ InvalidCCallImpent from } where mk_imp impspec = do { nm' <- vNameN nm @@ -785,10 +808,9 @@ = do { nm' <- vNameN nm ; ty' <- cvtSigType ty ; l <- getL - ; let e = CExport (L l (CExportStatic (SourceText as) - (mkFastString as) - (cvt_conv callconv))) - (L l (SourceText as)) + ; let e = CExport (L l (SourceText as)) (L l (CExportStatic (SourceText as) + (mkFastString as) + (cvt_conv callconv))) ; return $ ForeignExport { fd_e_ext = noAnn , fd_name = nm' , fd_sig_ty = ty' @@ -855,18 +877,18 @@ cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtSigType ty ; returnJustLA $ Hs.SigD noExtField $ - SpecInstSig noAnn (SourceText "{-# SPECIALISE") ty' } + SpecInstSig (noAnn, (SourceText "{-# SPECIALISE")) ty' } cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) = do { let nm' = mkFastString nm - ; rd_name' <- returnLA (quotedSourceText nm,nm') + ; rd_name' <- returnLA nm' ; let act = cvtPhases phases AlwaysActive ; ty_bndrs' <- traverse cvtTvs ty_bndrs ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs ; lhs' <- cvtl lhs ; rhs' <- cvtl rhs ; rule <- returnLA $ - HsRule { rd_ext = noAnn + HsRule { rd_ext = (noAnn, quotedSourceText nm) , rd_name = rd_name' , rd_act = act , rd_tyvs = ty_bndrs' @@ -874,8 +896,7 @@ , rd_lhs = lhs' , rd_rhs = rhs' } ; returnJustLA $ Hs.RuleD noExtField - $ HsRules { rds_ext = noAnn - , rds_src = SourceText "{-# RULES" + $ HsRules { rds_ext = (noAnn, SourceText "{-# RULES") , rds_rules = [rule] } } @@ -891,7 +912,7 @@ n' <- vcName n wrapParLA ValueAnnProvenance n' ; returnJustLA $ Hs.AnnD noExtField - $ HsAnnotation noAnn (SourceText "{-# ANN") target' exp' + $ HsAnnotation (noAnn, (SourceText "{-# ANN")) target' exp' } -- NB: This is the only place in GHC.ThToHs that makes use of the `setL` @@ -904,7 +925,7 @@ = do { cls' <- wrapL $ mapM cNameN cls ; mty' <- traverse tconNameN mty ; returnJustLA $ Hs.SigD noExtField - $ CompleteMatchSig noAnn NoSourceText cls' mty' } + $ CompleteMatchSig (noAnn, NoSourceText) cls' mty' } dfltActivation :: TH.Inline -> Activation dfltActivation TH.NoInline = NeverActive @@ -937,21 +958,22 @@ -- Declarations --------------------------------------------------- -cvtLocalDecs :: SDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) -cvtLocalDecs doc ds +cvtLocalDecs :: THDeclDescriptor -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) +cvtLocalDecs declDescr ds = case partitionWith is_ip_bind ds of ([], []) -> return (EmptyLocalBinds noExtField) ([], _) -> do ds' <- cvtDecs ds let (binds, prob_sigs) = partitionWith is_bind ds' let (sigs, bads) = partitionWith is_sig prob_sigs - unless (null bads) (failWith (mkBadDecMsg doc bads)) + for_ (nonEmpty bads) $ \ bad_decls -> + failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls) return (HsValBinds noAnn (ValBinds NoAnnSortKey (listToBag binds) sigs)) (ip_binds, []) -> do binds <- mapM (uncurry cvtImplicitParamBind) ip_binds return (HsIPBinds noAnn (IPBinds noExtField binds)) ((_:_), (_:_)) -> - failWith (text "Implicit parameters mixed with other bindings") + failWith ImplicitParamsWithOtherBinds cvtClause :: HsMatchContext GhcPs -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) @@ -959,7 +981,7 @@ = do { ps' <- cvtPats ps ; let pps = map (parenthesizePat appPrec) ps' ; g' <- cvtGuard body - ; ds' <- cvtLocalDecs (text "a where clause") wheres + ; ds' <- cvtLocalDecs WhereClause wheres ; returnLA $ Hs.Match noAnn ctxt pps (GRHSs emptyComments g' ds') } cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs) @@ -991,17 +1013,13 @@ l' <- cvt_lit l let e' = mk_expr l' if is_compound_lit l' then wrapParLA gHsPar e' else pure e' - cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp noComments (mkLHsPar x') - (mkLHsPar y')} - cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y - ; return $ HsApp noComments (mkLHsPar x') - (mkLHsPar y')} - cvt (AppTypeE e t) = do { e' <- cvtl e - ; t' <- cvtType t - ; let tp = parenthesizeHsType appPrec t' - ; return $ HsAppType noSrcSpan e' - $ mkHsWildCardBndrs tp } + cvt (AppE e1 e2) = do { e1' <- parenthesizeHsExpr opPrec <$> cvtl e1 + ; e2' <- parenthesizeHsExpr appPrec <$> cvtl e2 + ; return $ HsApp noComments e1' e2' } + cvt (AppTypeE e t) = do { e' <- parenthesizeHsExpr opPrec <$> cvtl e + ; t' <- parenthesizeHsType appPrec <$> cvtType t + ; return $ HsAppType noExtField e' noHsTok + $ mkHsWildCardBndrs t' } cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its -- own expression to avoid pretty-printing -- oddities that can result from zero-argument @@ -1016,7 +1034,7 @@ ; wrapParLA (HsLamCase noAnn LamCase . mkMatchGroup th_origin) ms' } cvt (LamCasesE ms) - | null ms = failWith (text "\\cases expression with no alternatives") + | null ms = failWith CasesExprWithoutAlts | otherwise = do { ms' <- mapM (cvtClause $ LamCaseAlt LamCases) ms ; th_origin <- getOrigin ; wrapParLA (HsLamCase noAnn LamCases . mkMatchGroup th_origin) ms' @@ -1029,10 +1047,10 @@ 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 (text "Multi-way if-expression with no alternatives") + | null alts = failWith MultiWayIfWithoutAlts | otherwise = do { alts' <- mapM cvtpair alts ; return $ HsMultiIf noAnn alts' } - cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds + cvt (LetE ds e) = do { ds' <- cvtLocalDecs LetExpression ds ; e' <- cvtl e; return $ HsLet noAnn noHsTok ds' noHsTok e'} cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms ; th_origin <- getOrigin @@ -1104,11 +1122,13 @@ -- constructor names - see #14627. { s' <- vcName s ; wrapParLA (HsVar noExtField) s' } - cvt (LabelE s) = return $ HsOverLabel noComments (fsLit s) + cvt (LabelE s) = return $ HsOverLabel noComments NoSourceText (fsLit s) cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' } cvt (GetFieldE exp f) = do { e' <- cvtl exp - ; return $ HsGetField noComments e' (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (fsLit f)))) } - cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . fsLit) xs + ; return $ HsGetField noComments 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 {- | #16895 Ensure an infix expression's operator is a variable/constructor. Consider this example: @@ -1125,8 +1145,7 @@ ensureValidOpExp (VarE _n) m = m ensureValidOpExp (ConE _n) m = m ensureValidOpExp (UnboundVarE _n) m = m -ensureValidOpExp _e _m = - failWith (text "Non-variable expression is not allowed in an infix expression") +ensureValidOpExp _e _m = failWith NonVarInInfixExpr {- Note [Dropping constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1238,11 +1257,12 @@ ------------------------------------- cvtHsDo :: HsDoFlavour -> [TH.Stmt] -> CvtM (HsExpr GhcPs) -cvtHsDo do_or_lc stmts - | null stmts = failWith (text "Empty stmt list in do-block") - | otherwise - = do { stmts' <- cvtStmts stmts - ; let Just (stmts'', last') = snocView stmts' +cvtHsDo do_or_lc stmts = case nonEmpty stmts of + Nothing -> failWith EmptyStmtListInDoBlock + Just stmts -> do + { stmts' <- traverse cvtStmt stmts + ; let stmts'' = NE.init stmts' + last' = NE.last stmts' ; last'' <- case last' of (L loc (BodyStmt _ body _ _)) @@ -1251,9 +1271,7 @@ ; wrapParLA (HsDo noAnn do_or_lc) (stmts'' ++ [last'']) } where - bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAHsDoFlavour do_or_lc <> colon - , nest 2 $ Outputable.ppr stmt - , text "(It should be an expression.)" ] + bad_last stmt = IllegalLastStatement do_or_lc stmt cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)] cvtStmts = mapM cvtStmt @@ -1261,7 +1279,7 @@ cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs)) cvtStmt (NoBindS e) = do { e' <- cvtl e; returnLA $ mkBodyStmt e' } cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnLA $ mkPsBindStmt noAnn p' e' } -cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds +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 } @@ -1280,7 +1298,7 @@ (L loc SigPat{}) -> L loc (gParPat p') -- #14875 _ -> p' ; g' <- cvtGuard body - ; decs' <- cvtLocalDecs (text "a where clause") decs + ; decs' <- cvtLocalDecs WhereClause decs ; returnLA $ Hs.Match noAnn ctxt [lp] (GRHSs emptyComments g' decs') } cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] @@ -1385,10 +1403,11 @@ ; ps' <- cvtPats ps ; ts' <- mapM cvtType ts ; 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 (map (mkHsPatSigType noAnn) ts') pps + , pat_args = PrefixCon pts pps } } cvtp (InfixP p1 s p2) = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2 @@ -1410,7 +1429,7 @@ 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' p' } + ; return $ AsPat noAnn s' noHsTok p' } cvtp TH.WildP = return $ WildPat noExtField cvtp (RecP c fs) = do { c' <- cNameN c; fs' <- mapM cvtPatFld fs ; return $ ConPat @@ -1526,21 +1545,21 @@ returnLA $ Hs.ViaStrategy (XViaStrategyPs noAnn ty') cvtType :: TH.Type -> CvtM (LHsType GhcPs) -cvtType = cvtTypeKind "type" +cvtType = cvtTypeKind TypeLevel cvtSigType :: TH.Type -> CvtM (LHsSigType GhcPs) -cvtSigType = cvtSigTypeKind "type" +cvtSigType = cvtSigTypeKind TypeLevel -- | Convert a Template Haskell 'Type' to an 'LHsSigType'. To avoid duplicating -- the logic in 'cvtTypeKind' here, we simply reuse 'cvtTypeKind' and perform -- surgery on the 'LHsType' it returns to turn it into an 'LHsSigType'. -cvtSigTypeKind :: String -> TH.Type -> CvtM (LHsSigType GhcPs) -cvtSigTypeKind ty_str ty = do - ty' <- cvtTypeKind ty_str ty +cvtSigTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsSigType GhcPs) +cvtSigTypeKind typeOrKind ty = do + ty' <- cvtTypeKind typeOrKind ty pure $ hsTypeToHsSigType $ parenthesizeHsType sigPrec ty' -cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs) -cvtTypeKind ty_str ty +cvtTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsType GhcPs) +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 @@ -1563,10 +1582,7 @@ ; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' } UnboxedSumT n | n < 2 - -> failWith $ - vcat [ text "Illegal sum arity:" <+> text (show n) - , nest 2 $ - text "Sums must have an arity of at least 2" ] + -> failWith $ IllegalSumArity n | Just normals <- m_normals , normals `lengthIs` n -- Saturated -> returnLA (HsSumTy noAnn normals) @@ -1600,7 +1616,7 @@ w'' = hsTypeToArrow w' returnLA (HsFunTy noAnn w'' x'' y'') | otherwise - -> do { fun_tc <- returnLA $ getRdrName funTyCon + -> do { fun_tc <- returnLA $ getRdrName fUNTyCon ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' } ListT | Just normals <- m_normals @@ -1743,7 +1759,7 @@ ; returnLA (HsIParamTy noAnn (reLocA n') t') } - _ -> failWith (text "Malformed " <> text ty_str <+> text (show ty)) + _ -> failWith (MalformedType typeOrKind ty) } hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs @@ -1796,8 +1812,9 @@ wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized -- --------------------------------------------------------------------- --- Note [Adding parens for splices] {- +Note [Adding parens for splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The hsSyn representation of parsed source explicitly contains all the original parens, as written in the source. @@ -1828,7 +1845,7 @@ go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') } go f as = return (f,as) -cvtTyLit :: TH.TyLit -> HsTyLit +cvtTyLit :: TH.TyLit -> HsTyLit (GhcPass p) cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) cvtTyLit (TH.CharTyLit c) = HsCharTy NoSourceText c @@ -1853,10 +1870,10 @@ ; returnLA (mkHsOpTy prom x' op y) } cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) -cvtKind = cvtTypeKind "kind" +cvtKind = cvtTypeKind KindLevel cvtSigKind :: TH.Kind -> CvtM (LHsSigType GhcPs) -cvtSigKind = cvtSigTypeKind "kind" +cvtSigKind = cvtSigTypeKind KindLevel -- | Convert Maybe Kind to a type family result signature. Used with data -- families where naming of the result is not possible (thus only kind or no @@ -1933,14 +1950,11 @@ unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM () unboxedSumChecks alt arity | alt > arity - = failWith $ text "Sum alternative" <+> text (show alt) - <+> text "exceeds its arity," <+> text (show arity) + = failWith $ SumAltArityExceeded alt arity | alt <= 0 - = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt) - , nest 2 $ text "Sum alternatives must start from 1" ] + = failWith $ IllegalSumAlt alt | arity < 2 - = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity) - , nest 2 $ text "Sums must have an arity of at least 2" ] + = failWith $ IllegalSumArity arity | otherwise = return () @@ -2039,12 +2053,12 @@ ipName :: String -> CvtM HsIPName ipName n - = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n)) + = do { unless (okVarOcc n) (failWith (IllegalOccName OccName.varName n)) ; return (HsIPName (fsLit n)) } cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName cvtName ctxt_ns (TH.Name occ flavour) - | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str) + | 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 @@ -2067,11 +2081,6 @@ "" -> False (c:_) -> startsVarId c || startsVarSym c -badOcc :: OccName.NameSpace -> String -> SDoc -badOcc ctxt_ns occ - = text "Illegal" <+> pprNameSpace ctxt_ns - <+> text "name:" <+> quotes (text occ) - thRdrName :: 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] @@ -2107,9 +2116,10 @@ thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName thOrigRdrName occ th_ns pkg mod = let occ' = mk_occ (mk_ghc_ns th_ns) occ - in case isBuiltInOcc_maybe occ' of + mod' = mkModule (mk_pkg pkg) (mk_mod mod) + in case isBuiltInOcc_maybe occ' <|> isPunOcc_maybe mod' occ' of Just name -> nameRdrName name - Nothing -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ' + Nothing -> (mkOrig $! mod') $! occ' thRdrNameGuesses :: TH.Name -> [RdrName] thRdrNameGuesses (TH.Name occ flavour) diff --git a/GHC/Types/Avail.hs b/GHC/Types/Avail.hs --- a/GHC/Types/Avail.hs +++ b/GHC/Types/Avail.hs @@ -48,13 +48,15 @@ import GHC.Data.List.SetOps import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Misc import GHC.Utils.Constants (debugIsOn) +import Control.DeepSeq import Data.Data ( Data ) import Data.Either ( partitionEithers ) +import Data.Functor.Classes ( liftCompare ) import Data.List ( find ) import Data.Maybe +import qualified Data.Semigroup as S -- ----------------------------------------------------------------------------- -- The AvailInfo type @@ -166,8 +168,7 @@ stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering stableAvailCmp (Avail c1) (Avail c2) = c1 `stableGreNameCmp` c2 stableAvailCmp (Avail {}) (AvailTC {}) = LT -stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp` - (cmpList stableGreNameCmp ns ms) +stableAvailCmp (AvailTC n ns) (AvailTC m ms) = stableNameCmp n m S.<> liftCompare stableGreNameCmp ns ms stableAvailCmp (AvailTC {}) (Avail {}) = GT stableGreNameCmp :: GreName -> GreName -> Ordering @@ -272,10 +273,17 @@ 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 @@ -315,10 +323,10 @@ 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 - (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) - (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) - (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) - (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) + (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)) + (False,False) -> AvailTC n1 ((s1:ss1) `unionListsOrd` (s2:ss2)) plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2]) -- | trims an 'AvailInfo' to keep only a single name @@ -363,7 +371,7 @@ pprAvail (Avail n) = ppr n pprAvail (AvailTC n ns) - = ppr n <> braces (fsep (punctuate comma (map ppr ns))) + = ppr n <> braces (pprWithCommas ppr ns) instance Binary AvailInfo where put_ bh (Avail aa) = do @@ -382,6 +390,10 @@ ac <- get bh return (AvailTC ab ac) +instance NFData AvailInfo where + 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 @@ -396,3 +408,4 @@ return (NormalGreName aa) _ -> do ab <- get bh return (FieldGreName ab) + diff --git a/GHC/Types/Basic.hs b/GHC/Types/Basic.hs --- a/GHC/Types/Basic.hs +++ b/GHC/Types/Basic.hs @@ -14,13 +14,12 @@ \end{itemize} -} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable PromotionFlag, Binary PromotionFlag, Outputable Boxity, Binay Boxity {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - module GHC.Types.Basic ( LeftOrRight(..), pickLR, @@ -48,7 +47,8 @@ CbvMark(..), isMarkedCbv, - PprPrec(..), topPrec, sigPrec, opPrec, funPrec, starPrec, appPrec, + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, + starPrec, appPrec, maxPrec, maybeParen, TupleSort(..), tupleSortBoxity, boxityTupleSort, @@ -97,17 +97,17 @@ setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, pprInline, pprInlineDebug, + UnfoldingSource(..), isStableSource, isStableUserSource, + isStableSystemSource, isCompulsorySource, + SuccessFlag(..), succeeded, failed, successIf, IntWithInf, infinity, treatZeroAsInf, subWithInf, mkIntWithInf, intGtLimit, - SpliceExplicitFlag(..), - TypeOrKind(..), isTypeLevel, isKindLevel, Levity(..), mightBeLifted, mightBeUnlifted, - - ExprOrPat(..), + TypeOrConstraint(..), NonStandardDefaultingStrategy(..), DefaultingStrategy(..), defaultNonStandardTyVars, @@ -126,14 +126,14 @@ 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) -{- -************************************************************************ +{- ********************************************************************* * * Binary choice * * -************************************************************************ --} +********************************************************************* -} data LeftOrRight = CLeft | CRight deriving( Eq, Data ) @@ -199,12 +199,6 @@ ************************************************************************ -} --- | A *one-index* constructor tag --- --- Type of the tags associated with each constructor possibility or superclass --- selector -type ConTag = Int - -- | A *zero-indexed* constructor tag type ConTagZ = Int @@ -289,14 +283,14 @@ f g x = Just (case g x of { ... }) Here 'f' is lazy in 'g', but it guarantees to call it no - more than once. So g will get a C1(U) usage demand. + more than once. So g will get a C(1,U) usage demand. * Occurrence analysis propagates this usage information (in the demand signature of a function) to its calls. Example, given 'f' above f (\x.e) blah - Since f's demand signature says it has a C1(U) usage demand on its + Since f's demand signature says it has a C(1,U) usage demand on its first argument, the occurrence analyser sets the \x to be one-shot. This is done via the occ_one_shots field of OccEnv. @@ -364,7 +358,7 @@ bestOneShot OneShotLam _ = OneShotLam pprOneShotInfo :: OneShotInfo -> SDoc -pprOneShotInfo NoOneShotInfo = empty +pprOneShotInfo NoOneShotInfo = text "NoOS" pprOneShotInfo OneShotLam = text "OneShot" instance Outputable OneShotInfo where @@ -405,16 +399,6 @@ * * ********************************************************************* -} --- | Is a TyCon a promoted data constructor or just a normal type constructor? -data PromotionFlag - = NotPromoted - | IsPromoted - deriving ( Eq, Data ) - -isPromoted :: PromotionFlag -> Bool -isPromoted IsPromoted = True -isPromoted NotPromoted = False - instance Outputable PromotionFlag where ppr NotPromoted = text "NotPromoted" ppr IsPromoted = text "IsPromoted" @@ -502,15 +486,6 @@ ************************************************************************ -} -data Boxity - = Boxed - | Unboxed - deriving( Eq, Data ) - -isBoxed :: Boxity -> Bool -isBoxed Boxed = True -isBoxed Unboxed = False - instance Outputable Boxity where ppr Boxed = text "Boxed" ppr Unboxed = text "Unboxed" @@ -621,7 +596,7 @@ -} -- | The semantics allowed for overlapping instances for a particular --- instance. See Note [Safe Haskell isSafeOverlap] (in "GHC.Core.InstEnv") for a +-- instance. See Note [Safe Haskell isSafeOverlap] in GHC.Core.InstEnv for a -- explanation of the `isSafeOverlap` field. -- -- - 'GHC.Parser.Annotation.AnnKeywordId' : @@ -771,16 +746,17 @@ newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show) -- See Note [Precedence in types] -topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec :: PprPrec -topPrec = PprPrec 0 -- No parens -sigPrec = PprPrec 1 -- Explicit type signatures -funPrec = PprPrec 2 -- Function args; no parens for constructor apps - -- See [Type operator precedence] for why both - -- funPrec and opPrec exist. -opPrec = PprPrec 2 -- Infix operator +topPrec, sigPrec, funPrec, opPrec, starPrec, appPrec, maxPrec :: PprPrec +topPrec = PprPrec 0 -- No parens +sigPrec = PprPrec 1 -- Explicit type signatures +funPrec = PprPrec 2 -- Function args; no parens for constructor apps + -- See [Type operator precedence] for why both + -- funPrec and opPrec exist. +opPrec = PprPrec 2 -- Infix operator starPrec = PprPrec 3 -- Star syntax for the type of types, i.e. the * in (* -> *) -- See Note [Star kind precedence] appPrec = PprPrec 4 -- Constructor args; no parens for atomic +maxPrec = appPrec -- Maximum precendence maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc maybeParen ctxt_prec inner_prec pretty @@ -1367,7 +1343,7 @@ isAlwaysActive _ = False competesWith :: Activation -> Activation -> Bool --- See Note [Activation competition] +-- See Note [Competing activations] competesWith AlwaysActive _ = True competesWith NeverActive _ = False @@ -1459,7 +1435,7 @@ It's not possible to get that combination by *writing* something, so if an Id has defaultInlinePragma it means the user didn't specify anything. -If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding. +If inl_inline = Inline or Inlineable, then the Id should have a stable unfolding. If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair @@ -1773,9 +1749,11 @@ inlinePragmaName (Opaque _) = text "OPAQUE" inlinePragmaName NoUserInlinePrag = empty +-- | Pretty-print without displaying the user-specified 'InlineSpec'. pprInline :: InlinePragma -> SDoc pprInline = pprInline' True +-- | Pretty-print including the user-specified 'InlineSpec'. pprInlineDebug :: InlinePragma -> SDoc pprInlineDebug = pprInline' False @@ -1802,7 +1780,63 @@ | otherwise = ppr info +{- ********************************************************************* +* * + UnfoldingSource +* * +********************************************************************* -} +data UnfoldingSource + = -- See also Note [Historical note: unfoldings for wrappers] + VanillaSrc -- The current rhs of the function + -- Replace uf_tmpl each time around + + -- See Note [Stable unfoldings] in GHC.Core + | StableUserSrc -- From a user-specified INLINE or INLINABLE pragma + | StableSystemSrc -- From a wrapper, or system-generated unfolding + + | CompulsorySrc -- Something that *has* no binding, so you *must* inline it + -- Only a few primop-like things have this property + -- (see "GHC.Types.Id.Make", calls to mkCompulsoryUnfolding). + -- Inline absolutely always, however boring the context. + +isStableUserSource :: UnfoldingSource -> Bool +isStableUserSource StableUserSrc = True +isStableUserSource _ = False + +isStableSystemSource :: UnfoldingSource -> Bool +isStableSystemSource StableSystemSrc = True +isStableSystemSource _ = False + +isCompulsorySource :: UnfoldingSource -> Bool +isCompulsorySource CompulsorySrc = True +isCompulsorySource _ = False + +isStableSource :: UnfoldingSource -> Bool +isStableSource CompulsorySrc = True +isStableSource StableSystemSrc = True +isStableSource StableUserSrc = True +isStableSource VanillaSrc = False + +instance Binary UnfoldingSource where + put_ bh CompulsorySrc = putByte bh 0 + put_ bh StableUserSrc = putByte bh 1 + put_ bh StableSystemSrc = putByte bh 2 + put_ bh VanillaSrc = putByte bh 3 + get bh = do + h <- getByte bh + case h of + 0 -> return CompulsorySrc + 1 -> return StableUserSrc + 2 -> return StableSystemSrc + _ -> return VanillaSrc + +instance Outputable UnfoldingSource where + ppr CompulsorySrc = text "Compulsory" + ppr StableUserSrc = text "StableUser" + ppr StableSystemSrc = text "StableSystem" + ppr VanillaSrc = text "" + {- ************************************************************************ * * @@ -1877,11 +1911,6 @@ mkIntWithInf :: Int -> IntWithInf mkIntWithInf = Int -data SpliceExplicitFlag - = ExplicitSplice | -- ^ <=> $(f x y) - ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression - deriving Data - {- ********************************************************************* * * Types vs Kinds @@ -1906,10 +1935,17 @@ {- ********************************************************************* * * - Levity information + Levity and TypeOrConstraint * * ********************************************************************* -} +{- The types `Levity` and `TypeOrConstraint` are internal to GHC. + They have the same shape as the eponymous types in the library + ghc-prim:GHC.Types + but they aren't the same types -- after all, they are defined in a + different module. +-} + data Levity = Lifted | Unlifted @@ -1927,24 +1963,10 @@ mightBeUnlifted (Just Lifted) = False mightBeUnlifted _ = True -{- ********************************************************************* -* * - Expressions vs Patterns -* * -********************************************************************* -} - --- | Are we dealing with an expression or a pattern? --- --- Used only for the textual output of certain error messages; --- see the 'FRRDataConArg' constructor of 'FixedRuntimeRepContext'. -data ExprOrPat - = Expression - | Pattern - deriving Eq +data TypeOrConstraint + = TypeLike | ConstraintLike + deriving( Eq, Ord, Data ) -instance Outputable ExprOrPat where - ppr Expression = text "expression" - ppr Pattern = text "pattern" {- ********************************************************************* * * diff --git a/GHC/Types/CostCentre.hs b/GHC/Types/CostCentre.hs --- a/GHC/Types/CostCentre.hs +++ b/GHC/Types/CostCentre.hs @@ -1,9 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} module GHC.Types.CostCentre ( - CostCentre(..), CcName, CCFlavour(..), - -- All abstract except to friend: ParseIface.y + -- All abstract except to friend: ParseIface.y + CostCentre(..), CcName, CCFlavour, + mkCafFlavour, mkExprCCFlavour, mkDeclCCFlavour, mkHpcCCFlavour, + mkLateCCFlavour, mkCallerCCFlavour, + pprCostCentre, CostCentreStack, + pprCostCentreStack, CollectedCCs, emptyCollectedCCs, collectCC, currentCCS, dontCareCCS, isCurrentCCS, @@ -31,7 +35,6 @@ import GHC.Types.SrcLoc import GHC.Data.FastString import GHC.Types.CostCentre.State -import GHC.Utils.Panic.Plain import Data.Data @@ -64,24 +67,39 @@ type CcName = FastString +data IndexedCCFlavour + = ExprCC -- ^ Explicitly annotated expression + | DeclCC -- ^ Explicitly annotated declaration + | HpcCC -- ^ Generated by HPC for coverage + | LateCC -- ^ Annotated by the one of the prof-last* passes. + | CallerCC -- ^ Annotated by the one of the prof-last* passes. + deriving (Eq,Ord,Data,Enum) -- | The flavour of a cost centre. -- -- Index fields represent 0-based indices giving source-code ordering of -- centres with the same module, name, and flavour. -data CCFlavour = CafCC -- ^ Auto-generated top-level thunk - | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression - | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration - | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage - | LateCC !CostCentreIndex -- ^ Annotated by the one of the prof-last* passes. +data CCFlavour = CafCC -- ^ Auto-generated top-level thunk, they all go into the same bucket + | IndexedCC !IndexedCCFlavour !CostCentreIndex -- ^ Explicitly annotated expression deriving (Eq, Ord, Data) +-- Construct a CC flavour +mkCafFlavour :: CCFlavour +mkCafFlavour = CafCC +mkExprCCFlavour :: CostCentreIndex -> CCFlavour +mkExprCCFlavour idx = IndexedCC ExprCC idx +mkDeclCCFlavour :: CostCentreIndex -> CCFlavour +mkDeclCCFlavour idx = IndexedCC DeclCC idx +mkHpcCCFlavour :: CostCentreIndex -> CCFlavour +mkHpcCCFlavour idx = IndexedCC HpcCC idx +mkLateCCFlavour :: CostCentreIndex -> CCFlavour +mkLateCCFlavour idx = IndexedCC LateCC idx +mkCallerCCFlavour :: CostCentreIndex -> CCFlavour +mkCallerCCFlavour idx = IndexedCC CallerCC idx + -- | Extract the index from a flavour flavourIndex :: CCFlavour -> Int flavourIndex CafCC = 0 -flavourIndex (ExprCC x) = unCostCentreIndex x -flavourIndex (DeclCC x) = unCostCentreIndex x -flavourIndex (HpcCC x) = unCostCentreIndex x -flavourIndex (LateCC x) = unCostCentreIndex x +flavourIndex (IndexedCC _flav x) = unCostCentreIndex x instance Eq CostCentre where c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } @@ -159,9 +177,9 @@ -- Unique. -- See bug #249, tests prof001, prof002, also #2411 str | isExternalName name = occNameFS (getOccName id) - | otherwise = occNameFS (getOccName id) - `appendFS` - mkFastString ('_' : show (getUnique name)) + | otherwise = concatFS [occNameFS (getOccName id), + fsLit "_", + mkFastString (show (getUnique name))] mkAllCafsCC :: Module -> SrcSpan -> CostCentre mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } @@ -236,10 +254,14 @@ -- expression. instance Outputable CostCentreStack where - ppr CurrentCCS = text "CCCS" - ppr DontCareCCS = text "CCS_DONT_CARE" - ppr (SingletonCCS cc) = ppr cc <> text "_ccs" + ppr = pprCostCentreStack +pprCostCentreStack :: IsLine doc => CostCentreStack -> doc +pprCostCentreStack CurrentCCS = text "CCCS" +pprCostCentreStack DontCareCCS = text "CCS_DONT_CARE" +pprCostCentreStack (SingletonCCS cc) = pprCostCentre cc <> text "_ccs" +{-# SPECIALISE pprCostCentreStack :: CostCentreStack -> SDoc #-} +{-# SPECIALISE pprCostCentreStack :: CostCentreStack -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable ----------------------------------------------------------------------------- -- Printing Cost Centres @@ -256,11 +278,16 @@ -- by costCentreName. instance Outputable CostCentre where - ppr cc = getPprStyle $ \ sty -> - if codeStyle sty - then ppCostCentreLbl cc - else text (costCentreUserName cc) + ppr = pprCostCentre +pprCostCentre :: IsLine doc => CostCentre -> doc +pprCostCentre cc = docWithContext $ \ sty -> + if codeStyle (sdocStyle sty) + then ppCostCentreLbl cc + else ftext (costCentreUserNameFS cc) +{-# SPECIALISE pprCostCentre :: CostCentre -> SDoc #-} +{-# SPECIALISE pprCostCentre :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- Printing in Core pprCostCentreCore :: CostCentre -> SDoc pprCostCentreCore (AllCafsCC {cc_mod = m}) @@ -284,26 +311,35 @@ pprIdxCore idx = whenPprDebug $ ppr idx -- Printing as a C label -ppCostCentreLbl :: CostCentre -> SDoc -ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" +ppCostCentreLbl :: IsLine doc => CostCentre -> doc +ppCostCentreLbl (AllCafsCC {cc_mod = m}) = pprModule m <> text "_CAFs_cc" ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m}) - = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> + = pprModule m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> ppFlavourLblComponent f <> text "_cc" +{-# SPECIALISE ppCostCentreLbl :: CostCentre -> SDoc #-} +{-# SPECIALISE ppCostCentreLbl :: CostCentre -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- ^ Print the flavour component of a C label -ppFlavourLblComponent :: CCFlavour -> SDoc +ppFlavourLblComponent :: IsLine doc => CCFlavour -> doc ppFlavourLblComponent CafCC = text "CAF" -ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i -ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i -ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i -ppFlavourLblComponent (LateCC i) = text "LATECC" <> ppIdxLblComponent i +ppFlavourLblComponent (IndexedCC flav i) = + case flav of + ExprCC -> text "EXPR" <> ppIdxLblComponent i + DeclCC -> text "DECL" <> ppIdxLblComponent i + HpcCC -> text "HPC" <> ppIdxLblComponent i + LateCC -> text "LATECC" <> ppIdxLblComponent i + CallerCC -> text "CALLERCC" <> ppIdxLblComponent i +{-# SPECIALISE ppFlavourLblComponent :: CCFlavour -> SDoc #-} +{-# SPECIALISE ppFlavourLblComponent :: CCFlavour -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- ^ Print the flavour index component of a C label -ppIdxLblComponent :: CostCentreIndex -> SDoc +ppIdxLblComponent :: IsLine doc => CostCentreIndex -> doc ppIdxLblComponent n = case unCostCentreIndex n of 0 -> empty - n -> ppr n + n -> int n +{-# SPECIALISE ppIdxLblComponent :: CostCentreIndex -> SDoc #-} +{-# SPECIALISE ppIdxLblComponent :: CostCentreIndex -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -- This is the name to go in the user-displayed string, -- recorded in the cost centre declaration @@ -322,28 +358,18 @@ instance Binary CCFlavour where put_ bh CafCC = - putByte bh 0 - put_ bh (ExprCC i) = do - putByte bh 1 - put_ bh i - put_ bh (DeclCC i) = do - putByte bh 2 - put_ bh i - put_ bh (HpcCC i) = do - putByte bh 3 - put_ bh i - put_ bh (LateCC i) = do - putByte bh 4 - put_ bh i + putByte bh 0 + put_ bh (IndexedCC flav i) = do + putByte bh 1 + let !flav_index = fromEnum flav + put_ bh flav_index + put_ bh i get bh = do h <- getByte bh case h of 0 -> return CafCC - 1 -> ExprCC <$> get bh - 2 -> DeclCC <$> get bh - 3 -> HpcCC <$> get bh - 4 -> LateCC <$> get bh - _ -> panic "Invalid CCFlavour" + _ -> do + IndexedCC <$> (toEnum <$> get bh) <*> get bh instance Binary CostCentre where put_ bh (NormalCC aa ab ac _ad) = do diff --git a/GHC/Types/Cpr.hs b/GHC/Types/Cpr.hs --- a/GHC/Types/Cpr.hs +++ b/GHC/Types/Cpr.hs @@ -10,7 +10,8 @@ CprType (..), topCprType, botCprType, flatConCprType, lubCprType, applyCprTy, abstractCprTy, trimCprTy, UnpackConFieldsResult (..), unpackConFieldsCpr, - CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig, seqCprSig + CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig, + seqCprSig, prependArgsCprSig ) where import GHC.Prelude @@ -186,6 +187,13 @@ seqCprSig :: CprSig -> () seqCprSig (CprSig ty) = seqCprTy ty + +prependArgsCprSig :: Arity -> CprSig -> CprSig +-- ^ Add extra value args to CprSig +prependArgsCprSig n_extra cpr_sig@(CprSig (CprType arity cpr)) + | n_extra == 0 = cpr_sig + | otherwise = assertPpr (n_extra > 0) (ppr n_extra) $ + CprSig (CprType (arity + n_extra) cpr) -- | BNF: -- diff --git a/GHC/Types/Demand.hs b/GHC/Types/Demand.hs --- a/GHC/Types/Demand.hs +++ b/GHC/Types/Demand.hs @@ -2,8 +2,6 @@ {-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE PatternSynonyms #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -39,31 +37,36 @@ -- ** Other @Demand@ operations oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, lazifyDmd, peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds, - mkWorkerDemand, + mkWorkerDemand, subDemandIfEvaluated, -- ** Extracting one-shot information argOneShots, argsOneShots, saturatedByOneShots, -- ** Manipulating Boxity of a Demand unboxDeeplyDmd, + -- * Demand environments + DmdEnv, emptyDmdEnv, + keepAliveDmdEnv, reuseEnv, + -- * Divergence Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv, - -- * Demand environments - DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs, - reuseEnv, - -- * Demand types DmdType(..), dmdTypeDepth, -- ** Algebra nopDmdType, botDmdType, - lubDmdType, plusDmdType, multDmdType, discardArgDmds, + lubDmdType, plusDmdType, multDmdType, + -- *** PlusDmdArg + PlusDmdArg, mkPlusDmdArg, toPlusDmdArg, -- ** Other operations peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException, + keepAliveDmdType, -- * Demand signatures - DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, + DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, mkVanillaDmdSig, splitDmdSig, dmdSigDmdEnv, hasDemandEnvSig, - nopSig, botSig, isNopSig, isDeadEndSig, isDeadEndAppSig, trimBoxityDmdSig, + nopSig, botSig, isNopSig, isBottomingSig, isDeadEndSig, isDeadEndAppSig, + trimBoxityDmdSig, transferArgBoxityDmdSig, + -- ** Handling arity adjustments prependArgsDmdSig, etaConvertDmdSig, @@ -82,8 +85,9 @@ import GHC.Prelude -import GHC.Types.Var +import GHC.Types.Var ( Var, Id ) import GHC.Types.Var.Env +import GHC.Types.Var.Set import GHC.Types.Unique.FM import GHC.Types.Basic import GHC.Data.Maybe ( orElse ) @@ -102,9 +106,6 @@ import Data.Coerce (coerce) import Data.Function -import GHC.Utils.Trace -_ = pprTrace -- Tired of commenting out the import all the time - {- ************************************************************************ * * @@ -267,7 +268,7 @@ frequently than small records (e.g., Int). Result: Big records tend to be passed around boxed (unmodified) much more frequently than small records. -Consequnce: The larger the record, the more likely conditions (1) and (2) from +Consequence: The larger the record, the more likely conditions (1) and (2) from Note [Function body boxity and call sites] are met, in which case unboxing returned parameters leads to reboxing. @@ -376,9 +377,6 @@ -- See Note [Boxity analysis] for the lattice. lubBoxity = boxedWins -plusBoxity :: Boxity -> Boxity -> Boxity -plusBoxity = boxedWins - {- ************************************************************************ * * @@ -473,6 +471,7 @@ - Handy special cases: o 'plusCard C_10' bumps up the strictness of its argument, just like 'lubCard C_00' lazifies it, without touching upper bounds. + See also 'strictifyCard' o Similarly, 'plusCard C_0N' discards usage information (incl. absence) but leaves strictness alone. @@ -561,15 +560,22 @@ -- | Intersect with [0,1]. oneifyCard :: Card -> Card -oneifyCard C_0N = C_01 -oneifyCard C_1N = C_11 -oneifyCard c = c +oneifyCard = glbCard C_01 +-- | Intersect with [1,n]. The same as @'plusCard' 'C_10'@. +strictifyCard :: Card -> Card +strictifyCard = glbCard C_1N + -- | Denotes '∪' on 'Card'. lubCard :: Card -> Card -> Card -- See Note [Bit vector representation for Card] lubCard (Card a) (Card b) = Card (a .|. b) -- main point of the bit-vector encoding! +-- | Denotes '∩' on 'Card'. +glbCard :: Card -> Card -> Card +-- See Note [Bit vector representation for Card] +glbCard (Card a) (Card b) = Card (a .&. b) + -- | Denotes '+' on lower and upper bounds of 'Card'. plusCard :: Card -> Card -> Card -- See Note [Algebraic specification for plusCard and multCard] @@ -598,11 +604,11 @@ ************************************************************************ -} --- | A demand describes a /scaled evaluation context/, e.g. how many times --- and how deep the denoted thing is evaluated. +-- | A demand describes -- --- The "how many" component is represented by a 'Card'inality. --- The "how deep" component is represented by a 'SubDemand'. +-- * 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 @@ -610,10 +616,10 @@ -- * '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 @1C1(L)@ on its first argument: It calls (@C@) the +-- * '$' 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 @MCM(L)@ on its second argument: It evaluates +-- * '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)@ @@ -643,11 +649,11 @@ -- | Only meant to be used in the pattern synonym below! viewDmdPair :: Demand -> (Card, SubDemand) viewDmdPair BotDmd = (C_10, botSubDmd) -viewDmdPair AbsDmd = (C_00, seqSubDmd) +viewDmdPair AbsDmd = (C_00, botSubDmd) viewDmdPair (D n sd) = (n, sd) --- | @c :* sd@ is a demand that says \"evaluated @c@ times, and each time it --- was evaluated, it was at least as deep as @sd@\". +-- | @c :* sd@ is a demand that says \"evaluated @c@ times, and any trace in +-- which it is evaluated will evaluate at least as deep as @sd@\". -- -- Matching on this pattern synonym is a complete match. -- If the matched demand was 'AbsDmd', it will match as @C_00 :* seqSubDmd@. @@ -663,27 +669,18 @@ pattern (:*) :: HasDebugCallStack => Card -> SubDemand -> Demand pattern n :* sd <- (viewDmdPair -> (n, sd)) where C_10 :* sd = BotDmd & assertPpr (sd == botSubDmd) (text "B /=" <+> ppr sd) - C_00 :* sd = AbsDmd & assertPpr (sd == seqSubDmd) (text "A /=" <+> ppr sd) + C_00 :* sd = AbsDmd & assertPpr (sd == botSubDmd) (text "A /=" <+> ppr sd) n :* sd = D n sd & assertPpr (isCardNonAbs n) (ppr n $$ ppr sd) {-# COMPLETE (:*) #-} --- | A sub-demand describes an /evaluation context/, e.g. how deep the --- denoted thing is evaluated. See 'Demand' for examples. --- --- The nested 'SubDemand' @d@ of a 'Call' @Cn(d)@ is /relative/ to a single such call. --- E.g. The expression @f 1 2 + f 3 4@ puts call demand @SCS(C1(L))@ on @f@: --- @f@ is called exactly twice (@S@), each time exactly once (@1@) with an --- additional argument. +-- | A sub-demand describes an /evaluation context/ (in the sense of an +-- operational semantics), e.g. how deep the denoted thing is going to be +-- evaluated. See 'Demand' for examples. -- --- The nested 'Demand's @dn@ of a 'Prod' @P(d1,d2,...)@ apply /absolutely/: --- If @dn@ is a used once demand (cf. 'isUsedOnce'), then that means that --- the denoted sub-expression is used once in the entire evaluation context --- described by the surrounding 'Demand'. E.g., @LP(ML)@ means that the --- field of the denoted expression is used at most once, although the --- entire expression might be used many times. +-- See Note [SubDemand denotes at least one evaluation] for a more detailed +-- description of what a sub-demand means. -- --- See Note [Call demands are relative] --- and Note [Demand notation]. +-- See Note [Demand notation] for the extensively used short-hand notation. -- See also Note [Why Boxity in SubDemand and not in Demand?]. data SubDemand = Poly !Boxity !CardNonOnce @@ -696,18 +693,23 @@ -- @Poly b n@ is semantically equivalent to @Prod b [n :* Poly b n, ...] -- or @Call n (Poly Boxed n)@. 'viewCall' and 'viewProd' do these rewrites. -- - -- In Note [Demand notation]: @L === P(L,L,...)@ and @L === CL(L)@, - -- @B === P(B,B,...)@ and @B === CB(B)@, - -- @!A === !P(A,A,...)@ and @!A === !CA(A)@, + -- In Note [Demand notation]: @L === P(L,L,...)@ and @L === C(L)@, + -- @B === P(B,B,...)@ and @B === C(B)@, + -- @!A === !P(A,A,...)@ and @!A === C(A)@, -- and so on. -- -- We'll only see 'Poly' with 'C_10' (B), 'C_00' (A), 'C_0N' (L) and sometimes -- 'C_1N' (S) through 'plusSubDmd', never 'C_01' (M) or 'C_11' (1) (grep the -- source code). Hence 'CardNonOnce', which is closed under 'lub' and 'plus'. + -- + -- Why doesn't this constructor simply carry a 'Demand' instead of its fields? + -- See Note [Call SubDemand vs. evaluation Demand]. | Call !CardNonAbs !SubDemand -- ^ @Call n sd@ describes the evaluation context of @n@ function - -- applications, where every individual result is evaluated according to @sd@. - -- @sd@ is /relative/ to a single call, see Note [Call demands are relative]. + -- applications (with one argument), where the result of each call is + -- evaluated according to @sd@. + -- @sd@ describes program traces in which the denoted thing was called at all, + -- see Note [SubDemand denotes at least one evaluation]. -- That Note also explains why it doesn't make sense for @n@ to be absent, -- hence we forbid it with 'CardNonAbs'. Absent call demands can still be -- expressed with 'Poly'. @@ -780,19 +782,21 @@ -- for Arity. Otherwise, #18304 bites us. -- | A smart constructor for 'Call', applying rewrite rules along the semantic --- equality @Call n (Poly n) === Poly n@, simplifying to 'Poly' 'SubDemand's +-- equality @Call C_0N (Poly C_0N) === Poly C_0N@, simplifying to 'Poly' 'SubDemand's -- when possible. mkCall :: CardNonAbs -> SubDemand -> SubDemand -mkCall C_1N sd@(Poly Boxed C_1N) = sd +--mkCall C_1N sd@(Poly Boxed C_1N) = sd -- NO! #21085 strikes. See Note [mkCall and plusSubDmd] mkCall C_0N sd@(Poly Boxed C_0N) = sd -mkCall n cd = assertPpr (isCardNonAbs n) (ppr n $$ ppr cd) $ - Call n cd +mkCall n sd = assertPpr (isCardNonAbs n) (ppr n $$ ppr sd) $ + Call n sd -- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' subdemands as -- necessary. viewCall :: SubDemand -> Maybe (Card, SubDemand) viewCall (Call n sd) = Just (n :: Card, sd) -viewCall (Poly _ n) = Just (n :: Card, Poly Boxed n) +viewCall (Poly _ n) + | isAbs n = Just (n :: Card, botSubDmd) + | otherwise = Just (n :: Card, Poly Boxed n) viewCall _ = Nothing topDmd, absDmd, botDmd, seqDmd :: Demand @@ -808,42 +812,33 @@ unboxDeeplySubDmd call@Call{} = call -- | Sets 'Boxity' to 'Unboxed' for the 'Demand', recursing into 'Prod's. +-- Don't recurse into lazy arguments; see GHC.Core.Opt.DmdAnal +-- Note [No lazy, Unboxed demands in demand signature] unboxDeeplyDmd :: Demand -> Demand unboxDeeplyDmd AbsDmd = AbsDmd unboxDeeplyDmd BotDmd = BotDmd -unboxDeeplyDmd (D n sd) = D n (unboxDeeplySubDmd sd) +unboxDeeplyDmd dmd@(D n sd) | isStrict n = D n (unboxDeeplySubDmd sd) + | otherwise = dmd --- | Denotes '∪' on 'SubDemand'. -lubSubDmd :: SubDemand -> SubDemand -> SubDemand --- Handle botSubDmd (just an optimisation, the general case would do the same) -lubSubDmd (Poly Unboxed C_10) d2 = d2 -lubSubDmd d1 (Poly Unboxed C_10) = d1 --- Handle Prod -lubSubDmd (Prod b1 ds1) (Poly b2 n2) - | let !d = polyFieldDmd b2 n2 - = mkProd (lubBoxity b1 b2) (strictMap (lubDmd d) ds1) -lubSubDmd (Prod b1 ds1) (Prod b2 ds2) - | equalLength ds1 ds2 - = mkProd (lubBoxity b1 b2) (strictZipWith lubDmd ds1 ds2) --- Handle Call -lubSubDmd (Call n1 sd1) sd2@(Poly _ n2) - -- See Note [Call demands are relative] - | isAbs n2 = mkCall (lubCard n2 n1) sd1 - | otherwise = mkCall (lubCard n2 n1) (lubSubDmd sd1 sd2) -lubSubDmd (Call n1 d1) (Call n2 d2) - | otherwise = mkCall (lubCard n1 n2) (lubSubDmd d1 d2) --- Handle Poly. Exploit reflexivity (so we'll match the Prod or Call cases again). -lubSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (lubCard n1 n2) -lubSubDmd sd1@Poly{} sd2 = lubSubDmd sd2 sd1 --- Otherwise (Call `lub` Prod) return Top -lubSubDmd _ _ = topSubDmd --- | Denotes '∪' on 'Demand'. -lubDmd :: Demand -> Demand -> Demand -lubDmd (n1 :* sd1) (n2 :* sd2) = lubCard n1 n2 :* lubSubDmd sd1 sd2 +multDmd :: Card -> Demand -> Demand +multDmd C_11 dmd = dmd -- An optimisation +-- The following four lines make sure that we rewrite to AbsDmd and BotDmd +-- whenever the leading cardinality is absent (C_00 or C_10). +-- Otherwise it may happen that the SubDemand is not 'botSubDmd', triggering +-- the assertion in `:*`. +-- Example: `multDmd B 1L = BA`, so with an inner `seqSubDmd`. Our lattice +-- allows us to always rewrite this to proper BotDmd and we maintain the +-- invariant that this is indeed the case. +multDmd C_00 _ = AbsDmd +multDmd _ AbsDmd = AbsDmd +multDmd C_10 (D n _) = if isStrict n then BotDmd else AbsDmd +multDmd n BotDmd = if isStrict n then BotDmd else AbsDmd +-- See Note [SubDemand denotes at least one evaluation] for the strictifyCard +multDmd n (D m sd) = multCard n m :* multSubDmd (strictifyCard n) sd multSubDmd :: Card -> SubDemand -> SubDemand -multSubDmd C_11 sd = sd +multSubDmd C_11 sd = sd -- An optimisation, for when sd is a deep Prod -- The following three equations don't have an impact on Demands, only on -- Boxity. They are needed so that we don't trigger the assertions in `:*` -- when called from `multDmd`. @@ -851,46 +846,77 @@ multSubDmd C_10 (Poly _ n) = if isStrict n then botSubDmd else seqSubDmd -- Otherwise `multSubDmd B L == B /= !B` multSubDmd C_10 (Call n _) = if isStrict n then botSubDmd else seqSubDmd -- Otherwise we'd call `mkCall` with absent cardinality multSubDmd n (Poly b m) = Poly b (multCard n m) -multSubDmd n (Call n' sd) = mkCall (multCard n n') sd -- See Note [Call demands are relative] +multSubDmd n (Call n' sd) = mkCall (multCard n n') sd multSubDmd n (Prod b ds) = mkProd b (strictMap (multDmd n) ds) -multDmd :: Card -> Demand -> Demand --- The first two lines compute the same result as the last line, but won't --- trigger the assertion in `:*` for input like `multDmd B 1L`, which would call --- `B :* A`. We want to return `B` in these cases. -multDmd C_10 (n :* _) = if isStrict n then BotDmd else AbsDmd -multDmd n (C_10 :* _) = if isStrict n then BotDmd else AbsDmd -multDmd n (m :* sd) = multCard n m :* multSubDmd n sd +lazifyIfStrict :: Card -> SubDemand -> SubDemand +lazifyIfStrict n sd = multSubDmd (glbCard C_01 n) sd --- | Denotes '+' on 'SubDemand'. +-- | Denotes '∪' on 'Demand'. +lubDmd :: Demand -> Demand -> Demand +lubDmd BotDmd dmd2 = dmd2 +lubDmd dmd1 BotDmd = dmd1 +lubDmd (n1 :* sd1) (n2 :* sd2) = -- pprTraceWith "lubDmd" (\it -> ppr (n1:*sd1) $$ ppr (n2:*sd2) $$ ppr it) $ + lubCard n1 n2 :* lubSubDmd sd1 sd2 + +lubSubDmd :: SubDemand -> SubDemand -> SubDemand +-- Shortcuts for neutral and absorbing elements. +-- Below we assume that Boxed always wins. +lubSubDmd (Poly Unboxed C_10) sd = sd +lubSubDmd sd (Poly Unboxed C_10) = sd +lubSubDmd sd@(Poly Boxed C_0N) _ = sd +lubSubDmd _ sd@(Poly Boxed C_0N) = sd +-- Handle Prod +lubSubDmd (Prod b1 ds1) (Poly b2 n2) + | let !d = polyFieldDmd b2 n2 + = mkProd (lubBoxity b1 b2) (strictMap (lubDmd d) ds1) +lubSubDmd (Prod b1 ds1) (Prod b2 ds2) + | equalLength ds1 ds2 + = mkProd (lubBoxity b1 b2) (strictZipWith lubDmd ds1 ds2) +-- Handle Call +lubSubDmd (Call n1 sd1) (viewCall -> Just (n2, sd2)) = + mkCall (lubCard n1 n2) (lubSubDmd sd1 sd2) +-- Handle Poly +lubSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (lubCard n1 n2) +-- Other Poly case by commutativity +lubSubDmd sd1@Poly{} sd2 = lubSubDmd sd2 sd1 +-- Otherwise (Call `lub` Prod) return Top +lubSubDmd _ _ = topSubDmd + +-- | Denotes '+' on 'Demand'. +plusDmd :: Demand -> Demand -> Demand +plusDmd AbsDmd dmd2 = dmd2 +plusDmd dmd1 AbsDmd = dmd1 +plusDmd (n1 :* sd1) (n2 :* sd2) = -- pprTraceWith "plusDmd" (\it -> ppr (n1:*sd1) $$ ppr (n2:*sd2) $$ ppr it) $ + -- Why lazify? See Note [SubDemand denotes at least one evaluation] + -- and also Note [Unrealised opportunity in plusDmd] which applies when both + -- n1 and n2 are lazy already + plusCard n1 n2 :* plusSubDmd (lazifyIfStrict n1 sd1) (lazifyIfStrict n2 sd2) + plusSubDmd :: SubDemand -> SubDemand -> SubDemand --- Handle seqSubDmd (just an optimisation, the general case would do the same) -plusSubDmd (Poly Unboxed C_00) d2 = d2 -plusSubDmd d1 (Poly Unboxed C_00) = d1 +-- Shortcuts for neutral and absorbing elements. +-- Below we assume that Boxed always wins. +plusSubDmd (Poly Unboxed C_00) sd = sd +plusSubDmd sd (Poly Unboxed C_00) = sd +plusSubDmd sd@(Poly Boxed C_1N) _ = sd +plusSubDmd _ sd@(Poly Boxed C_1N) = sd -- Handle Prod plusSubDmd (Prod b1 ds1) (Poly b2 n2) | let !d = polyFieldDmd b2 n2 - = mkProd (plusBoxity b1 b2) (strictMap (plusDmd d) ds1) + = mkProd (lubBoxity b1 b2) (strictMap (plusDmd d) ds1) plusSubDmd (Prod b1 ds1) (Prod b2 ds2) | equalLength ds1 ds2 - = mkProd (plusBoxity b1 b2) (strictZipWith plusDmd ds1 ds2) + = mkProd (lubBoxity b1 b2) (strictZipWith plusDmd ds1 ds2) -- Handle Call -plusSubDmd (Call n1 sd1) sd2@(Poly _ n2) - -- See Note [Call demands are relative] - | isAbs n2 = mkCall (plusCard n2 n1) sd1 - | otherwise = mkCall (plusCard n2 n1) (lubSubDmd sd1 sd2) -plusSubDmd (Call n1 sd1) (Call n2 sd2) - | otherwise = mkCall (plusCard n1 n2) (lubSubDmd sd1 sd2) --- Handle Poly. Exploit reflexivity (so we'll match the Prod or Call cases again). -plusSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (plusBoxity b1 b2) (plusCard n1 n2) +plusSubDmd (Call n1 sd1) (viewCall -> Just (n2, sd2)) = + mkCall (plusCard n1 n2) (lubSubDmd sd1 sd2) +-- Handle Poly +plusSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (plusCard n1 n2) +-- Other Poly case by commutativity plusSubDmd sd1@Poly{} sd2 = plusSubDmd sd2 sd1 --- Otherwise (Call `lub` Prod) return Top +-- Otherwise (Call `plus` Prod) return Top plusSubDmd _ _ = topSubDmd --- | Denotes '+' on 'Demand'. -plusDmd :: Demand -> Demand -> Demand -plusDmd (n1 :* sd1) (n2 :* sd2) = plusCard n1 n2 :* plusSubDmd sd1 sd2 - -- | Used to suppress pretty-printing of an uninformative demand isTopDmd :: Demand -> Bool isTopDmd dmd = dmd == topDmd @@ -927,27 +953,27 @@ -- is_plus_idem_sub_dmd sd = plusSubDmd sd sd == sd is_plus_idem_sub_dmd (Poly _ n) = assert (isCardNonOnce n) True is_plus_idem_sub_dmd (Prod _ ds) = all is_plus_idem_dmd ds - is_plus_idem_sub_dmd (Call n _) = is_plus_idem_card n -- See Note [Call demands are relative] + is_plus_idem_sub_dmd (Call n _) = is_plus_idem_card n evalDmd :: Demand evalDmd = C_1N :* topSubDmd --- | First argument of 'GHC.Exts.maskAsyncExceptions#': @1C1(L)@. +-- | First argument of 'GHC.Exts.maskAsyncExceptions#': @1C(1,L)@. -- Called exactly once. strictOnceApply1Dmd :: Demand strictOnceApply1Dmd = C_11 :* mkCall C_11 topSubDmd --- | First argument of 'GHC.Exts.atomically#': @SCS(L)@. +-- | First argument of 'GHC.Exts.atomically#': @SC(S,L)@. -- Called at least once, possibly many times. strictManyApply1Dmd :: Demand strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd --- | First argument of catch#: @MCM(L)@. +-- | First argument of catch#: @MC(M,L)@. -- Evaluates its arg lazily, but then applies it exactly once to one argument. lazyApply1Dmd :: Demand lazyApply1Dmd = C_01 :* mkCall C_01 topSubDmd --- | Second argument of catch#: @MCM(C1(L))@. +-- | Second argument of catch#: @MC(M,C(1,L))@. -- Calls its arg lazily, but then applies it exactly once to an additional argument. lazyApply2Dmd :: Demand lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd) @@ -960,9 +986,7 @@ -- | Make a 'Demand' evaluated at-least-once (e.g. strict). strictifyDmd :: Demand -> Demand -strictifyDmd AbsDmd = seqDmd -strictifyDmd BotDmd = BotDmd -strictifyDmd (n :* sd) = plusCard C_10 n :* sd +strictifyDmd = plusDmd seqDmd -- | If the argument is a used non-newtype dictionary, give it strict demand. -- Also split the product type & demand and recur in order to similarly @@ -987,23 +1011,15 @@ = Nothing strictifyDictDmd _ dmd = dmd --- | Make a 'Demand' lazy, setting all lower bounds (outside 'Call's) to 0. +-- | Make a 'Demand' lazy. lazifyDmd :: Demand -> Demand -lazifyDmd AbsDmd = AbsDmd -lazifyDmd BotDmd = AbsDmd -lazifyDmd (n :* sd) = multCard C_01 n :* lazifySubDmd sd - --- | Make a 'SubDemand' lazy, setting all lower bounds (outside 'Call's) to 0. -lazifySubDmd :: SubDemand -> SubDemand -lazifySubDmd (Poly b n) = Poly b (multCard C_01 n) -lazifySubDmd (Prod b sd) = mkProd b (strictMap lazifyDmd sd) -lazifySubDmd (Call n sd) = mkCall (lubCard C_01 n) sd +lazifyDmd = multDmd C_01 --- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C1(d)@. +-- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C(1,d)@. mkCalledOnceDmd :: SubDemand -> SubDemand mkCalledOnceDmd sd = mkCall C_11 sd --- | @mkCalledOnceDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s. +-- | @mkCalledOnceDmds n d@ returns @C(1,C1...C(1,d))@ where there are @n@ @C1@'s. mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity @@ -1024,15 +1040,21 @@ go _ _ _ = (topCard, topSubDmd) {-# INLINE peelManyCalls #-} -- so that the pair cancels away in a `fst _` context +-- | 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. +subDemandIfEvaluated :: Demand -> SubDemand +subDemandIfEvaluated (_ :* sd) = sd + -- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap mkWorkerDemand :: Int -> Demand mkWorkerDemand n = C_01 :* go n where go 0 = topSubDmd - go n = Call C_01 $ go (n-1) + go n = mkCall C_01 $ go (n-1) argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]] -- ^ See Note [Computing one-shot info] -argsOneShots (DmdSig (DmdType _ arg_ds)) n_val_args +argsOneShots (DmdSig (DmdType _ arg_ds _)) n_val_args | unsaturated_call = [] | otherwise = go arg_ds where @@ -1051,7 +1073,7 @@ argOneShots AbsDmd = [] -- This defn conflicts with 'saturatedByOneShots', argOneShots BotDmd = [] -- according to which we should return -- @repeat OneShotLam@ here... -argOneShots (_ :* sd) = go sd -- See Note [Call demands are relative] +argOneShots (_ :* sd) = go sd where go (Call n sd) | isUsedOnce n = OneShotLam : go sd @@ -1059,9 +1081,9 @@ go _ = [] -- | --- @saturatedByOneShots n CM(CM(...)) = True@ +-- @saturatedByOneShots n C(M,C(M,...)) = True@ -- <=> --- There are at least n nested CM(..) calls. +-- There are at least n nested C(M,..) calls. -- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap saturatedByOneShots :: Int -> Demand -> Bool saturatedByOneShots _ AbsDmd = True @@ -1088,54 +1110,223 @@ In #7319 we get T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] -Note [Call demands are relative] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The expression @if b then 0 else f 1 2 + f 3 4@ uses @f@ according to the demand -@LCL(C1(P(L)))@, meaning +Note [SubDemand denotes at least one evaluation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a demand `n :* sd` on a binding `let x = e in `. +(Similarly, a call sub-demand `Cn(sd)` on a lambda `\_. e`). +While `n` describes how *often* `x` had been evaluated in , +the sub-demand `sd` describes how *deep* `e` has been evaluated, under the +following - "f is called multiple times or not at all (CL), but each time it - is called, it's called with *exactly one* (C1) more argument. - Whenever it is called with two arguments, we have no info on how often - the field of the product result is used (L)." + PREMISE: *for all program traces where `x` had been evaluated at all* -So the 'SubDemand' nested in a 'Call' demand is relative to exactly one call. -And that extends to the information we have how its results are used in each -call site. Consider (#18903) +That is, `sd` disregards all program traces where `x` had not been evaluated, +because it can't describe the depth of an evaluation that never happened. +NB: The Premise only makes a difference for lower bounds/strictness. +Upper bounds/usage are unaffected by adding or leaving out evaluations that +never happen. - h :: Int -> Int - h m = - let g :: Int -> (Int,Int) - g 1 = (m, 0) - g n = (2 * n, 2 `div` n) - {-# NOINLINE g #-} - in case m of - 1 -> 0 - 2 -> snd (g m) - _ -> uncurry (+) (g m) +The Premise comes into play when we have lazy Demands. For example, if `x` was +demanded with `LP(SL,A)`, so perhaps the full expression was + let x = (e1, e2) in (x `seq` fun y `seq` case x of (a,b) -> a, True) +then `x` will be evaluated lazily, but in any trace in which `x` is evaluated, +the pair in its RHS will ultimately be evaluated deeply with sub-demand +`P(SL,A)`. That means that `e1` is ultimately evaluated strictly, even though +evaluation of the field does not directly follow the eval of `x` due to the +intermittent call `fun y`. -We want to give @g@ the demand @MCM(P(MP(L),1P(L)))@, so we see that in each call -site of @g@, we are strict in the second component of the returned pair. +How does the additional strictness help? The long version is the list of +examples at the end of this Note (as procured in #21081 and #18903). +The short version is -This relative cardinality leads to an otherwise unexpected call to 'lubSubDmd' -in 'plusSubDmd', but if you do the math it's just the right thing. + * We get to take advantage of call-by-value/let-to-case in more situations, + as for e1 above. See example "More let-to-case" below. + * Note [Eta reduction based on evaluation context] applies in more situations. + See example "More eta reduction" below. + * We get to unbox more results, see example "More CPR" below. -There's one more subtlety: Since the nested demand is relative to exactly one -call, in the case where we have *at most zero calls* (e.g. CA(...)), the premise -is hurt and we can assume that the nested demand is 'botSubDmd'. That ensures -that @g@ above actually gets the @1P(L)@ demand on its second pair component, -rather than the lazy @MP(L)@ if we 'lub'bed with an absent demand. +It seems like we don't give up anything in return. Indeed that is the case: + * If we dropped the Premise, then a lazy `n` in `nP(m..)` would always force + `m` to be lazy, too. That is quite redundant! It seems wasteful not to use + the lower bound of `m` for something more useful. So indeed we give up on + nothing in return for some nice wins. + * Even if `n` is absent (so the Premise does hold for no trace whatsoever), + it's pretty easy to describe how `e` was evaluated. Answer: 'botSubDmd'. + We use it when expanding 'Absent' and 'Bottom' demands in 'viewDmdPair' as + well as when expanding absent 'Poly's to 'Call' sub-demands in 'viewCall'. + +Of course, we now have to maintain the Premise when we unpack and rebuild +Demands. For strict demands, we know that the Premise indeed always holds for +any program trace abstracted over, whereas we have to be careful for lazy +demands. + +In particular, when doing `plusDmd` we have to *lazify* the nested SubDemand +if the outer cardinality is lazy. E.g., + LP(SL) + SP(L) = (L+S)P((M*SL)+L) = SP(L+L) = SP(L) +Multiplying with `M`/`C_01` is the "lazify" part here and is implemented in +`lazifyIfStrict`. Example proving that point: + d2 :: + d2 x y = y `seq` (case x of (a,b) -> a, True) + -- What is the demand on x in (d2 x x)? NOT SP(SL)!! + +We used to apply the same reasoning to Call SubDemands `Cn(sd)` in `plusSubDmd`, +but that led to #21717, because different calls return different heap objects. +See Note [Call SubDemand vs. evaluation Demand]. + +There are a couple more examples that improve in T21081. +Here is a selection of those examples demonstrating the usefulness of The +Premise: + + * "More let-to-case" (from testcase T21081): + ```hs + f :: (Bool, Bool) -> (Bool, Bool) + f pr = (case pr of (a,b) -> a /= b, True) + g :: Int -> (Bool, Bool) + g x = let y = let z = odd x in (z,z) in f y + ``` + Although `f` is lazy in `pr`, we could case-bind `z` because it is always + evaluated when `y` is evaluated. So we give `pr` demand `LP(SL,SL)` + (most likely with better upper bounds/usage) and demand analysis then + infers a strict demand for `z`. + + * "More eta reduction" (from testcase T21081): + ```hs + myfoldl :: (a -> b -> a) -> a -> [b] -> a + myfoldl f z [] = z + myfoldl f !z (x:xs) = myfoldl (\a b -> f a b) (f z x) xs + ``` + Here, we can give `f` a demand of `LC(S,C(1,L))` (instead of the lazier + `LC(L,C(1,L))`) which says "Whenever `f` is evaluated (lazily), it is also + called with two arguments". + And Note [Eta reduction based on evaluation context] means we can rewrite + `\a b -> f a b` to `f` in the call site of `myfoldl`. Nice! + + * "More CPR" (from testcase T18903): + ```hs + h :: Int -> Int + h m = + let g :: Int -> (Int,Int) + g 1 = (m, 0) + g n = (2 * n, 2 `div` n) + {-# NOINLINE g #-} + in case m of + 1 -> 0 + 2 -> snd (g m) + _ -> uncurry (+) (g m) + ``` + We want to give `g` the demand `MC(1,P(MP(L),1P(L)))`, so we see that in each + call site of `g`, we are strict in the second component of the returned + pair. That in turn means that Nested CPR can unbox the result of the + division even though it might throw. + +Note [Unrealised opportunity in plusDmd] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall the lazification of SubDemands happening in `plusDmd` as described in +Note [SubDemand denotes at least one evaluation]. + +We *could* do better when both Demands are lazy already. Example + (fun 1, fun 2) +Both args put Demand SC(S,L) on `fun`. The lazy pair arg context lazifies +this to LC(S,L), and it would be reasonable to report this Demand on `fun` for +the entire pair expression; after all, `fun` is called whenever it is evaluated. +But our definition of `plusDmd` will compute + LC(S,L) + LC(S,L) = (L+L)(M*C(S,L) + M*C(S,L)) = L(C(L,L)) = L +Which is clearly less precise. +Doing better here could mean to `lub` when both demands are lazy, e.g., + LC(S,L) + LC(S,L) = (L+L)(C(S,L) ⊔ C(S,L)) = L(C(S,L)) +Indeed that's what we did at one point between 9.4 and 9.6 after !7599, but it +means that we need a function `lubPlusSubDmd` that lubs on lower bounds but +plus'es upper bounds, implying maintenance challenges and complicated +explanations. + +Plus, NoFib says that this special case doesn't bring all that much +(geom. mean +0.0% counted instructions), so we don't bother anymore. + +Note [Call SubDemand vs. evaluation Demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Although both evaluation Demands and Call SubDemands carry a (Card,SubDemand) +pair, their interpretation is quite different. Example: + + f x = fst x * snd x + -- f :: , because 1P(1L,A)+1P(A,1L) = SP(1L,1L) + g x = fst (x 1) * snd (x 2) + -- g :: , because 1C(1,P(1L,A))+1C(1,P(A,1L)) = SC(S,P(ML,ML)) + +The point about this example is that both demands have P(A,1L)/P(1L,A) as +sub-expressions, but when these sub-demands occur + + 1. under an evaluation demand, we combine with `plusSubDmd` + 2. whereas under a Call sub-demand, we combine with `lubSubDmd` + +And thus (1) yields a stricter demand on the pair components than (2). + +In #21717 we saw that we really need lub in (2), because otherwise we make an +unsound prediction in `g (\n -> if n == 1 then (1,1) else (bot,2))`; we'd say +that the `bot` expression is always evaluated, when it clearly is not. +Operationally, every call to `g` gives back a potentially distinct, +heap-allocated pair with potentially different contents, and we must `lubSubDmd` +over all such calls to approximate how any of those pairs might be used. + +That is in stark contrast to f's argument `x`: Operationally, every eval of +`x` must yield the same pair and `f` evaluates both components of that pair. +The theorem "every eval of `x` returns the same heap object" is a very strong +MUST-alias property and we capitalise on that by using `plusSubDmd` in (1). + +And indeed we *must* use `plusSubDmd` in (1) for sound upper bounds in an +analysis that assumes call-by-need (as opposed to the weaker call-by-name) for +let bindings. Consider + + h x = fst x * fst x + -- h :: + +And the expression `let a=1; p=(a,a)} in h p`. Here, *although* the RHS of `p` +is only evaluated once under call-by-need, `a` is still evaluated twice. +If we had used `lubSubDmd`, we'd see SP(1L,A) and the 1L unsoundly says "exactly +once". + +If the analysis had assumed call-by-name, it would be sound to say "a is used +once in p": p is used multiple times and hence so would a, as if p was a +function. So using `plusSubDmd` does not only yield better strictness, it is +also "holding up the other end of the bargain" of the call-by-need assumption +for upper bounds. + +(To SG's knowledge, the distinction between call-by-name and call-by-need does +not matter for strictness analysis/lower bounds, thus it would be sound to use +`lubSubDmd` all the time there.) + +Note [mkCall and plusSubDmd] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never rewrite a strict, non-absent Call sub-demand like C(S,S) to a +polymorphic sub-demand like S, otherwise #21085 strikes. Consider the +following inequality (would also for M and 1 instead of L and S, but we forbid +such Polys): + + L+S = S = C(S,S) < C(S,L) = C(L,L)+C(S,S) + +Note that L=C(L,L). If we also had S=C(S,S), we'd be in trouble: Now +`plusSubDmd` would no longer maintain the equality relation on sub-demands, +much less monotonicity. Bad! + +Clearly, `n <= Cn(n)` is unproblematic, as is `n >= Cn(n)` for any `n` +except 1 and S. But `C(S,S) >= S` would mean trouble, because then we'd get +the problematic `C(S,S) = S`. We have just established that `S < C(S,S)`! +As such, the rewrite C(S,S) to S is anti-monotone and we forbid it, first +and foremost in `mkCall` (which is the only place that rewrites Cn(n) to n). + +Crisis and #21085 averted! + Note [Computing one-shot info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a call f (\pqr. e1) (\xyz. e2) e3 where f has usage signature - + Then argsOneShots returns a [[OneShotInfo]] of [[OneShot,NoOneShotInfo,OneShot], [OneShot]] The occurrence analyser propagates this one-shot infor to the binders \pqr and \xyz; -see Note [Use one-shot information] in "GHC.Core.Opt.OccurAnal". +see Note [Sources of one-shot information] in GHC.Core.Opt.OccurAnal. Note [Boxity in Poly] ~~~~~~~~~~~~~~~~~~~~~ @@ -1181,7 +1372,7 @@ But then we regressed in T7837 (grep #19871 for boring specifics), which needed to transfer an ambient unboxed *demand* on a dictionary selector to its argument -dictionary, via a 'Call' sub-demand `C1(sd)`, as +dictionary, via a 'Call' sub-demand `C(1,sd)`, as Note [Demand transformer for a dictionary selector] explains. Annoyingly, the boxity info has to be stored in the *sub-demand* `sd`! There's no demand to store the boxity in. So we bit the bullet and now we store Boxity in @@ -1275,7 +1466,7 @@ -- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2 -- (See Note [Default demand on free variables and arguments] for why) --- | See Note [Asymmetry of plusDmdType], which concludes that 'plusDivergence' +-- | See Note [Asymmetry of 'plus*'], which concludes that 'plusDivergence' -- needs to be symmetric. -- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv@. -- But that regresses in too many places (every infinite loop, basically) to be @@ -1486,7 +1677,7 @@ catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this") Any analysis that assumes otherwise will be broken in some way or another -(beyond `-fno-pendantic-bottoms`). +(beyond `-fno-pedantic-bottoms`). But then #13380 and #17676 suggest (in Mar 20) that we need to re-introduce a subtly different variant of `ThrowsExn` (which we call `ExnOrDiv` now) that is @@ -1546,131 +1737,112 @@ -} -- 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 --- ('de_fvs') --- * Saying whether or not evaluation would surely diverge ('de_div') --- --- See Note [Demand env Equality]. -data DmdEnv = DE { de_fvs :: !(VarEnv Demand), de_div :: !Divergence } - -instance Eq DmdEnv where - DE fv1 div1 == DE fv2 div2 - = div1 == div2 && canonicalise div1 fv1 == canonicalise div2 fv2 - where - canonicalise div fv = filterUFM (/= defaultFvDmd div) fv - -mkEmptyDmdEnv :: Divergence -> DmdEnv -mkEmptyDmdEnv div = DE emptyVarEnv div - --- | Build a potentially terminating 'DmdEnv' from a finite map that says what --- has been evaluated so far -mkTermDmdEnv :: VarEnv Demand -> DmdEnv -mkTermDmdEnv fvs = DE fvs topDiv - -nopDmdEnv :: DmdEnv -nopDmdEnv = mkEmptyDmdEnv topDiv - -botDmdEnv :: DmdEnv -botDmdEnv = mkEmptyDmdEnv botDiv - -exnDmdEnv :: DmdEnv -exnDmdEnv = mkEmptyDmdEnv exnDiv - -lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv -lubDmdEnv (DE fv1 d1) (DE fv2 d2) = DE lub_fv lub_div - where - -- See Note [Demand env Equality] - lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2) - lub_div = lubDivergence d1 d2 - -addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv -addVarDmdEnv env@(DE fvs div) id dmd - = DE (extendVarEnv fvs id (dmd `plusDmd` lookupDmdEnv env id)) div - -plusDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv -plusDmdEnv (DE fv1 d1) (DE fv2 d2) - -- In contrast to Note [Asymmetry of plusDmdType], this function is symmetric. - | isEmptyVarEnv fv2, defaultFvDmd d2 == absDmd - = DE fv1 (d1 `plusDivergence` d2) -- a very common case that is much more efficient - | isEmptyVarEnv fv1, defaultFvDmd d1 == absDmd - = DE fv2 (d1 `plusDivergence` d2) -- another very common case that is much more efficient - | otherwise - = DE (plusVarEnv_CD plusDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)) - (d1 `plusDivergence` d2) +type DmdEnv = VarEnv Demand --- | 'DmdEnv' is a monoid via 'plusDmdEnv' and 'nopDmdEnv'; this is its 'msum' -plusDmdEnvs :: [DmdEnv] -> DmdEnv -plusDmdEnvs [] = nopDmdEnv -plusDmdEnvs pdas = foldl1' plusDmdEnv pdas +emptyDmdEnv :: DmdEnv +emptyDmdEnv = emptyVarEnv multDmdEnv :: Card -> DmdEnv -> DmdEnv -multDmdEnv C_11 env = env -multDmdEnv C_00 _ = nopDmdEnv -multDmdEnv n (DE fvs div) = DE (mapVarEnv (multDmd n) fvs) (multDivergence n div) +multDmdEnv C_11 env = env +multDmdEnv C_00 _ = emptyDmdEnv +multDmdEnv n env = mapVarEnv (multDmd n) env reuseEnv :: DmdEnv -> DmdEnv reuseEnv = multDmdEnv C_1N -lookupDmdEnv :: DmdEnv -> Id -> Demand --- See Note [Default demand on free variables and arguments] -lookupDmdEnv (DE fv div) id = lookupVarEnv fv id `orElse` defaultFvDmd div +-- | @keepAliveDmdType dt vs@ makes sure that the Ids in @vs@ have +-- /some/ usage in the returned demand types -- they are not Absent. +-- See Note [Absence analysis for stable unfoldings and RULES] +-- in "GHC.Core.Opt.DmdAnal". +keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv +keepAliveDmdEnv env vs + = nonDetStrictFoldVarSet add env vs + where + add :: Id -> DmdEnv -> DmdEnv + add v env = extendVarEnv_C add_dmd env v topDmd -delDmdEnv :: DmdEnv -> Id -> DmdEnv -delDmdEnv (DE fv div) id = DE (fv `delVarEnv` id) div + add_dmd :: Demand -> Demand -> Demand + -- If the existing usage is Absent, make it used + -- Otherwise leave it alone + add_dmd dmd _ | isAbsDmd dmd = topDmd + | otherwise = dmd -- | Characterises how an expression -- --- * Evaluates its free variables ('dt_env') including divergence info +-- * Evaluates its free variables ('dt_env') -- * Evaluates its arguments ('dt_args') +-- * Diverges on every code path or not ('dt_div') -- +-- Equality is defined modulo 'defaultFvDmd's in 'dt_env'. +-- See Note [Demand type Equality]. data DmdType = DmdType - { dt_env :: !DmdEnv -- ^ Demands on free variables. - -- See Note [Demand type Divergence] + { dt_env :: !DmdEnv -- ^ Demand on explicitly-mentioned free variables , dt_args :: ![Demand] -- ^ Demand on arguments + , dt_div :: !Divergence -- ^ Whether evaluation diverges. + -- See Note [Demand type Divergence] } --- | See Note [Demand env Equality]. +-- | See Note [Demand type Equality]. instance Eq DmdType where - DmdType env1 ds1 == DmdType env2 ds2 - = ds1 == ds2 -- cheap checks first - && env1 == env2 + (==) (DmdType fv1 ds1 div1) + (DmdType fv2 ds2 div2) = div1 == div2 && ds1 == ds2 -- cheap checks first + && canonicalise div1 fv1 == canonicalise div2 fv2 + where + canonicalise div fv = filterUFM (/= defaultFvDmd div) fv -- | Compute the least upper bound of two 'DmdType's elicited /by the same -- incoming demand/! lubDmdType :: DmdType -> DmdType -> DmdType -lubDmdType d1 d2 = DmdType lub_fv lub_ds +lubDmdType d1 d2 + = DmdType lub_fv lub_ds lub_div where n = max (dmdTypeDepth d1) (dmdTypeDepth d2) - (DmdType fv1 ds1) = etaExpandDmdType n d1 - (DmdType fv2 ds2) = etaExpandDmdType n d2 + (DmdType fv1 ds1 r1) = etaExpandDmdType n d1 + (DmdType fv2 ds2 r2) = etaExpandDmdType n d2 + + -- See Note [Demand type Equality] + lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2) lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 - lub_fv = lubDmdEnv fv1 fv2 + lub_div = lubDivergence r1 r2 -discardArgDmds :: DmdType -> DmdEnv -discardArgDmds (DmdType fv _) = fv +type PlusDmdArg = (DmdEnv, Divergence) -plusDmdType :: DmdType -> DmdEnv -> DmdType -plusDmdType (DmdType fv ds) fv' - -- See Note [Asymmetry of plusDmdType] - -- 'DmdEnv' forms a (monoidal) action on 'DmdType' via this operation. - = DmdType (plusDmdEnv fv fv') ds +mkPlusDmdArg :: DmdEnv -> PlusDmdArg +mkPlusDmdArg env = (env, topDiv) +toPlusDmdArg :: DmdType -> PlusDmdArg +toPlusDmdArg (DmdType fv _ r) = (fv, r) + +plusDmdType :: DmdType -> PlusDmdArg -> DmdType +plusDmdType (DmdType fv1 ds1 r1) (fv2, t2) + -- See Note [Asymmetry of 'plus*'] + -- 'plus' takes the argument/result info from its *first* arg, + -- using its second arg just for its free-var info. + | isEmptyVarEnv fv2, defaultFvDmd t2 == absDmd + = DmdType fv1 ds1 (r1 `plusDivergence` t2) -- a very common case that is much more efficient + | otherwise + = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2)) + ds1 + (r1 `plusDivergence` t2) + botDmdType :: DmdType -botDmdType = DmdType botDmdEnv [] +botDmdType = DmdType emptyDmdEnv [] botDiv -- | The demand type of doing nothing (lazy, absent, no Divergence -- information). Note that it is ''not'' the top of the lattice (which would be -- "may use everything"), so it is (no longer) called topDmdType. nopDmdType :: DmdType -nopDmdType = DmdType nopDmdEnv [] +nopDmdType = DmdType emptyDmdEnv [] topDiv +isNopDmdType :: DmdType -> Bool +isNopDmdType (DmdType env args div) + = div == topDiv && null args && isEmptyVarEnv env + -- | The demand type of an unspecified expression that is guaranteed to -- throw a (precise or imprecise) exception or diverge. exnDmdType :: DmdType -exnDmdType = DmdType exnDmdEnv [] +exnDmdType = DmdType emptyDmdEnv [] exnDiv dmdTypeDepth :: DmdType -> Arity dmdTypeDepth = length . dt_args @@ -1679,7 +1851,7 @@ -- expansion, where n must not be lower than the demand types depth. -- It appends the argument list with the correct 'defaultArgDmd'. etaExpandDmdType :: Arity -> DmdType -> DmdType -etaExpandDmdType n d@DmdType{dt_args = ds, dt_env = env} +etaExpandDmdType n d@DmdType{dt_args = ds, dt_div = div} | n == depth = d | n > depth = d{dt_args = inc_ds} | otherwise = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d) @@ -1691,7 +1863,7 @@ -- * Divergence is still valid: -- - A dead end after 2 arguments stays a dead end after 3 arguments -- - The remaining case is Dunno, which is already topDiv - inc_ds = take n (ds ++ repeat (defaultArgDmd (de_div env))) + inc_ds = take n (ds ++ repeat (defaultArgDmd div)) -- | A conservative approximation for a given 'DmdType' in case of an arity -- decrease. Currently, it's just nopDmdType. @@ -1703,27 +1875,30 @@ -- We already have a suitable demand on all -- free vars, so no need to add more! splitDmdTy ty@DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args}) -splitDmdTy ty@DmdType{dt_env=env} = (defaultArgDmd (de_div env), ty) +splitDmdTy ty@DmdType{dt_div=div} = (defaultArgDmd div, ty) multDmdType :: Card -> DmdType -> DmdType -multDmdType n (DmdType fv args) +multDmdType n (DmdType fv args res_ty) = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $ DmdType (multDmdEnv n fv) (map (multDmd n) args) + (multDivergence n res_ty) peelFV :: DmdType -> Var -> (DmdType, Demand) -peelFV (DmdType fv ds) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) - (DmdType fv' ds, dmd) +peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) + (DmdType fv' ds res, dmd) where -- Force these arguments so that old `Env` is not retained. - !fv' = fv `delDmdEnv` id - !dmd = lookupDmdEnv fv id + !fv' = fv `delVarEnv` id + -- See Note [Default demand on free variables and arguments] + !dmd = lookupVarEnv fv id `orElse` defaultFvDmd res addDemand :: Demand -> DmdType -> DmdType -addDemand dmd (DmdType fv ds) = DmdType fv (dmd:ds) +addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res findIdDemand :: DmdType -> Var -> Demand -findIdDemand (DmdType fv _) id = lookupDmdEnv fv id +findIdDemand (DmdType fv _ res) id + = lookupVarEnv fv id `orElse` defaultFvDmd res -- | When e is evaluated after executing an IO action that may throw a precise -- exception, we act as if there is an additional control flow path that is @@ -1739,6 +1914,11 @@ deferAfterPreciseException :: DmdType -> DmdType deferAfterPreciseException = lubDmdType exnDmdType +-- | See 'keepAliveDmdEnv'. +keepAliveDmdType :: DmdType -> VarSet -> DmdType +keepAliveDmdType (DmdType fvs ds res) vars = + DmdType (fvs `keepAliveDmdEnv` vars) ds res + {- Note [deferAfterPreciseException] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The big picture is in Note [Precise exceptions and strictness analysis] @@ -1764,9 +1944,9 @@ (# s', r) -> f x which uses `x` *boxed*. If we `lub`bed it with `(DmdType emptyDmdEnv [] exnDiv)` -we'd get an *unboxed* demand on `x` (because we let Unboxed win), which led to -ticket #20746. -Nowadays with `lubBoxity = boxedWins` we don't need the complicated definition. +we'd get an *unboxed* demand on `x` (because we let Unboxed win), +which led to #20746. Nowadays with `lubBoxity = boxedWins` we don't need +the complicated definition. Note [Demand type Divergence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1780,39 +1960,46 @@ this has a strictness signature of <1L><1L>b meaning that we don't know what happens when we call err in weaker contexts than -C1(C1(L)), like @err `seq` ()@ (1A) and @err 1 `seq` ()@ (CS(A)). We +C(1,C(1,L)), like @err `seq` ()@ (1A) and @err 1 `seq` ()@ (C(S,A)). We may not unleash the botDiv, hence assume topDiv. Of course, in -@err 1 2 `seq` ()@ the incoming demand CS(CS(A)) is strong enough and we see +@err 1 2 `seq` ()@ the incoming demand C(S,C(S,A)) is strong enough and we see that the expression diverges. Now consider a function f g = g 1 2 -with signature , and the expression +with signature , and the expression f err `seq` () -now f puts a strictness demand of C1(C1(L)) onto its argument, which is unleashed +now f puts a strictness demand of C(1,C(1,L)) onto its argument, which is unleashed on err via the App rule. In contrast to weaker head strictness, this demand is strong enough to unleash err's signature and hence we see that the whole expression diverges! -Note [Demand env Equality] +Note [Demand type Equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What is the difference between the Demand env {x->A} and {}? +What is the difference between the DmdType {x->A} and ? Answer: There is none! They have the exact same semantics, because any var that -is not mentioned in 'de_fvs' implicitly has demand 'defaultFvDmd', based on -the divergence of the demand env 'de_div'. -Similarly, b{x->B, y->A} is the same as b{y->A}, because the default FV -demand of BotDiv is B. But neither is equal to b{}, because y has demand B in +is not mentioned in 'dt_env' implicitly has demand 'defaultFvDmd', based on +the divergence of the demand type 'dt_div'. +Similarly, b{x->B, y->A} is the same as b{y->A}, because the default FV +demand of BotDiv is B. But neither is equal to b, because y has demand B in the latter, not A as before. -The Eq instance of DmdEnv must reflect that, otherwise we can get into monotonicity -issues during fixed-point iteration ({x->A} /= {} /= {x->A} /= ...). -It does so by filtering out any default FV demands prior to comparing 'de_fvs'. +NB: 'dt_env' technically can't stand for its own, because it doesn't tell us the +demand on FVs that don't appear in the DmdEnv. Hence 'PlusDmdArg' carries along +a 'Divergence', for example. -Note that 'lubDmdEnv' maintains this kind of equality by using 'plusVarEnv_CD', -involving 'defaultFvDmd' for any entries present in one 'de_fvs' but not the +The Eq instance of DmdType must reflect that, otherwise we can get into monotonicity +issues during fixed-point iteration ({x->A} /= /= {x->A} /= ...). +It does so by filtering out any default FV demands prior to comparing 'dt_env'. +An alternative would be to maintain an invariant that there are no default FV demands +in 'dt_env' to begin with, but that seems more involved to maintain in the current +implementation. + +Note that 'lubDmdType' maintains this kind of equality by using 'plusVarEnv_CD', +involving 'defaultFvDmd' for any entries present in one 'dt_env' but not the other. -Note [Asymmetry of plusDmdType] +Note [Asymmetry of 'plus*'] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'plus' for DmdTypes is *asymmetrical*, because there can only one be one type contributing argument demands! For example, given (e1 e2), we get @@ -1842,7 +2029,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a demand transformer d1 -> d2 -> r for f. If a sufficiently detailed demand is fed into this transformer, -e.g arising from "f x1 x2" in a strict, use-once context, +e.g arising from "f x1 x2" in a strict, use-once context, then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for the free variable environment) and furthermore the result information r is the one we want to use. @@ -1850,9 +2037,9 @@ An anonymous lambda is also an unsaturated function all (needs one argument, none given), so this applies to that case as well. -But the demand fed into f might be less than C1(C1(L)). Then we have to +But the demand fed into f might be less than C(1,C(1,L)). Then we have to 'multDmdType' the announced demand type. Examples: - * Not strict enough, e.g. C1(C1(L)): + * Not strict enough, e.g. C(1,C(1,L)): - We have to multiply all argument and free variable demands with C_01, zapping strictness. - We have to multiply divergence with C_01. If r says that f Diverges for sure, @@ -1860,7 +2047,7 @@ be passed. If the demand is lower, we may just as well converge. If we were tracking definite convergence, than that would still hold under a weaker demand than expected by the demand transformer. - * Used more than once, e.g. CS(C1(L)): + * Used more than once, e.g. C(S,C(1,L)): - Multiply with C_1N. Even if f puts a used-once demand on any of its argument or free variables, if we call f multiple times, we may evaluate this argument or free variable multiple times. @@ -1889,8 +2076,8 @@ c) an indication of the result of applying the Id to its arguments -However, in fact we store in the Id an extremely emascuated demand -transfomer, namely +However, in fact we store in the Id an extremely emasculated demand +transformer, namely a single DmdType (Nevertheless we dignify DmdSig as a distinct type.) @@ -1916,7 +2103,7 @@ uses x with 1L, and its arg with demand 1P(L,L). Note [Understanding DmdType and DmdSig] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Demand types are sound approximations of an expression's semantics relative to the incoming demand we put the expression under. Consider the following expression: @@ -1930,8 +2117,8 @@ incoming demand | demand type -------------------------------- 1A | {} - C1(C1(L)) | <1P(L)>{} - C1(C1(1P(1P(L),A))) | <1P(A)>{} + C(1,C(1,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 the arity of the incoming call demand due to the anonymous lambda. @@ -1968,21 +2155,24 @@ -- | 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) +mkDmdSigForArity arity dmd_ty@(DmdType fvs args div) + | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args) div | otherwise = DmdSig (etaExpandDmdType arity dmd_ty) mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig -mkClosedDmdSig ds div = mkDmdSigForArity (length ds) (DmdType (mkEmptyDmdEnv div) ds) +mkClosedDmdSig ds res = mkDmdSigForArity (length ds) (DmdType emptyDmdEnv ds res) +mkVanillaDmdSig :: Arity -> Divergence -> DmdSig +mkVanillaDmdSig ar div = mkClosedDmdSig (replicate ar topDmd) div + splitDmdSig :: DmdSig -> ([Demand], Divergence) -splitDmdSig (DmdSig (DmdType env dmds)) = (dmds, de_div env) +splitDmdSig (DmdSig (DmdType _ dmds res)) = (dmds, res) dmdSigDmdEnv :: DmdSig -> DmdEnv -dmdSigDmdEnv (DmdSig (DmdType env _)) = env +dmdSigDmdEnv (DmdSig (DmdType env _ _)) = env hasDemandEnvSig :: DmdSig -> Bool -hasDemandEnvSig = not . isEmptyVarEnv . de_fvs . dmdSigDmdEnv +hasDemandEnvSig = not . isEmptyVarEnv . dmdSigDmdEnv botSig :: DmdSig botSig = DmdSig botDmdType @@ -1991,16 +2181,23 @@ nopSig = DmdSig nopDmdType isNopSig :: DmdSig -> Bool -isNopSig (DmdSig ty) = ty == nopDmdType +isNopSig (DmdSig ty) = isNopDmdType ty -- | True if the signature diverges or throws an exception in a saturated call. -- See Note [Dead ends]. isDeadEndSig :: DmdSig -> Bool -isDeadEndSig (DmdSig (DmdType env _)) = isDeadEndDiv (de_div env) +isDeadEndSig (DmdSig (DmdType _ _ res)) = isDeadEndDiv res +-- | True if the signature diverges or throws an imprecise exception in a saturated call. +-- NB: In constrast to 'isDeadEndSig' this returns False for 'exnDiv'. +-- See Note [Dead ends] +-- and Note [Precise vs imprecise exceptions]. +isBottomingSig :: DmdSig -> Bool +isBottomingSig (DmdSig (DmdType _ _ res)) = res == botDiv + -- | True when the signature indicates all arguments are boxed onlyBoxedArguments :: DmdSig -> Bool -onlyBoxedArguments (DmdSig (DmdType _ dmds)) = all demandIsBoxed dmds +onlyBoxedArguments (DmdSig (DmdType _ dmds _)) = all demandIsBoxed dmds where demandIsBoxed BotDmd = True demandIsBoxed AbsDmd = True @@ -2020,29 +2217,59 @@ -- Hence this function conservatively returns False in that case. -- See Note [Dead ends]. isDeadEndAppSig :: DmdSig -> Int -> Bool -isDeadEndAppSig (DmdSig (DmdType env ds)) n - = isDeadEndDiv (de_div env) && not (lengthExceeds ds n) - -trimBoxityDmdEnv :: DmdEnv -> DmdEnv -trimBoxityDmdEnv (DE fvs div) = DE (mapVarEnv trimBoxity fvs) div +isDeadEndAppSig (DmdSig (DmdType _ ds res)) n + = isDeadEndDiv res && not (lengthExceeds ds n) trimBoxityDmdType :: DmdType -> DmdType -trimBoxityDmdType (DmdType env ds) = - DmdType (trimBoxityDmdEnv env) (map trimBoxity ds) +trimBoxityDmdType (DmdType fvs ds res) = + DmdType (mapVarEnv trimBoxity fvs) (map trimBoxity ds) res trimBoxityDmdSig :: DmdSig -> DmdSig trimBoxityDmdSig = coerce trimBoxityDmdType +-- | Transfers the boxity of the left arg to the demand structure of the right +-- arg. This only makes sense if applied to new and old demands of the same +-- value. +transferBoxity :: Demand -> Demand -> Demand +transferBoxity from to = go_dmd from to + where + go_dmd (from_n :* from_sd) to_dmd@(to_n :* to_sd) + | isAbs from_n || isAbs to_n = to_dmd + | otherwise = case (from_sd, to_sd) of + (Poly from_b _, Poly _ to_c) -> + to_n :* Poly from_b to_c + (_, Prod _ to_ds) + | Just (from_b, from_ds) <- viewProd (length to_ds) from_sd + -> to_n :* mkProd from_b (strictZipWith go_dmd from_ds to_ds) + (Prod from_b from_ds, _) + | Just (_, to_ds) <- viewProd (length from_ds) to_sd + -> to_n :* mkProd from_b (strictZipWith go_dmd from_ds to_ds) + _ -> trimBoxity to_dmd + +transferArgBoxityDmdType :: DmdType -> DmdType -> DmdType +transferArgBoxityDmdType _from@(DmdType _ from_ds _) to@(DmdType to_fvs to_ds to_res) + | equalLength from_ds to_ds + = -- pprTraceWith "transfer" (\r -> ppr _from $$ ppr to $$ ppr r) $ + DmdType to_fvs -- Only arg boxity! See Note [Don't change boxity without worker/wrapper] + (zipWith transferBoxity from_ds to_ds) + to_res + | otherwise + = trimBoxityDmdType to + +transferArgBoxityDmdSig :: DmdSig -> DmdSig -> DmdSig +transferArgBoxityDmdSig = coerce transferArgBoxityDmdType + prependArgsDmdSig :: Int -> DmdSig -> DmdSig -- ^ Add extra ('topDmd') arguments to a strictness signature. -- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument -- demands. This is used by FloatOut. -prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds)) - | new_args == 0 = sig - | dmd_ty == nopDmdType = sig - | otherwise = DmdSig (DmdType env dmds') +prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds res)) + | new_args == 0 = sig + | isNopDmdType dmd_ty = sig + | otherwise = DmdSig (DmdType env dmds' res) where - dmds' = replicate new_args topDmd ++ dmds + dmds' = assertPpr (new_args > 0) (ppr new_args) $ + replicate new_args topDmd ++ dmds etaConvertDmdSig :: Arity -> DmdSig -> DmdSig -- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to @@ -2081,7 +2308,7 @@ -- Given a function's 'DmdSig' and a 'SubDemand' for the evaluation context, -- return how the function evaluates its free variables and arguments. dmdTransformSig :: DmdSig -> DmdTransformer -dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds)) sd +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?] @@ -2096,7 +2323,7 @@ where arity = length str_marks (n, body_sd) = peelManyCalls arity sd - mk_body_ty n dmds = DmdType nopDmdEnv (zipWith (bump n) str_marks dmds) + mk_body_ty n dmds = DmdType emptyDmdEnv (zipWith (bump n) str_marks dmds) topDiv 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] @@ -2107,11 +2334,11 @@ 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 _ [_ :* prod] _)) call_sd | (n, sd') <- peelCallDmd call_sd , Prod _ sig_ds <- prod = multDmdType n $ - DmdType nopDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] + DmdType emptyDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] topDiv | otherwise = nopDmdType -- See Note [Demand transformer for a dictionary selector] where @@ -2162,7 +2389,7 @@ SubDemand --F_f----> DmdType With - α(C1(C1(_))) = >=2 + α(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 @@ -2192,7 +2419,7 @@ What do we learn about the demand on 'd'? Alas, we see only the demand from 'sc_sel', namely '1P(1,A)'. We /don't/ see that 'd' really has a nested -demand '1P(1P(A,1C1(1)),A)'. On the other hand, if we inlined the two selectors +demand '1P(1P(A,1C(1,1)),A)'. On the other hand, if we inlined the two selectors we'd have f d x = case d of (x,_) -> @@ -2233,12 +2460,9 @@ it should not fall over. -} -zapDmdEnv :: DmdEnv -> DmdEnv -zapDmdEnv (DE _ div) = mkEmptyDmdEnv div - -- | Remove the demand environment from the signature. zapDmdEnvSig :: DmdSig -> DmdSig -zapDmdEnvSig (DmdSig (DmdType env ds)) = DmdSig (DmdType (zapDmdEnv env) ds) +zapDmdEnvSig (DmdSig (DmdType _ ds r)) = mkClosedDmdSig ds r zapUsageDemand :: Demand -> Demand -- Remove the usage info, but not the strictness info, from the demand @@ -2259,8 +2483,8 @@ -- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the strictness -- signature zapUsedOnceSig :: DmdSig -> DmdSig -zapUsedOnceSig (DmdSig (DmdType env ds)) - = DmdSig (DmdType env (map zapUsedOnceDemand ds)) +zapUsedOnceSig (DmdSig (DmdType env ds r)) + = DmdSig (DmdType env (map zapUsedOnceDemand ds) r) data KillFlags = KillFlags { kf_abs :: Bool @@ -2345,11 +2569,11 @@ seqDemandList = foldr (seq . seqDemand) () seqDmdType :: DmdType -> () -seqDmdType (DmdType env ds) = - seqDmdEnv env `seq` seqDemandList ds `seq` () +seqDmdType (DmdType env ds res) = + seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` () seqDmdEnv :: DmdEnv -> () -seqDmdEnv (DE fvs _) = seqEltsUFM seqDemand fvs +seqDmdEnv env = seqEltsUFM seqDemand env seqDmdSig :: DmdSig -> () seqDmdSig (DmdSig ty) = seqDmdType ty @@ -2441,8 +2665,8 @@ -- | See Note [Demand notation] instance Outputable SubDemand where - ppr (Poly b sd) = pp_boxity b <> ppr sd - ppr (Call n sd) = char 'C' <> ppr n <> parens (ppr sd) + ppr (Poly b n) = pp_boxity b <> ppr n + ppr (Call n sd) = char 'C' <> parens (ppr n <> comma <> ppr sd) ppr (Prod b ds) = pp_boxity b <> char 'P' <> parens (fields ds) where fields [] = empty @@ -2458,20 +2682,17 @@ ppr ExnOrDiv = char 'x' -- for e(x)ception ppr Dunno = empty -instance Outputable DmdEnv where - ppr (DE fvs div) - = ppr div <> if null fv_elts then empty - else braces (fsep (map pp_elt fv_elts)) +instance Outputable DmdType where + ppr (DmdType fv ds res) + = hsep [hcat (map (angleBrackets . ppr) ds) <> ppr res, + if null fv_elts then empty + else braces (fsep (map pp_elt fv_elts))] where pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd - fv_elts = nonDetUFMToList fvs + fv_elts = nonDetUFMToList fv -- It's OK to use nonDetUFMToList here because we only do it for -- pretty printing -instance Outputable DmdType where - ppr (DmdType fv ds) - = hcat (map (angleBrackets . ppr) ds) <> ppr fv - instance Outputable DmdSig where ppr (DmdSig ty) = ppr ty @@ -2520,6 +2741,15 @@ 2 -> Prod <$> get bh <*> get bh _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int)) +instance Binary DmdSig where + put_ bh (DmdSig aa) = put_ bh aa + get bh = DmdSig <$> get bh + +instance Binary DmdType where + -- Ignore DmdEnv when spitting out the DmdType + put_ bh (DmdType _ ds dr) = put_ bh ds *> put_ bh dr + get bh = DmdType emptyDmdEnv <$> get bh <*> get bh + instance Binary Divergence where put_ bh Dunno = putByte bh 0 put_ bh ExnOrDiv = putByte bh 1 @@ -2531,16 +2761,3 @@ 1 -> return ExnOrDiv 2 -> return Diverges _ -> pprPanic "Binary:Divergence" (ppr (fromIntegral h :: Int)) - -instance Binary DmdEnv where - -- Ignore VarEnv when spitting out the DmdType - put_ bh (DE _ d) = put_ bh d - get bh = DE emptyVarEnv <$> get bh - -instance Binary DmdType where - put_ bh (DmdType fv ds) = put_ bh fv *> put_ bh ds - get bh = DmdType <$> get bh <*> get bh - -instance Binary DmdSig where - put_ bh (DmdSig aa) = put_ bh aa - get bh = DmdSig <$> get bh diff --git a/GHC/Types/Error.hs b/GHC/Types/Error.hs --- a/GHC/Types/Error.hs +++ b/GHC/Types/Error.hs @@ -4,6 +4,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} module GHC.Types.Error ( -- * Messages @@ -23,6 +26,7 @@ , MessageClass (..) , Severity (..) , Diagnostic (..) + , UnknownDiagnostic (..) , DiagnosticMessage (..) , DiagnosticReason (..) , DiagnosticHint (..) @@ -31,6 +35,8 @@ , mkDecoratedDiagnostic , mkDecoratedError + , NoDiagnosticOpts(..) + -- * Hints and refactoring actions , GhcHint (..) , AvailableBindings(..) @@ -54,7 +60,7 @@ , pprMessageBag , mkLocMessage - , mkLocMessageAnn + , mkLocMessageWarningGroups , getCaretDiagnostic -- * Queries , isIntrinsicErrorMessage @@ -65,6 +71,9 @@ , partitionMessages , errorsFound , errorsOrFatalWarningsFound + + -- * Diagnostic codes + , DiagnosticCode(..) ) where @@ -77,13 +86,19 @@ import GHC.Utils.Outputable as Outputable import qualified GHC.Utils.Ppr.Colour as Col import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Hint import GHC.Data.FastString (unpackFS) import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) import GHC.Utils.Json +import GHC.Utils.Panic import Data.Bifunctor import Data.Foldable ( fold ) -import GHC.Types.Hint +import qualified Data.List.NonEmpty as NE +import Data.List ( intercalate ) +import Data.Typeable ( Typeable ) +import Numeric.Natural ( Natural ) +import Text.Printf ( printf ) {- Note [Messages] @@ -191,39 +206,6 @@ mapDecoratedSDoc f (Decorated s1) = Decorated (map f s1) -{- -Note [Rendering Messages] -~~~~~~~~~~~~~~~~~~~~~~~~~ - -Turning 'Messages' into something that renders nicely for the user is one of -the last steps, and it happens typically at the application's boundaries (i.e. -from the 'Driver' upwards). - -For now (see #18516) this class has few instance, but the idea is that as the -more domain-specific types are defined, the more instances we would get. For -example, given something like: - - data TcRnDiagnostic - = TcRnOutOfScope .. - | .. - - newtype TcRnMessage = TcRnMessage (DiagnosticMessage TcRnDiagnostic) - -We could then define how a 'TcRnDiagnostic' is displayed to the user. Rather -than scattering pieces of 'SDoc' around the codebase, we would write once for -all: - - instance Diagnostic TcRnDiagnostic where - diagnosticMessage (TcRnMessage msg) = case diagMessage msg of - TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."] - ... - -This way, we can easily write generic rendering functions for errors that all -they care about is the knowledge that a given type 'e' has a 'Diagnostic' -constraint. - --} - -- | A class identifying a diagnostic. -- Dictionary.com defines a diagnostic as: -- @@ -232,16 +214,59 @@ -- -- 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. See also Note [Rendering --- Messages]. +-- message was generated in the first place. class Diagnostic a where - diagnosticMessage :: a -> DecoratedSDoc + + -- | Type of configuration options for the diagnostic. + type DiagnosticOpts a + defaultDiagnosticOpts :: DiagnosticOpts a + + -- | Extract the error message text from a 'Diagnostic'. + diagnosticMessage :: DiagnosticOpts a -> a -> DecoratedSDoc + + -- | Extract the reason for this diagnostic. For warnings, + -- a 'DiagnosticReason' includes the warning flag. diagnosticReason :: a -> DiagnosticReason + + -- | Extract any hints a user might use to repair their + -- code to avoid this diagnostic. diagnosticHints :: a -> [GhcHint] -pprDiagnostic :: Diagnostic e => e -> SDoc + -- | Get the 'DiagnosticCode' associated with this 'Diagnostic'. + -- This can return 'Nothing' for at least two reasons: + -- + -- 1. The message might be from a plugin that does not supply codes. + -- 2. The message might not yet have been assigned a code. See the + -- 'Diagnostic' instance for 'DiagnosticMessage'. + -- + -- Ideally, case (2) would not happen, but because + -- some errors in GHC still use the old system of just writing the + -- error message in-place (instead of using a dedicated error type + -- and constructor), we do not have error codes for all errors. + -- #18516 tracks our progress toward this goal. + diagnosticCode :: a -> Maybe DiagnosticCode + +-- | An existential wrapper around an unknown diagnostic. +data UnknownDiagnostic where + UnknownDiagnostic :: (DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) + => a -> UnknownDiagnostic + +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 + +-- A fallback 'DiagnosticOpts' which can be used when there are no options +-- for a particular diagnostic. +data NoDiagnosticOpts = NoDiagnosticOpts + +pprDiagnostic :: forall e . Diagnostic e => e -> SDoc pprDiagnostic e = vcat [ ppr (diagnosticReason e) - , nest 2 (vcat (unDecorated (diagnosticMessage 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 @@ -261,9 +286,12 @@ } instance Diagnostic DiagnosticMessage where - diagnosticMessage = diagMessage + type DiagnosticOpts DiagnosticMessage = NoDiagnosticOpts + defaultDiagnosticOpts = NoDiagnosticOpts + diagnosticMessage _ = diagMessage diagnosticReason = diagReason diagnosticHints = diagHints + diagnosticCode _ = Nothing -- | Helper function to use when no hints can be provided. Currently this function -- can be used to construct plain 'DiagnosticMessage' and add hints to them, but @@ -323,7 +351,7 @@ data MsgEnvelope e = MsgEnvelope { errMsgSpan :: SrcSpan -- ^ The SrcSpan is used for sorting errors into line-number order - , errMsgContext :: PrintUnqualified + , errMsgContext :: NamePprCtx , errMsgDiagnostic :: e , errMsgSeverity :: Severity } deriving (Functor, Foldable, Traversable) @@ -344,7 +372,7 @@ -- ^ Log messages intended for end users. -- No file\/line\/column stuff. - | MCDiagnostic Severity DiagnosticReason + | MCDiagnostic Severity DiagnosticReason (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, @@ -353,10 +381,15 @@ -- and manipulate diagnostic messages directly, for example inside -- 'GHC.Utils.Error'. In all the other circumstances, /especially/ when -- emitting compiler diagnostics, use the smart constructor. - deriving (Eq, Show) - -{- Note [Suppressing Messages] + -- + -- The @Maybe 'DiagnosticCode'@ field carries a code (if available) for + -- this diagnostic. If you are creating a message not tied to any + -- error-message type, then use Nothing. In the long run, this really + -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes]. +{- +Note [Suppressing Messages] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ The 'SevIgnore' constructor is used to generate messages for diagnostics which are meant to be suppressed and not reported to the user: the classic example are warnings for which the user didn't enable the corresponding 'WarningFlag', @@ -410,27 +443,31 @@ json MCInteractive = JSString "MCInteractive" json MCDump = JSString "MCDump" json MCInfo = JSString "MCInfo" - json (MCDiagnostic sev reason) = - JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason) + json (MCDiagnostic sev reason code) = + JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code) instance Show (MsgEnvelope DiagnosticMessage) where show = showMsgEnvelope --- | Shows an 'MsgEnvelope'. -showMsgEnvelope :: Diagnostic a => MsgEnvelope a -> String +-- | Shows an 'MsgEnvelope'. Only use this for debugging. +showMsgEnvelope :: forall a . Diagnostic a => MsgEnvelope a -> String showMsgEnvelope err = - renderWithContext defaultSDocContext (vcat (unDecorated . diagnosticMessage $ errMsgDiagnostic err)) + renderWithContext defaultSDocContext (vcat (unDecorated . (diagnosticMessage (defaultDiagnosticOpts @a)) $ errMsgDiagnostic err)) pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) --- | Make an unannotated error message with location info. -mkLocMessage :: MessageClass -> SrcSpan -> SDoc -> SDoc -mkLocMessage = mkLocMessageAnn Nothing +mkLocMessage + :: MessageClass -- ^ What kind of message? + -> SrcSpan -- ^ location + -> SDoc -- ^ message + -> SDoc +mkLocMessage = mkLocMessageWarningGroups True --- | Make a possibly annotated error message with location info. -mkLocMessageAnn - :: Maybe String -- ^ optional annotation +-- | Make an error message with location info, specifying whether to show +-- warning groups (if applicable). +mkLocMessageWarningGroups + :: Bool -- ^ Print warning groups (if applicable)? -> MessageClass -- ^ What kind of message? -> SrcSpan -- ^ location -> SDoc -- ^ message @@ -438,41 +475,76 @@ -- Always print the location, even if it is unhelpful. Error messages -- are supposed to be in a standard format, and one without a location -- would look strange. Better to say explicitly "". -mkLocMessageAnn ann msg_class locn msg +mkLocMessageWarningGroups show_warn_groups msg_class locn msg = sdocOption sdocColScheme $ \col_scheme -> let locn' = sdocOption sdocErrorSpans $ \case True -> ppr locn False -> ppr (srcSpanStart locn) - msgColour = getMessageClassColour msg_class col_scheme + msg_colour = getMessageClassColour msg_class col_scheme + col = coloured msg_colour . text - -- Add optional information - optAnn = case ann of - Nothing -> text "" - Just i -> text " [" <> coloured msgColour (text i) <> text "]" + msg_title = coloured msg_colour $ + case msg_class of + MCDiagnostic SevError _ _ -> text "error" + MCDiagnostic SevWarning _ _ -> text "warning" + MCFatal -> text "fatal" + _ -> empty + warning_flag_doc = + case msg_class of + MCDiagnostic sev reason _code + | Just msg <- flag_msg sev reason -> brackets msg + _ -> empty + + code_doc = + case msg_class of + MCDiagnostic _ _ (Just code) -> brackets (coloured msg_colour $ ppr code) + _ -> empty + + flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc + flag_msg SevIgnore _ = Nothing + -- The above can happen when displaying an error message + -- 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) = + let name = NE.head (warnFlagNames wflag) in + Just $ col ("-W" ++ name) <+> warn_flag_grp wflag + <> comma + <+> col ("Werror=" ++ name) + flag_msg SevError ErrorWithoutFlag = Nothing + flag_msg SevWarning WarningWithoutFlag = Nothing + flag_msg SevWarning (WarningWithFlag wflag) = + let name = NE.head (warnFlagNames wflag) in + Just (col ("-W" ++ name) <+> warn_flag_grp wflag) + 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) ++ ")" + | otherwise = empty + -- Add prefixes, like Foo.hs:34: warning: -- header = locn' <> colon <+> - coloured msgColour msgText <> optAnn + msg_title <> colon <+> + code_doc <+> warning_flag_doc in coloured (Col.sMessage col_scheme) (hang (coloured (Col.sHeader col_scheme) header) 4 msg) - where - msgText = - case msg_class of - MCDiagnostic SevError _reason -> text "error:" - MCDiagnostic SevWarning _reason -> text "warning:" - MCFatal -> text "fatal:" - _ -> empty - getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour -getMessageClassColour (MCDiagnostic SevError _reason) = Col.sError -getMessageClassColour (MCDiagnostic SevWarning _reason) = Col.sWarning -getMessageClassColour MCFatal = Col.sFatal -getMessageClassColour _ = const mempty +getMessageClassColour (MCDiagnostic SevError _reason _code) = Col.sError +getMessageClassColour (MCDiagnostic SevWarning _reason _code) = Col.sWarning +getMessageClassColour MCFatal = Col.sFatal +getMessageClassColour _ = const mempty getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty @@ -602,3 +674,29 @@ -- warnings, and the second the errors. partitionMessages :: Diagnostic e => Messages e -> (Messages e, Messages e) partitionMessages (Messages xs) = bimap Messages Messages (partitionBag isWarningMessage xs) + +---------------------------------------------------------------- +-- -- +-- Definition of diagnostic codes -- +-- -- +---------------------------------------------------------------- + +-- | A diagnostic code is a namespaced numeric identifier +-- unique to the given diagnostic (error or warning). +-- +-- All diagnostic codes defined within GHC are given the +-- GHC namespace. +-- +-- See Note [Diagnostic codes] in GHC.Types.Error.Codes. +data DiagnosticCode = + DiagnosticCode + { diagnosticCodeNameSpace :: String + -- ^ diagnostic code prefix (e.g. "GHC") + , diagnosticCodeNumber :: Natural + -- ^ the actual diagnostic code + } + +instance Outputable DiagnosticCode where + ppr (DiagnosticCode prefix c) = + text prefix <> text "-" <> text (printf "%05d" c) + -- pad the numeric code to have at least 5 digits diff --git a/GHC/Types/Error/Codes.hs b/GHC/Types/Error/Codes.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/Error/Codes.hs @@ -0,0 +1,903 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Defines diagnostic codes for the diagnostics emitted by GHC. +-- +-- A diagnostic code is a numeric unique identifier for a diagnostic. +-- See Note [Diagnostic codes]. +module GHC.Types.Error.Codes + ( constructorCode ) + where + +import GHC.Prelude +import GHC.Types.Error ( DiagnosticCode(..), UnknownDiagnostic (..), diagnosticCode ) + +import GHC.Hs.Extension ( GhcRn ) + +import GHC.Driver.Errors.Types ( DriverMessage ) +import GHC.Parser.Errors.Types ( PsMessage, PsHeaderMessage ) +import GHC.HsToCore.Errors.Types ( DsMessage ) +import GHC.Tc.Errors.Types +import GHC.Tc.Utils.TcType ( IllegalForeignTypeReason, TypeCannotBeMarshaledReason ) +import GHC.Unit.Module.Warnings ( WarningTxt ) +import GHC.Utils.Panic.Plain + +import Data.Kind ( Type, Constraint ) +import GHC.Exts ( proxy# ) +import GHC.Generics +import GHC.TypeLits ( Symbol, TypeError, ErrorMessage(..) ) +import GHC.TypeNats ( Nat, KnownNat, natVal' ) + +{- Note [Diagnostic codes] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every time a new diagnostic (error or warning) is introduced to GHC, +it is assigned a new numeric code, which has never been used before. + +To ensure uniqueness across GHC versions, we proceed as follows: + + - all diagnostic codes are defined in a single module, GHC.Types.Error.Codes. + - uniqueness of diagnostic codes is ensured by the use of an injective type family, + GhcDiagnosticCode, + - 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. + +[Instructions for adding a new diagnostic code] + + After adding a constructor to a diagnostic datatype, such as PsMessage, + TcRnMessage, DsMessage or DriverMessage, you can add corresponding + diagnostic codes as follows: + + a. To give a single diagnostic code to the constructor, simply add a + type family equation to GHC.Error.Codes.GhcDiagnosticCode, e.g.: + + 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. + + You will get a type error if you try to use an error code that is already + used by another constructor. + + b. If you instead require more granular diagnostic codes, add a type family + equation to GHC.Error.Codes.ConRecursInto, specifying which argument + to recur into to obtain an diagnostic code. + + For example, the 'TcRnCannotDeriveInstance' constructor is associated + with several diagnostic codes, depending on the value of the argument of + type 'DeriveInstanceErrReason'. This is achieved as follows: + + - The equation + ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason + says to recur into the argument of type 'DeriveInstanceErrReason' + to get a diagnostic code. + + - The equations + GhcDiagnosticCode "DerivErrNotWellKinded" = 62016 + GhcDiagnosticCode "DerivErrSafeHaskellGenericInst" = 07214 + GhcDiagnosticCode "DerivErrDerivingViaWrongKind" = 63174 + ... + give the diagnostic codes for the various constructors of DeriveInstanceErrReason. + These are added following the procedure in (a). + + 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. +-} + +{- ********************************************************************* +* * + The GhcDiagnosticCode type family +* * +********************************************************************* -} + +-- | 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)) + => diag -> Maybe DiagnosticCode +constructorCode diag = gdiagnosticCode (from diag) + +-- | Type family computing the numeric diagnostic code for a given error message constructor. +-- +-- Its injectivity annotation ensures uniqueness of error codes. +-- +-- Never remove a return value from this type family! Outdated error messages must still +-- be tracked here to ensure uniqueness of diagnostic codes across GHC versions. +-- +-- See Note [Diagnostic codes] in GHC.Types.Error. +type GhcDiagnosticCode :: Symbol -> Nat +type family GhcDiagnosticCode c = n | n -> c where + + -- Desugarer diagnostic codes + GhcDiagnosticCode "DsEmptyEnumeration" = 10190 + GhcDiagnosticCode "DsIdentitiesFound" = 04214 + GhcDiagnosticCode "DsOverflowedLiterals" = 97441 + GhcDiagnosticCode "DsRedundantBangPatterns" = 38520 + GhcDiagnosticCode "DsOverlappingPatterns" = 53633 + GhcDiagnosticCode "DsInaccessibleRhs" = 94210 + 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 + GhcDiagnosticCode "DsRuleBindersNotBound" = 40548 + GhcDiagnosticCode "DsLazyPatCantBindVarsOfUnliftedType" = 17879 + GhcDiagnosticCode "DsNotYetHandledByTH" = 65904 + GhcDiagnosticCode "DsAggregatedViewExpressions" = 19551 + GhcDiagnosticCode "DsUnbangedStrictPatterns" = 21030 + GhcDiagnosticCode "DsCannotMixPolyAndUnliftedBindings" = 20036 + GhcDiagnosticCode "DsWrongDoBind" = 08838 + GhcDiagnosticCode "DsUnusedDoBind" = 81995 + GhcDiagnosticCode "DsRecBindsNotAllowedForUnliftedTys" = 20185 + GhcDiagnosticCode "DsRuleMightInlineFirst" = 95396 + GhcDiagnosticCode "DsAnotherRuleMightFireFirst" = 87502 + + + -- Parser diagnostic codes + GhcDiagnosticCode "PsErrParseLanguagePragma" = 68686 + GhcDiagnosticCode "PsErrUnsupportedExt" = 46537 + GhcDiagnosticCode "PsErrParseOptionsPragma" = 24342 + GhcDiagnosticCode "PsErrUnknownOptionsPragma" = 04924 + GhcDiagnosticCode "PsWarnBidirectionalFormatChars" = 03272 + GhcDiagnosticCode "PsWarnTab" = 94817 + GhcDiagnosticCode "PsWarnTransitionalLayout" = 93617 + GhcDiagnosticCode "PsWarnOperatorWhitespaceExtConflict" = 47082 + GhcDiagnosticCode "PsWarnOperatorWhitespace" = 40798 + GhcDiagnosticCode "PsWarnHaddockInvalidPos" = 94458 + GhcDiagnosticCode "PsWarnHaddockIgnoreMulti" = 05641 + GhcDiagnosticCode "PsWarnStarBinder" = 21887 + GhcDiagnosticCode "PsWarnStarIsType" = 39567 + GhcDiagnosticCode "PsWarnUnrecognisedPragma" = 42044 + GhcDiagnosticCode "PsWarnMisplacedPragma" = 28007 + GhcDiagnosticCode "PsWarnImportPreQualified" = 07924 + GhcDiagnosticCode "PsErrLexer" = 21231 + GhcDiagnosticCode "PsErrCmmLexer" = 75725 + GhcDiagnosticCode "PsErrCmmParser" = 09848 + GhcDiagnosticCode "PsErrParse" = 58481 + GhcDiagnosticCode "PsErrTypeAppWithoutSpace" = 84077 + GhcDiagnosticCode "PsErrLazyPatWithoutSpace" = 27207 + GhcDiagnosticCode "PsErrBangPatWithoutSpace" = 95644 + GhcDiagnosticCode "PsErrInvalidInfixHole" = 45106 + GhcDiagnosticCode "PsErrExpectedHyphen" = 44524 + GhcDiagnosticCode "PsErrSpaceInSCC" = 76176 + GhcDiagnosticCode "PsErrEmptyDoubleQuotes" = 11861 + GhcDiagnosticCode "PsErrLambdaCase" = 51179 + GhcDiagnosticCode "PsErrEmptyLambda" = 71614 + GhcDiagnosticCode "PsErrLinearFunction" = 31574 + GhcDiagnosticCode "PsErrMultiWayIf" = 28985 + GhcDiagnosticCode "PsErrOverloadedRecordUpdateNotEnabled" = 82135 + GhcDiagnosticCode "PsErrNumUnderscores" = 62330 + GhcDiagnosticCode "PsErrIllegalBangPattern" = 79767 + GhcDiagnosticCode "PsErrOverloadedRecordDotInvalid" = 26832 + GhcDiagnosticCode "PsErrIllegalPatSynExport" = 89515 + GhcDiagnosticCode "PsErrOverloadedRecordUpdateNoQualifiedFields" = 94863 + GhcDiagnosticCode "PsErrExplicitForall" = 25955 + GhcDiagnosticCode "PsErrIllegalQualifiedDo" = 40280 + GhcDiagnosticCode "PsErrQualifiedDoInCmd" = 54089 + GhcDiagnosticCode "PsErrRecordSyntaxInPatSynDecl" = 28021 + GhcDiagnosticCode "PsErrEmptyWhereInPatSynDecl" = 13248 + GhcDiagnosticCode "PsErrInvalidWhereBindInPatSynDecl" = 24737 + GhcDiagnosticCode "PsErrNoSingleWhereBindInPatSynDecl" = 65536 + GhcDiagnosticCode "PsErrDeclSpliceNotAtTopLevel" = 08451 + GhcDiagnosticCode "PsErrMultipleNamesInStandaloneKindSignature" = 42569 + GhcDiagnosticCode "PsErrIllegalExplicitNamespace" = 47007 + GhcDiagnosticCode "PsErrUnallowedPragma" = 85314 + GhcDiagnosticCode "PsErrImportPostQualified" = 87491 + GhcDiagnosticCode "PsErrImportQualifiedTwice" = 05661 + GhcDiagnosticCode "PsErrIllegalImportBundleForm" = 81284 + GhcDiagnosticCode "PsErrInvalidRuleActivationMarker" = 50396 + GhcDiagnosticCode "PsErrMissingBlock" = 16849 + GhcDiagnosticCode "PsErrUnsupportedBoxedSumExpr" = 09550 + GhcDiagnosticCode "PsErrUnsupportedBoxedSumPat" = 16863 + GhcDiagnosticCode "PsErrUnexpectedQualifiedConstructor" = 73413 + GhcDiagnosticCode "PsErrTupleSectionInPat" = 09646 + GhcDiagnosticCode "PsErrOpFewArgs" = 24180 + GhcDiagnosticCode "PsErrVarForTyCon" = 18208 + GhcDiagnosticCode "PsErrMalformedEntityString" = 26204 + GhcDiagnosticCode "PsErrDotsInRecordUpdate" = 70712 + GhcDiagnosticCode "PsErrInvalidDataCon" = 46574 + GhcDiagnosticCode "PsErrInvalidInfixDataCon" = 30670 + GhcDiagnosticCode "PsErrIllegalPromotionQuoteDataCon" = 80236 + GhcDiagnosticCode "PsErrUnpackDataCon" = 40845 + GhcDiagnosticCode "PsErrUnexpectedKindAppInDataCon" = 83653 + GhcDiagnosticCode "PsErrInvalidRecordCon" = 08195 + GhcDiagnosticCode "PsErrIllegalUnboxedStringInPat" = 69925 + GhcDiagnosticCode "PsErrIllegalUnboxedFloatingLitInPat" = 76595 + GhcDiagnosticCode "PsErrDoNotationInPat" = 06446 + GhcDiagnosticCode "PsErrIfThenElseInPat" = 45696 + GhcDiagnosticCode "PsErrLambdaCaseInPat" = 07636 + GhcDiagnosticCode "PsErrCaseInPat" = 53786 + GhcDiagnosticCode "PsErrLetInPat" = 78892 + GhcDiagnosticCode "PsErrLambdaInPat" = 00482 + GhcDiagnosticCode "PsErrArrowExprInPat" = 04584 + GhcDiagnosticCode "PsErrArrowCmdInPat" = 98980 + GhcDiagnosticCode "PsErrArrowCmdInExpr" = 66043 + GhcDiagnosticCode "PsErrViewPatInExpr" = 66228 + GhcDiagnosticCode "PsErrLambdaCmdInFunAppCmd" = 12178 + GhcDiagnosticCode "PsErrCaseCmdInFunAppCmd" = 92971 + GhcDiagnosticCode "PsErrLambdaCaseCmdInFunAppCmd" = 47171 + GhcDiagnosticCode "PsErrIfCmdInFunAppCmd" = 97005 + GhcDiagnosticCode "PsErrLetCmdInFunAppCmd" = 70526 + GhcDiagnosticCode "PsErrDoCmdInFunAppCmd" = 77808 + GhcDiagnosticCode "PsErrDoInFunAppExpr" = 52095 + GhcDiagnosticCode "PsErrMDoInFunAppExpr" = 67630 + GhcDiagnosticCode "PsErrLambdaInFunAppExpr" = 06074 + GhcDiagnosticCode "PsErrCaseInFunAppExpr" = 25037 + GhcDiagnosticCode "PsErrLambdaCaseInFunAppExpr" = 77182 + GhcDiagnosticCode "PsErrLetInFunAppExpr" = 90355 + GhcDiagnosticCode "PsErrIfInFunAppExpr" = 01239 + GhcDiagnosticCode "PsErrProcInFunAppExpr" = 04807 + GhcDiagnosticCode "PsErrMalformedTyOrClDecl" = 47568 + GhcDiagnosticCode "PsErrIllegalWhereInDataDecl" = 36952 + GhcDiagnosticCode "PsErrIllegalDataTypeContext" = 87429 + GhcDiagnosticCode "PsErrPrimStringInvalidChar" = 43080 + GhcDiagnosticCode "PsErrSuffixAT" = 33856 + GhcDiagnosticCode "PsErrPrecedenceOutOfRange" = 25078 + GhcDiagnosticCode "PsErrSemiColonsInCondExpr" = 75254 + GhcDiagnosticCode "PsErrSemiColonsInCondCmd" = 18910 + GhcDiagnosticCode "PsErrAtInPatPos" = 08382 + GhcDiagnosticCode "PsErrParseErrorOnInput" = 66418 + GhcDiagnosticCode "PsErrMalformedDecl" = 85316 + GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl" = 45054 + GhcDiagnosticCode "PsErrNotADataCon" = 25742 + GhcDiagnosticCode "PsErrInferredTypeVarNotAllowed" = 57342 + GhcDiagnosticCode "PsErrIllegalTraditionalRecordSyntax" = 65719 + GhcDiagnosticCode "PsErrParseErrorInCmd" = 03790 + GhcDiagnosticCode "PsErrInPat" = 07626 + GhcDiagnosticCode "PsErrIllegalRoleName" = 09009 + GhcDiagnosticCode "PsErrInvalidTypeSignature" = 94426 + GhcDiagnosticCode "PsErrUnexpectedTypeInDecl" = 77878 + GhcDiagnosticCode "PsErrInvalidPackageName" = 21926 + GhcDiagnosticCode "PsErrParseRightOpSectionInPat" = 72516 + GhcDiagnosticCode "PsErrIllegalGadtRecordMultiplicity" = 37475 + GhcDiagnosticCode "PsErrInvalidCApiImport" = 72744 + GhcDiagnosticCode "PsErrMultipleConForNewtype" = 05380 + GhcDiagnosticCode "PsErrUnicodeCharLooksLike" = 31623 + + -- Driver diagnostic codes + GhcDiagnosticCode "DriverMissingHomeModules" = 32850 + GhcDiagnosticCode "DriverUnknownHiddenModules" = 38189 + GhcDiagnosticCode "DriverUnknownReexportedModules" = 68286 + GhcDiagnosticCode "DriverUnusedPackages" = 42258 + GhcDiagnosticCode "DriverUnnecessarySourceImports" = 88907 + GhcDiagnosticCode "DriverDuplicatedModuleDeclaration" = 29235 + GhcDiagnosticCode "DriverModuleNotFound" = 82272 + GhcDiagnosticCode "DriverFileModuleNameMismatch" = 28623 + GhcDiagnosticCode "DriverUnexpectedSignature" = 66004 + GhcDiagnosticCode "DriverFileNotFound" = 49196 + GhcDiagnosticCode "DriverStaticPointersNotSupported" = 77799 + GhcDiagnosticCode "DriverBackpackModuleNotFound" = 19971 + GhcDiagnosticCode "DriverUserDefinedRuleIgnored" = 56147 + GhcDiagnosticCode "DriverMixedSafetyImport" = 70172 + GhcDiagnosticCode "DriverCannotLoadInterfaceFile" = 37141 + GhcDiagnosticCode "DriverInferredSafeModule" = 58656 + GhcDiagnosticCode "DriverMarkedTrustworthyButInferredSafe" = 19244 + GhcDiagnosticCode "DriverInferredSafeImport" = 82658 + GhcDiagnosticCode "DriverCannotImportUnsafeModule" = 44360 + GhcDiagnosticCode "DriverMissingSafeHaskellMode" = 29747 + GhcDiagnosticCode "DriverPackageNotTrusted" = 08674 + GhcDiagnosticCode "DriverCannotImportFromUntrustedPackage" = 75165 + GhcDiagnosticCode "DriverRedirectedNoMain" = 95379 + GhcDiagnosticCode "DriverHomePackagesNotClosed" = 03271 + + -- Constraint solver diagnostic codes + GhcDiagnosticCode "BadTelescope" = 97739 + GhcDiagnosticCode "UserTypeError" = 64725 + 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 + + -- Type mismatch errors + GhcDiagnosticCode "BasicMismatch" = 18872 + GhcDiagnosticCode "KindMismatch" = 89223 + GhcDiagnosticCode "TypeEqMismatch" = 83865 + GhcDiagnosticCode "CouldNotDeduce" = 05617 + + -- Variable unification errors + GhcDiagnosticCode "CannotUnifyWithPolytype" = 91028 + GhcDiagnosticCode "OccursCheck" = 27958 + GhcDiagnosticCode "SkolemEscape" = 46956 + GhcDiagnosticCode "DifferentTyVars" = 25897 + GhcDiagnosticCode "RepresentationalEq" = 10283 + + -- Typechecker/renamer diagnostic codes + GhcDiagnosticCode "TcRnRedundantConstraints" = 30606 + GhcDiagnosticCode "TcRnInaccessibleCode" = 40564 + GhcDiagnosticCode "TcRnTypeDoesNotHaveFixedRuntimeRep" = 18478 + GhcDiagnosticCode "TcRnImplicitLift" = 00846 + GhcDiagnosticCode "TcRnUnusedPatternBinds" = 61367 + GhcDiagnosticCode "TcRnDodgyImports" = 99623 + GhcDiagnosticCode "TcRnDodgyExports" = 75356 + GhcDiagnosticCode "TcRnMissingImportList" = 77037 + GhcDiagnosticCode "TcRnUnsafeDueToPlugin" = 01687 + GhcDiagnosticCode "TcRnModMissingRealSrcSpan" = 84170 + GhcDiagnosticCode "TcRnIdNotExportedFromModuleSig" = 44188 + GhcDiagnosticCode "TcRnIdNotExportedFromLocalSig" = 50058 + GhcDiagnosticCode "TcRnShadowedName" = 63397 + GhcDiagnosticCode "TcRnDuplicateWarningDecls" = 00711 + GhcDiagnosticCode "TcRnSimplifierTooManyIterations" = 95822 + GhcDiagnosticCode "TcRnIllegalPatSynDecl" = 82077 + GhcDiagnosticCode "TcRnLinearPatSyn" = 15172 + GhcDiagnosticCode "TcRnEmptyRecordUpdate" = 20825 + GhcDiagnosticCode "TcRnIllegalFieldPunning" = 44287 + GhcDiagnosticCode "TcRnIllegalWildcardsInRecord" = 37132 + GhcDiagnosticCode "TcRnIllegalWildcardInType" = 65507 + GhcDiagnosticCode "TcRnDuplicateFieldName" = 85524 + GhcDiagnosticCode "TcRnIllegalViewPattern" = 22406 + GhcDiagnosticCode "TcRnCharLiteralOutOfRange" = 17268 + GhcDiagnosticCode "TcRnIllegalWildcardsInConstructor" = 47217 + GhcDiagnosticCode "TcRnIgnoringAnnotations" = 66649 + GhcDiagnosticCode "TcRnAnnotationInSafeHaskell" = 68934 + GhcDiagnosticCode "TcRnInvalidTypeApplication" = 95781 + GhcDiagnosticCode "TcRnTagToEnumMissingValArg" = 36495 + GhcDiagnosticCode "TcRnTagToEnumUnspecifiedResTy" = 08522 + GhcDiagnosticCode "TcRnTagToEnumResTyNotAnEnum" = 49356 + GhcDiagnosticCode "TcRnTagToEnumResTyTypeData" = 96189 + GhcDiagnosticCode "TcRnArrowIfThenElsePredDependsOnResultTy" = 55868 + GhcDiagnosticCode "TcRnIllegalHsBootFileDecl" = 58195 + GhcDiagnosticCode "TcRnRecursivePatternSynonym" = 72489 + GhcDiagnosticCode "TcRnPartialTypeSigTyVarMismatch" = 88793 + GhcDiagnosticCode "TcRnPartialTypeSigBadQuantifier" = 94185 + GhcDiagnosticCode "TcRnMissingSignature" = 38417 + GhcDiagnosticCode "TcRnPolymorphicBinderMissingSig" = 64414 + GhcDiagnosticCode "TcRnOverloadedSig" = 16675 + GhcDiagnosticCode "TcRnTupleConstraintInst" = 69012 + GhcDiagnosticCode "TcRnAbstractClassInst" = 51758 + GhcDiagnosticCode "TcRnNoClassInstHead" = 56538 + GhcDiagnosticCode "TcRnUserTypeError" = 47403 + GhcDiagnosticCode "TcRnConstraintInKind" = 01259 + GhcDiagnosticCode "TcRnUnboxedTupleOrSumTypeFuncArg" = 19590 + GhcDiagnosticCode "TcRnLinearFuncInKind" = 13218 + GhcDiagnosticCode "TcRnForAllEscapeError" = 31147 + GhcDiagnosticCode "TcRnVDQInTermType" = 51580 + GhcDiagnosticCode "TcRnBadQuantPredHead" = 02550 + GhcDiagnosticCode "TcRnIllegalTupleConstraint" = 77539 + 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 + GhcDiagnosticCode "TcRnFunDepConflict" = 46208 + GhcDiagnosticCode "TcRnDupInstanceDecls" = 59692 + GhcDiagnosticCode "TcRnConflictingFamInstDecls" = 34447 + GhcDiagnosticCode "TcRnFamInstNotInjective" = 05175 + GhcDiagnosticCode "TcRnBangOnUnliftedType" = 55666 + GhcDiagnosticCode "TcRnLazyBangOnUnliftedType" = 71444 + GhcDiagnosticCode "TcRnMultipleDefaultDeclarations" = 99565 + GhcDiagnosticCode "TcRnBadDefaultType" = 88933 + GhcDiagnosticCode "TcRnPatSynBundledWithNonDataCon" = 66775 + GhcDiagnosticCode "TcRnPatSynBundledWithWrongType" = 66025 + GhcDiagnosticCode "TcRnDupeModuleExport" = 51876 + GhcDiagnosticCode "TcRnExportedModNotImported" = 90973 + GhcDiagnosticCode "TcRnNullExportedModule" = 64649 + GhcDiagnosticCode "TcRnMissingExportList" = 85401 + GhcDiagnosticCode "TcRnExportHiddenComponents" = 94558 + GhcDiagnosticCode "TcRnDuplicateExport" = 47854 + GhcDiagnosticCode "TcRnExportedParentChildMismatch" = 88993 + GhcDiagnosticCode "TcRnConflictingExports" = 69158 + GhcDiagnosticCode "TcRnAmbiguousField" = 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 "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 + GhcDiagnosticCode "TcRnGADTMonoLocalBinds" = 58008 + 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 "TcRnUntickedPromotedThing" = 49957 + GhcDiagnosticCode "TcRnIllegalBuiltinSyntax" = 39716 + GhcDiagnosticCode "TcRnWarnDefaulting" = 18042 + GhcDiagnosticCode "TcRnForeignImportPrimExtNotSet" = 49692 + GhcDiagnosticCode "TcRnForeignImportPrimSafeAnn" = 26133 + GhcDiagnosticCode "TcRnForeignFunctionImportAsValue" = 76251 + GhcDiagnosticCode "TcRnFunPtrImportWithoutAmpersand" = 57989 + GhcDiagnosticCode "TcRnIllegalForeignDeclBackend" = 03355 + 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 "TcRnInvalidReturnKind" = 55233 + GhcDiagnosticCode "TcRnClassKindNotConstraint" = 80768 + GhcDiagnosticCode "TcRnUnpromotableThing" = 88634 + GhcDiagnosticCode "TcRnMatchesHaveDiffNumArgs" = 91938 + GhcDiagnosticCode "TcRnCannotBindScopedTyVarInPatSig" = 46131 + GhcDiagnosticCode "TcRnCannotBindTyVarsInPatBind" = 48361 + GhcDiagnosticCode "TcRnTooManyTyArgsInConPattern" = 01629 + GhcDiagnosticCode "TcRnMultipleInlinePragmas" = 96665 + GhcDiagnosticCode "TcRnUnexpectedPragmas" = 88293 + GhcDiagnosticCode "TcRnNonOverloadedSpecialisePragma" = 35827 + GhcDiagnosticCode "TcRnSpecialiseNotVisible" = 85337 + GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl" = 50649 + GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote" = 40027 + GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn" = 69639 + + GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods" = 93006 + 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 + + -- IllegalNewtypeReason + GhcDiagnosticCode "DoesNotHaveSingleField" = 23517 + GhcDiagnosticCode "IsNonLinear" = 38291 + GhcDiagnosticCode "IsGADT" = 89498 + GhcDiagnosticCode "HasConstructorContext" = 17440 + GhcDiagnosticCode "HasExistentialTyVar" = 07525 + GhcDiagnosticCode "HasStrictnessAnnotation" = 04049 + + -- TcRnPragmaWarning + GhcDiagnosticCode "WarningTxt" = 63394 + GhcDiagnosticCode "DeprecatedTxt" = 68441 + + -- TcRnRunSliceFailure/ConversionFail + GhcDiagnosticCode "IllegalOccName" = 55017 + GhcDiagnosticCode "SumAltArityExceeded" = 68444 + GhcDiagnosticCode "IllegalSumAlt" = 63966 + GhcDiagnosticCode "IllegalSumArity" = 97721 + GhcDiagnosticCode "MalformedType" = 28709 + GhcDiagnosticCode "IllegalLastStatement" = 47373 + GhcDiagnosticCode "KindSigsOnlyAllowedOnGADTs" = 40746 + GhcDiagnosticCode "IllegalDeclaration" = 23882 + GhcDiagnosticCode "CannotMixGADTConsWith98Cons" = 24104 + GhcDiagnosticCode "EmptyStmtListInDoBlock" = 34949 + GhcDiagnosticCode "NonVarInInfixExpr" = 99831 + GhcDiagnosticCode "MultiWayIfWithoutAlts" = 63930 + GhcDiagnosticCode "CasesExprWithoutAlts" = 91745 + GhcDiagnosticCode "ImplicitParamsWithOtherBinds" = 42974 + GhcDiagnosticCode "InvalidCCallImpent" = 60220 + GhcDiagnosticCode "RecGadtNoCons" = 18816 + GhcDiagnosticCode "GadtNoCons" = 38140 + GhcDiagnosticCode "InvalidTypeInstanceHeader" = 37056 + GhcDiagnosticCode "InvalidTyFamInstLHS" = 78486 + GhcDiagnosticCode "InvalidImplicitParamBinding" = 51603 + GhcDiagnosticCode "DefaultDataInstDecl" = 39639 + GhcDiagnosticCode "FunBindLacksEquations" = 52078 + + -- Diagnostic codes for the foreign function interface + GhcDiagnosticCode "NotADataType" = 31136 + GhcDiagnosticCode "NewtypeDataConNotInScope" = 72317 + GhcDiagnosticCode "UnliftedFFITypesNeeded" = 10964 + GhcDiagnosticCode "NotABoxedMarshalableTyCon" = 89401 + GhcDiagnosticCode "ForeignLabelNotAPtr" = 26070 + GhcDiagnosticCode "NotSimpleUnliftedType" = 43510 + GhcDiagnosticCode "NotBoxedKindAny" = 64097 + GhcDiagnosticCode "ForeignDynNotPtr" = 27555 + GhcDiagnosticCode "SafeHaskellMustBeInIO" = 57638 + GhcDiagnosticCode "IOResultExpected" = 41843 + GhcDiagnosticCode "UnexpectedNestedForall" = 92994 + GhcDiagnosticCode "LinearTypesNotAllowed" = 57396 + GhcDiagnosticCode "OneArgExpected" = 91490 + GhcDiagnosticCode "AtLeastOneArgExpected" = 07641 + + -- Out of scope errors + GhcDiagnosticCode "NotInScope" = 76037 + GhcDiagnosticCode "NoExactName" = 97784 + GhcDiagnosticCode "SameName" = 81573 + GhcDiagnosticCode "MissingBinding" = 44432 + GhcDiagnosticCode "NoTopLevelBinding" = 10173 + GhcDiagnosticCode "UnknownSubordinate" = 54721 + + -- Diagnostic codes for deriving + GhcDiagnosticCode "DerivErrNotWellKinded" = 62016 + GhcDiagnosticCode "DerivErrSafeHaskellGenericInst" = 07214 + GhcDiagnosticCode "DerivErrDerivingViaWrongKind" = 63174 + GhcDiagnosticCode "DerivErrNoEtaReduce" = 38996 + GhcDiagnosticCode "DerivErrBootFileFound" = 30903 + GhcDiagnosticCode "DerivErrDataConsNotAllInScope" = 54540 + GhcDiagnosticCode "DerivErrGNDUsedOnData" = 10333 + GhcDiagnosticCode "DerivErrNullaryClasses" = 04956 + GhcDiagnosticCode "DerivErrLastArgMustBeApp" = 28323 + GhcDiagnosticCode "DerivErrNoFamilyInstance" = 82614 + GhcDiagnosticCode "DerivErrNotStockDeriveable" = 00158 + GhcDiagnosticCode "DerivErrHasAssociatedDatatypes" = 34611 + GhcDiagnosticCode "DerivErrNewtypeNonDeriveableClass" = 82023 + GhcDiagnosticCode "DerivErrCannotEtaReduceEnough" = 26557 + GhcDiagnosticCode "DerivErrOnlyAnyClassDeriveable" = 23244 + GhcDiagnosticCode "DerivErrNotDeriveable" = 38178 + GhcDiagnosticCode "DerivErrNotAClass" = 63388 + GhcDiagnosticCode "DerivErrNoConstructors" = 64560 + GhcDiagnosticCode "DerivErrLangExtRequired" = 86639 + GhcDiagnosticCode "DerivErrDunnoHowToDeriveForType" = 48959 + GhcDiagnosticCode "DerivErrMustBeEnumType" = 30750 + GhcDiagnosticCode "DerivErrMustHaveExactlyOneConstructor" = 37542 + GhcDiagnosticCode "DerivErrMustHaveSomeParameters" = 45539 + GhcDiagnosticCode "DerivErrMustNotHaveClassContext" = 16588 + GhcDiagnosticCode "DerivErrBadConstructor" = 16437 + GhcDiagnosticCode "DerivErrGenerics" = 30367 + GhcDiagnosticCode "DerivErrEnumOrProduct" = 58291 + + -- TcRnEmptyStmtsGroupError/EmptyStatementGroupErrReason + GhcDiagnosticCode "EmptyStmtsGroupInParallelComp" = 41242 + GhcDiagnosticCode "EmptyStmtsGroupInTransformListComp" = 92693 + GhcDiagnosticCode "EmptyStmtsGroupInDoNotation" = 82311 + GhcDiagnosticCode "EmptyStmtsGroupInArrowNotation" = 19442 + + -- 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. + + GhcDiagnosticCode "Example outdated error" = 00000 + +{- ********************************************************************* +* * + Recurring into an argument +* * +********************************************************************* -} + +-- | Some constructors of diagnostic datatypes don't have +-- corresponding error codes, because we recur inside them. +-- +-- For example, we don't have an error code for the +-- 'TcRnCannotDeriveInstance' constructor of 'TcRnMessage', +-- because we recur into the 'DeriveInstanceErrReason' to obtain +-- an error code. +-- +-- This type family keeps track of such constructors. +type ConRecursInto :: Symbol -> Maybe Type +type family ConRecursInto con where + + ---------------------------------- + -- Constructors of GhcMessage + + ConRecursInto "GhcDriverMessage" = 'Just DriverMessage + ConRecursInto "GhcPsMessage" = 'Just PsMessage + ConRecursInto "GhcTcRnMessage" = 'Just TcRnMessage + ConRecursInto "GhcDsMessage" = 'Just DsMessage + ConRecursInto "GhcUnknownMessage" = 'Just UnknownDiagnostic + + ---------------------------------- + -- Constructors of DriverMessage + + ConRecursInto "DriverUnknownMessage" = 'Just UnknownDiagnostic + ConRecursInto "DriverPsHeaderMessage" = 'Just PsMessage + + ---------------------------------- + -- Constructors of PsMessage + + ConRecursInto "PsUnknownMessage" = 'Just UnknownDiagnostic + ConRecursInto "PsHeaderMessage" = 'Just PsHeaderMessage + + ---------------------------------- + -- Constructors of TcRnMessage + + ConRecursInto "TcRnUnknownMessage" = 'Just UnknownDiagnostic + + -- Recur into TcRnMessageWithInfo to get the underlying TcRnMessage + ConRecursInto "TcRnMessageWithInfo" = 'Just TcRnMessageDetailed + ConRecursInto "TcRnMessageDetailed" = 'Just TcRnMessage + ConRecursInto "TcRnWithHsDocContext" = 'Just TcRnMessage + + ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason + ConRecursInto "TcRnPragmaWarning" = 'Just (WarningTxt GhcRn) + ConRecursInto "TcRnNotInScope" = 'Just NotInScopeError + ConRecursInto "TcRnIllegalNewtype" = 'Just IllegalNewtypeReason + + -- + -- TH errors + + ConRecursInto "TcRnRunSpliceFailure" = 'Just RunSpliceFailReason + ConRecursInto "ConversionFail" = 'Just ConversionFailReason + + ------------------ + -- FFI errors + + ConRecursInto "TcRnIllegalForeignType" = 'Just IllegalForeignTypeReason + -- IllegalForeignTypeReason: recur into TypeCannotBeMarshaled for the reason + ConRecursInto "TypeCannotBeMarshaled" = 'Just TypeCannotBeMarshaledReason + + ------------------ + -- Solver reports + + -- Recur inside TcRnSolverReport to get the underlying TcSolverReportMsg + ConRecursInto "TcRnSolverReport" = 'Just SolverReportWithCtxt + ConRecursInto "SolverReportWithCtxt" = 'Just TcSolverReportMsg + ConRecursInto "TcReportWithInfo" = 'Just TcSolverReportMsg + + -- Recur inside CannotUnifyVariable to get the underlying reason + ConRecursInto "CannotUnifyVariable" = 'Just CannotUnifyVariableReason + + -- Recur inside Mismatch to get the underlying reason + ConRecursInto "Mismatch" = 'Just MismatchMsg + + -- Recur inside empty statements groups to get the underlying statements block + ConRecursInto "TcRnEmptyStmtsGroup" = 'Just EmptyStatementGroupErrReason + ---------------------------------- + -- Constructors of DsMessage + + ConRecursInto "DsUnknownMessage" = 'Just UnknownDiagnostic + + ---------------------------------- + -- Any other constructors: don't recur, instead directly + -- use the constructor name for the error code. + + ConRecursInto _ = 'Nothing + +{- ********************************************************************* +* * + Generics machinery +* * +********************************************************************* -} + +{- Note [Diagnostic codes using generics] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Diagnostic codes 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). + +Using this type family, we need to obtain corresponding value-level +functions, e.g. + + diagnosticCode :: TcRnMessage -> DiagnosticCode + diagnosticCode diag = case diag of + TcRnInaccessibleCode {} -> ghcDiagnosticCode 40564 + TcRnTypeDoesNotHaveFixedRuntimeRep {} -> ghcDiagnosticCode 18478 + TcRnCannotDeriveInstance _ _ _ _ reason -> + case reason of + DerivErrNotWellKinded {} -> ghcDiagnosticCode 62016 + DerivErrNotAClass {} -> ghcDiagnosticCode 63388 + ... + ... + +For some constructors, such as 'TcRnInaccessibleCode', we directly get a +diagnostic code, using the 'GhcDiagnosticCode' type family. For other +constructors, such as 'TcRnCannotDeriveInstance', we instead recur into an +argument (in this case 'DeriveInstanceErrReason') to obtain a diagnostic code. + +To achieve this, we use a variant of the 'typed' lens from 'generic-lens' +(we only need a getter, not a setter): + + - Using GHC.Generics, we obtain the type-level structure + of diagnostic types, as sums of products, with extra metadata. + - The 'ConRecursInto' type family declares when we should + recur into an argument of the constructor instead of using + the constructor name itself for the diagnostic code. + - To decide whether to recur, in the generic representation, + we must look at all factors of a product to see if there is + a type we should recur into. We look at the left branch + 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: + + ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason + + In this case, for the constructor 'TcRnCannotDeriveInstance', we recur into the + 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. +-- +-- See Note [Diagnostic codes using generics] in GHC.Types.Error.Codes. +type GDiagnosticCode :: (Type -> Type) -> Constraint +class GDiagnosticCode f where + gdiagnosticCode :: f a -> Maybe DiagnosticCode + +type ConstructorCode :: Symbol -> (Type -> Type) -> Maybe Type -> Constraint +class ConstructorCode 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# + +-- 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 + +-- (*) 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) + +-- (**) 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 + +-- 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 + +-- 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 + +-- | Decide whether to pick the left or right branch +-- when deciding how to recurse into a product. +type family HasTypeQ (ty :: Type) f :: Maybe Type where + HasTypeQ typ (M1 _ _ (K1 _ typ)) + = 'Just typ + HasTypeQ typ (M1 _ _ x) + = HasTypeQ typ x + HasTypeQ typ (l :*: r) + = Alt (HasTypeQ typ l) (HasTypeQ typ r) + HasTypeQ typ (l :+: r) + = Both (HasTypeQ typ l) (HasTypeQ typ r) + HasTypeQ typ (K1 _ _) + = 'Nothing + HasTypeQ typ U1 + = 'Nothing + HasTypeQ typ V1 + = 'Nothing + +type family Both (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where + Both ('Just a) ('Just a) = 'Just a + +type family Alt (m1 :: Maybe a) (m2 :: Maybe a) :: Maybe a where + Alt ('Just a) _ = 'Just a + Alt _ b = b + +type HasType :: Type -> Symbol -> (Type -> Type) -> Constraint +class HasType ty orig f where + getType :: f a -> ty + +instance HasType 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 + +-- 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 + 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 + +-- Pick the right branch. +instance HasType ty orig g => HasTypeProd ty 'Nothing orig f g where + getTypeProd (_ :*: y) = getType @ty @orig @g y + +{- ********************************************************************* +* * + Custom type errors for diagnostic codes +* * +********************************************************************* -} + +-- (ERR1) Improve error messages for recurring into an argument. +instance {-# OVERLAPPABLE #-} + TypeError + ( 'Text "The constructor '" ':<>: 'Text orig ':<>: 'Text "'" + ':$$: '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 + getType = panic "getType: unreachable" + +-- (ERR2) Improve error messages for missing 'GhcDiagnosticCode' equations. +type KnownConstructor :: Symbol -> Constraint +type family KnownConstructor con where + KnownConstructor con = + KnownNatOrErr + ( TypeError + ( 'Text "Missing 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) + +type KnownNatOrErr :: Constraint -> Nat -> Constraint +type KnownNatOrErr err n = (Assert err n, KnownNat n) + +-- Detecting a stuck type family using a data family. +-- See https://blog.csongor.co.uk/report-stuck-families/. +type Assert :: Constraint -> k -> Constraint +type family Assert err n where + Assert _ Dummy = Dummy + Assert _ n = () +data family Dummy :: k diff --git a/GHC/Types/FieldLabel.hs b/GHC/Types/FieldLabel.hs --- a/GHC/Types/FieldLabel.hs +++ b/GHC/Types/FieldLabel.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable FieldLabelString {- % @@ -71,8 +72,7 @@ -} module GHC.Types.FieldLabel - ( FieldLabelString - , FieldLabelEnv + ( FieldLabelEnv , FieldLabel(..) , fieldSelectorOccName , fieldLabelPrintableName @@ -89,16 +89,16 @@ import GHC.Data.FastString import GHC.Data.FastString.Env +import GHC.Types.Unique (Uniquable(..)) import GHC.Utils.Outputable import GHC.Utils.Binary +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) + +import Control.DeepSeq import Data.Bool import Data.Data --- | Field labels are just represented as strings; --- they are not necessarily unique (even within a module) -type FieldLabelString = FastString - -- | A map from labels to all the auxiliary information type FieldLabelEnv = DFastStringEnv FieldLabel @@ -117,13 +117,22 @@ deriving (Data, Eq) instance HasOccName FieldLabel where - occName = mkVarOccFS . flLabel + occName = mkVarOccFS . field_label . flLabel instance Outputable FieldLabel where ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl)) <> ppr (flHasDuplicateRecordFields fl) <> ppr (flHasFieldSelector fl)) +instance Outputable FieldLabelString where + ppr (FieldLabelString l) = ppr l + +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 @@ -138,6 +147,8 @@ ppr DuplicateRecordFields = text "+dup" ppr NoDuplicateRecordFields = text "-dup" +instance NFData DuplicateRecordFields where + rnf x = x `seq` () -- | Flag to indicate whether the FieldSelectors extension is enabled. data FieldSelectors @@ -153,6 +164,8 @@ ppr FieldSelectors = text "+sel" ppr NoFieldSelectors = text "-sel" +instance NFData FieldSelectors where + rnf x = x `seq` () -- | 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 @@ -160,7 +173,7 @@ -- 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 aa + put_ bh (field_label aa) put_ bh ab put_ bh ac put_ bh ad @@ -169,7 +182,7 @@ ab <- get bh ac <- get bh ad <- get bh - return (FieldLabel aa ab ac ad) + return (FieldLabel (FieldLabelString aa) ab ac ad) -- | Record selector OccNames are built from the underlying field name @@ -179,9 +192,10 @@ fieldSelectorOccName :: FieldLabelString -> OccName -> DuplicateRecordFields -> FieldSelectors -> OccName fieldSelectorOccName lbl dc dup_fields_ok has_sel | shouldMangleSelectorNames dup_fields_ok has_sel = mkRecFldSelOcc str - | otherwise = mkVarOccFS lbl + | otherwise = mkVarOccFS fl where - str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc + 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 @@ -189,7 +203,7 @@ -- need to qualify it with a module prefix. fieldLabelPrintableName :: FieldLabel -> Name fieldLabelPrintableName fl - | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (flLabel fl)) + | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (field_label $ flLabel fl)) | otherwise = flSelector fl -- | Selector name mangling should be used if either DuplicateRecordFields or diff --git a/GHC/Types/ForeignCall.hs b/GHC/Types/ForeignCall.hs --- a/GHC/Types/ForeignCall.hs +++ b/GHC/Types/ForeignCall.hs @@ -153,7 +153,7 @@ See: http://www.programmersheaven.com/2/Calling-conventions -} --- any changes here should be replicated in the CallConv type in template haskell +-- any changes here should be replicated in the Callconv type in template haskell data CCallConv = CCallConv | CApiConv @@ -219,8 +219,8 @@ | otherwise = text "_unsafe" ppr_fun (StaticTarget st lbl mPkgId isFun) - = text (if isFun then "__ffi_static_ccall" - else "__ffi_static_ccall_value") + = (if isFun then text "__ffi_static_ccall" + else text "__ffi_static_ccall_value") <> gc_suf <+> (case mPkgId of Nothing -> empty diff --git a/GHC/Types/ForeignStubs.hs b/GHC/Types/ForeignStubs.hs --- a/GHC/Types/ForeignStubs.hs +++ b/GHC/Types/ForeignStubs.hs @@ -1,5 +1,6 @@ -- | Foreign export stubs {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE TypeApplications #-} module GHC.Types.ForeignStubs ( ForeignStubs (..) , CHeader(..) @@ -44,7 +45,7 @@ where body' = vcat [ declarations - , hsep [text "void", pprCLabel platform CStyle clbl, text "(void)"] + , hsep [text "void", pprCLabel platform clbl, text "(void)"] , braces body ] @@ -68,10 +69,10 @@ instance Monoid CHeader where mempty = CHeader empty - mconcat = coerce vcat + mconcat = coerce (vcat @SDoc) instance Semigroup CHeader where - (<>) = coerce ($$) + (<>) = coerce (($$) @SDoc) -- | Foreign export stubs data ForeignStubs diff --git a/GHC/Types/Hint.hs b/GHC/Types/Hint.hs --- a/GHC/Types/Hint.hs +++ b/GHC/Types/Hint.hs @@ -31,11 +31,13 @@ import GHC.Unit.Module (ModuleName, Module) import GHC.Hs.Extension (GhcTc) import GHC.Core.Coercion +import GHC.Core.Type (PredType) 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) @@ -63,7 +65,7 @@ -- it's totally irrelevant/redundant for IDEs and other tools. SuggestSingleExtension !SDoc !LangExt.Extension -- | Suggest to enable the input extensions. The list - -- is to be intended as /disjuctive/ i.e. the user is + -- is to be intended as /disjunctive/ i.e. the user is -- suggested to enable /any/ of the extensions listed. If -- the input 'SDoc' is not empty, it will contain some extra -- information about the why the extensions are required, but @@ -136,6 +138,14 @@ -} | SuggestExtension !LanguageExtensionHint + {-| Suggests possible corrections of a misspelled pragma. Its argument + represents all applicable suggestions. + + Example: {-# LNGUAGE BangPatterns #-} + + Test case(s): parser/should_compile/T21589 + -} + | SuggestCorrectPragmaName ![String] {-| Suggests that a monadic code block is probably missing a \"do\" keyword. Example: @@ -393,11 +403,24 @@ Test cases: ccfail004 -} | SuggestImportingDataCon - {- 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 + + Test cases: patsyn/should_fail/record-exquant + typecheck/should_fail/T3176 + -} + | SuggestPatternMatchingSyntax + {-| Suggest tips for making a definition visible for the purpose of writing + a SPECIALISE pragma for it in a different module. + + Test cases: none + -} + | SuggestSpecialiseVisibilityHints Name + + | LoopySuperclassSolveHint PredType ClsInstOrQC -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way 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 @@ -13,8 +13,9 @@ import GHC.Types.Hint 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) +import GHC.Types.Name (NameSpace, pprDefinedAt, occNameSpace, pprNameSpace, isValNameSpace, nameModule) import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace) import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine) import GHC.Unit.Module.Imported (ImportedModsVal(..)) @@ -40,6 +41,8 @@ in header <+> hcat (intersperse (text ", ") (map ppr exts)) $$ extraUserInfo SuggestExtensionInOrderTo extraUserInfo ext -> (text "Use" <+> ppr ext) $$ extraUserInfo + SuggestCorrectPragmaName suggestions + -> text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) SuggestMissingDo -> text "Possibly caused by a missing 'do'?" SuggestLetInDo @@ -197,6 +200,21 @@ 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" + SuggestPatternMatchingSyntax + -> text "Use pattern-matching syntax instead" + SuggestSpecialiseVisibilityHints name + -> text "Make sure" <+> ppr mod <+> text "is compiled with -O and that" + <+> 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" perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" diff --git a/GHC/Types/Id.hs b/GHC/Types/Id.hs --- a/GHC/Types/Id.hs +++ b/GHC/Types/Id.hs @@ -86,21 +86,20 @@ idInlineActivation, setInlineActivation, idRuleMatchInfo, -- ** One-shot lambdas - isOneShotBndr, isProbablyOneShotLambda, setOneShotLambda, clearOneShotLambda, updOneShotInfo, setIdOneShotInfo, - isStateHackType, stateHackOneShot, typeOneShot, -- ** Reading 'IdInfo' fields idArity, idCallArity, idFunRepArity, - idUnfolding, realIdUnfolding, idSpecialisation, idCoreRules, idHasRules, idCafInfo, idLFInfo_maybe, - idOneShotInfo, idStateHackOneShotInfo, + idOneShotInfo, idOccInfo, - isNeverRepPolyId, + IdUnfoldingFun, idUnfolding, realIdUnfolding, + alwaysActiveUnfoldingFun, whenActiveUnfoldingFun, noUnfoldingFun, + -- ** Writing 'IdInfo' fields setIdUnfolding, zapIdUnfolding, setCaseBndrEvald, setIdArity, @@ -129,8 +128,9 @@ import GHC.Prelude -import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding, - isCompulsoryUnfolding, Unfolding( NoUnfolding ), isEvaldUnfolding, hasSomeUnfolding, noUnfolding ) +import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding + , isCompulsoryUnfolding, Unfolding( NoUnfolding ) + , IdUnfoldingFun, isEvaldUnfolding, hasSomeUnfolding, noUnfolding ) import GHC.Types.Id.Info import GHC.Types.Basic @@ -146,7 +146,6 @@ import GHC.Core.Type import GHC.Types.RepType -import GHC.Builtin.Types.Prim import GHC.Core.DataCon import GHC.Types.Demand import GHC.Types.Cpr @@ -167,8 +166,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.GlobalVars -import GHC.Utils.Trace import GHC.Stg.InferTags.TagSig -- infixl so you can say (id `set` a `set` b) @@ -315,7 +312,7 @@ mkLocalCoVar :: Name -> Type -> CoVar mkLocalCoVar name ty = assert (isCoVarType ty) $ - Var.mkLocalVar CoVarId name Many ty vanillaIdInfo + 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 @@ -383,7 +380,7 @@ -- | Workers get local names. "CoreTidy" will externalise these if necessary mkWorkerId :: Unique -> Id -> Type -> Id mkWorkerId uniq unwrkr ty - = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) Many ty + = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ManyTy ty -- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings mkTemplateLocal :: Int -> Type -> Id @@ -502,16 +499,16 @@ _other -> Nothing isPrimOpId id = case Var.idDetails id of - PrimOpId _ -> True - _ -> False + PrimOpId {} -> True + _ -> False isDFunId id = case Var.idDetails id of DFunId {} -> True _ -> False isPrimOpId_maybe id = case Var.idDetails id of - PrimOpId op -> Just op - _ -> Nothing + PrimOpId op _ -> Just op + _ -> Nothing isFCallId id = case Var.idDetails id of FCallId _ -> True @@ -586,7 +583,12 @@ -- exception to this is unboxed tuples and sums datacons, which definitely have -- no binding hasNoBinding id = case Var.idDetails id of - PrimOpId _ -> True -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps + +-- TEMPORARILY make all primops hasNoBinding, to avoid #20155 +-- The goal is to understand #20155 and revert to the commented out version + PrimOpId _ _ -> True -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps +-- PrimOpId _ lev_poly -> lev_poly -- TEMPORARILY commented out + FCallId _ -> True DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc _ -> isCompulsoryUnfolding (realIdUnfolding id) @@ -695,8 +697,6 @@ setIdCallArity :: Id -> Arity -> Id setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id --- | This function counts all arguments post-unarisation, which includes --- arguments with no runtime representation -- see Note [Unarisation and arity] idFunRepArity :: Id -> RepArity idFunRepArity x = countFunRepArgs (idArity x) (idType x) @@ -747,9 +747,28 @@ -- loop breaker. See 'unfoldingInfo'. -- -- If you really want the unfolding of a strong loopbreaker, call 'realIdUnfolding'. -idUnfolding :: Id -> Unfolding +idUnfolding :: IdUnfoldingFun idUnfolding id = unfoldingInfo (idInfo id) +noUnfoldingFun :: IdUnfoldingFun +noUnfoldingFun _id = noUnfolding + +-- | Returns an unfolding only if +-- (a) not a strong loop breaker and +-- (b) always active +alwaysActiveUnfoldingFun :: IdUnfoldingFun +alwaysActiveUnfoldingFun id + | isAlwaysActive (idInlineActivation id) = idUnfolding id + | otherwise = noUnfolding + +-- | Returns an unfolding only if +-- (a) not a strong loop breaker and +-- (b) active in according to is_active +whenActiveUnfoldingFun :: (Activation -> Bool) -> IdUnfoldingFun +whenActiveUnfoldingFun is_active id + | is_active (idInlineActivation id) = idUnfolding id + | otherwise = NoUnfolding + realIdUnfolding :: Id -> Unfolding -- ^ Expose the unfolding if there is one, including for loop breakers realIdUnfolding id = realUnfoldingInfo (idInfo id) @@ -922,64 +941,6 @@ idOneShotInfo :: Id -> OneShotInfo idOneShotInfo id = oneShotInfo (idInfo id) --- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account --- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" -idStateHackOneShotInfo :: Id -> OneShotInfo -idStateHackOneShotInfo id - | isStateHackType (idType id) = stateHackOneShot - | otherwise = idOneShotInfo id - --- | Returns whether the lambda associated with the 'Id' is certainly applied at most once --- This one is the "business end", called externally. --- It works on type variables as well as Ids, returning True --- Its main purpose is to encapsulate the Horrible State Hack --- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity" -isOneShotBndr :: Var -> Bool -isOneShotBndr var - | isTyVar var = True - | OneShotLam <- idStateHackOneShotInfo var = True - | otherwise = False - --- | Should we apply the state hack to values of this 'Type'? -stateHackOneShot :: OneShotInfo -stateHackOneShot = OneShotLam - -typeOneShot :: Type -> OneShotInfo -typeOneShot ty - | isStateHackType ty = stateHackOneShot - | otherwise = NoOneShotInfo - -isStateHackType :: Type -> Bool -isStateHackType ty - | unsafeHasNoStateHack - = False - | otherwise - = case tyConAppTyCon_maybe ty of - Just tycon -> tycon == statePrimTyCon - _ -> False - -- This is a gross hack. It claims that - -- every function over realWorldStatePrimTy is a one-shot - -- function. This is pretty true in practice, and makes a big - -- difference. For example, consider - -- a `thenST` \ r -> ...E... - -- The early full laziness pass, if it doesn't know that r is one-shot - -- will pull out E (let's say it doesn't mention r) to give - -- let lvl = E in a `thenST` \ r -> ...lvl... - -- When `thenST` gets inlined, we end up with - -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... - -- and we don't re-inline E. - -- - -- It would be better to spot that r was one-shot to start with, but - -- I don't want to rely on that. - -- - -- Another good example is in fill_in in PrelPack.hs. We should be able to - -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. - -isProbablyOneShotLambda :: Id -> Bool -isProbablyOneShotLambda id = case idStateHackOneShotInfo id of - OneShotLam -> True - NoOneShotInfo -> False - setOneShotLambda :: Id -> Id setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id @@ -1105,6 +1066,7 @@ old_strictness = dmdSigInfo old_info new_strictness = prependArgsDmdSig arity_increase old_strictness old_cpr = cprSigInfo old_info + new_cpr = prependArgsCprSig arity_increase old_cpr old_cbv_marks = fromMaybe (replicate old_arity NotMarkedCbv) (idCbvMarks_maybe old_id) abstr_cbv_marks = mapMaybe getMark abstract_wrt @@ -1118,11 +1080,8 @@ , mightBeLiftedType (idType v) = Just MarkedCbv | otherwise = Just NotMarkedCbv - transfer new_info = new_info `setArityInfo` new_arity + transfer new_info = new_info `setArityInfo` new_arity `setInlinePragInfo` old_inline_prag - `setOccInfo` new_occ_info - `setDmdSigInfo` new_strictness - `setCprSigInfo` old_cpr - -isNeverRepPolyId :: Id -> Bool -isNeverRepPolyId = isNeverRepPolyIdInfo . idInfo + `setOccInfo` new_occ_info + `setDmdSigInfo` new_strictness + `setCprSigInfo` new_cpr 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 @@ -83,10 +83,6 @@ -- ** Tick-box Info TickBoxOp(..), TickBoxId, - - -- ** Levity info - LevityInfo, levityInfo, setNeverRepPoly, setLevityInfoWithType, - isNeverRepPolyIdInfo ) where import GHC.Prelude @@ -100,13 +96,11 @@ import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.PatSyn -import GHC.Core.Type import GHC.Types.ForeignCall import GHC.Unit.Module import GHC.Types.Demand import GHC.Types.Cpr -import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain @@ -126,9 +120,7 @@ `setCafInfo`, `setDmdSigInfo`, `setCprSigInfo`, - `setDemandInfo`, - `setNeverRepPoly`, - `setLevityInfoWithType` + `setDemandInfo` {- ************************************************************************ * * @@ -161,7 +153,11 @@ | ClassOpId Class -- ^ The 'Id' is a superclass selector, -- or class operation of a class - | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator + | 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 + | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. -- Type will be simple: no type families, newtypes, etc @@ -259,7 +255,7 @@ and if no arguments are visible requires us to eta-expand it's call site. That is for a binding with three cbv arguments like `w[WorkerLikeId[!,!,!]]` we would need to eta expand undersaturated -occurences like `map w xs` into `map (\x1 x2 x3 -> w x1 x2 x3) xs. +occurrences like `map w xs` into `map (\x1 x2 x3 -> w x1 x2 x3) xs. In experiments it turned out that the code size increase of doing so can outweigh the performance benefits of doing so. @@ -269,7 +265,7 @@ this problem can't occur for them. For workers and specialized functions there are also always at least some applied arguments as we won't inline the wrapper/apply their rule -if there are unapplied occurances like `map f xs`. +if there are unapplied occurrences like `map f xs`. -} -- | Recursive Selector Parent @@ -310,7 +306,7 @@ pp (DataConWorkId _) = text "DataCon" pp (DataConWrapId _) = text "DataConWrapper" pp (ClassOpId {}) = text "ClassOp" - pp (PrimOpId _) = text "PrimOp" + pp (PrimOpId {}) = text "PrimOp" pp (FCallId _) = text "ForeignCall" pp (TickBoxOpId _) = text "TickBoxOp" pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") @@ -357,33 +353,33 @@ occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program dmdSigInfo :: DmdSig, - -- ^ A strictness signature. Digests how a function uses its arguments - -- if applied to at least 'arityInfo' arguments. + -- ^ A strictness signature. Describes how a function uses its arguments + -- See Note [idArity varies independently of dmdTypeDepth] + -- in GHC.Core.Opt.DmdAnal cprSigInfo :: CprSig, -- ^ Information on whether the function will ultimately return a -- freshly allocated constructor. demandInfo :: Demand, -- ^ ID demand information bitfield :: {-# UNPACK #-} !BitField, - -- ^ Bitfield packs CafInfo, OneShotInfo, arity info, LevityInfo, and + -- ^ Bitfield packs CafInfo, OneShotInfo, arity info, and -- call arity info in one 64-bit word. Packing these fields reduces size -- of `IdInfo` from 12 words to 7 words and reduces residency by almost -- 4% in some programs. See #17497 and associated MR. -- -- 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 -- See documentation of the getters for what these packed fields mean. tagSig :: !(Maybe TagSig) } --- | Encodes arities, OneShotInfo, CafInfo and LevityInfo. +-- | Encodes arities, OneShotInfo, CafInfo. -- From least-significant to most-significant bits: -- -- - Bit 0 (1): OneShotInfo -- - Bit 1 (1): CafInfo --- - Bit 2 (1): LevityInfo +-- - Bit 2 (1): unused -- - Bits 3-32(30): Call Arity info -- - Bits 33-62(30): Arity info -- @@ -400,10 +396,6 @@ bitfieldGetCafInfo (BitField bits) = if testBit bits 1 then NoCafRefs else MayHaveCafRefs -bitfieldGetLevityInfo :: BitField -> LevityInfo -bitfieldGetLevityInfo (BitField bits) = - if testBit bits 2 then NeverLevityPolymorphic else NoLevityInfo - bitfieldGetCallArityInfo :: BitField -> ArityInfo bitfieldGetCallArityInfo (BitField bits) = fromIntegral (bits `shiftR` 3) .&. ((1 `shiftL` 30) - 1) @@ -424,12 +416,6 @@ MayHaveCafRefs -> BitField (clearBit bits 1) NoCafRefs -> BitField (setBit bits 1) -bitfieldSetLevityInfo :: LevityInfo -> BitField -> BitField -bitfieldSetLevityInfo info (BitField bits) = - case info of - NoLevityInfo -> BitField (clearBit bits 2) - NeverLevityPolymorphic -> BitField (setBit bits 2) - bitfieldSetCallArityInfo :: ArityInfo -> BitField -> BitField bitfieldSetCallArityInfo info bf@(BitField bits) = assert (info < 2^(30 :: Int) - 1) $ @@ -443,16 +429,12 @@ -- Getters --- | When applied, will this Id ever have a representation-polymorphic type? -levityInfo :: IdInfo -> LevityInfo -levityInfo = bitfieldGetLevityInfo . bitfield - -- | Info about a lambda-bound variable, if the 'Id' is one oneShotInfo :: IdInfo -> OneShotInfo oneShotInfo = bitfieldGetOneShotInfo . bitfield -- | 'Id' arity, as computed by "GHC.Core.Opt.Arity". Specifies how many arguments --- this 'Id' has to be applied to before it does any meaningful work. +-- this 'Id' has to be applied to before it doesn any meaningful work. arityInfo :: IdInfo -> ArityInfo arityInfo = bitfieldGetArityInfo . bitfield @@ -487,7 +469,7 @@ unfoldingInfo :: IdInfo -> Unfolding unfoldingInfo info | isStrongLoopBreaker (occInfo info) = trimUnfolding $ realUnfoldingInfo info - | otherwise = realUnfoldingInfo info + | otherwise = realUnfoldingInfo info setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo setUnfoldingInfo info uf @@ -549,7 +531,6 @@ bitfieldSetArityInfo unknownArity $ bitfieldSetCallArityInfo unknownArity $ bitfieldSetOneShotInfo NoOneShotInfo $ - bitfieldSetLevityInfo NoLevityInfo $ emptyBitField, lfInfo = Nothing, tagSig = Nothing @@ -864,55 +845,3 @@ instance Outputable TickBoxOp where ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) - -{- -************************************************************************ -* * - Levity -* * -************************************************************************ - -Note [Levity info] -~~~~~~~~~~~~~~~~~~ - -Ids store whether or not they can be representation-polymorphic at any amount -of saturation. This is helpful in optimizing representation polymorphism checks, -allowing us to learn that something is not representation-polymorphic without -actually figuring out its type. -See exprHasFixedRuntimeRep in GHC.Core.Utils for where this info is used. - -Historical note: this was very important when representation polymorphism -was checked in the desugarer (it was needed to prevent T5631 from blowing up). -It's less important now that the checks happen in the typechecker, but remains useful. -Refer to Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete for details -about the new approach being used. --} - --- See Note [Levity info] -data LevityInfo = NoLevityInfo -- always safe - | NeverLevityPolymorphic - deriving Eq - -instance Outputable LevityInfo where - ppr NoLevityInfo = text "NoLevityInfo" - ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic" - --- | Marks an IdInfo describing an Id that is never representation-polymorphic --- (even when applied). The Type is only there for checking that it's really --- never representation-polymorphic. -setNeverRepPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo -setNeverRepPoly info ty - = assertPpr (resultHasFixedRuntimeRep ty) (ppr ty) $ - info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) } - -setLevityInfoWithType :: IdInfo -> Type -> IdInfo -setLevityInfoWithType info ty - | resultHasFixedRuntimeRep ty - = info { bitfield = bitfieldSetLevityInfo NeverLevityPolymorphic (bitfield info) } - | otherwise - = info - -isNeverRepPolyIdInfo :: IdInfo -> Bool -isNeverRepPolyIdInfo info - | NeverLevityPolymorphic <- levityInfo info = True - | otherwise = False 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 @@ -17,7 +17,7 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Types.Id.Make ( - mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, + mkDictFunId, mkDictSelId, mkDictSelRhs, mkFCallId, @@ -25,6 +25,7 @@ DataConBoxer(..), vanillaDataConBoxer, mkDataConRep, mkDataConWorkId, DataConBangOpts (..), BangOpts (..), + unboxedUnitExpr, -- And some particular Ids; see below for why they are wired in wiredInIds, ghcPrimIds, @@ -32,7 +33,10 @@ voidPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, coercionTokenId, coerceId, - proxyHashId, noinlineId, noinlineIdName, + proxyHashId, + nospecId, nospecIdName, + noinlineId, noinlineIdName, + noinlineConstraintId, noinlineConstraintIdName, coerceName, leftSectionName, rightSectionName, ) where @@ -43,6 +47,7 @@ import GHC.Builtin.Names import GHC.Core +import GHC.Core.Opt.Arity( typeOneShot ) import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.TyCo.Rep @@ -51,7 +56,7 @@ import GHC.Core.Reduction import GHC.Core.Make import GHC.Core.FVs ( mkRuleInfo ) -import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase ) +import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, coreAltsType ) import GHC.Core.Unfold.Make import GHC.Core.SimpleOpt import GHC.Core.TyCon @@ -69,7 +74,7 @@ import GHC.Types.Cpr import GHC.Types.Unique.Supply import GHC.Types.Basic hiding ( SuccessFlag(..) ) -import GHC.Types.Var (VarBndr(Bndr)) +import GHC.Types.Var (VarBndr(Bndr), visArgConstraintLike) import GHC.Tc.Utils.TcType as TcType @@ -80,7 +85,7 @@ import GHC.Data.FastString import GHC.Data.List.SetOps - +import Data.List ( zipWith4 ) {- ************************************************************************ @@ -159,7 +164,7 @@ ++ errorIds -- Defined in GHC.Core.Make magicIds :: [Id] -- See Note [magicIds] -magicIds = [lazyId, oneShotId, noinlineId] +magicIds = [lazyId, oneShotId, noinlineId, noinlineConstraintId, nospecId] ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds @@ -307,14 +312,15 @@ Note [Newtype datacons] ~~~~~~~~~~~~~~~~~~~~~~~ -The "data constructor" for a newtype should always be vanilla. At one -point this wasn't true, because the newtype arising from +The "data constructor" for a newtype should have no existentials. It's +not quite a "vanilla" data constructor, because the newtype arising from class C a => D a -looked like - newtype T:D a = D:D (C a) -so the data constructor for T:C had a single argument, namely the -predicate (C a). But now we treat that as an ordinary argument, not -part of the theta-type, so all is well. +looks like + newtype T:D a = C:D (C a) +so the data constructor for T:C has a single argument, namely the +predicate (C a). That ends up in the dcOtherTheta for the data con, +which makes it not vanilla. So the assert just tests for existentials. +The rest is checked by having a singleton arg_tys. Note [Newtype workers] ~~~~~~~~~~~~~~~~~~~~~~ @@ -356,7 +362,7 @@ We'd like 'map Age' to match the LHS. For this to happen, Age must be unfolded, otherwise we'll be stuck. This is tested in T16208. -It also allows for the posssibility of representation-polymorphic newtypes +It also allows for the possibility of representation-polymorphic newtypes with wrappers (with -XUnliftedNewtypes): newtype N (a :: TYPE r) = MkN a @@ -471,20 +477,19 @@ val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name sel_ty = mkInvisForAllTys tyvars $ - mkInvisFunTyMany (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ + mkFunctionType ManyTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ scaledThing (getNth arg_tys val_index) -- See Note [Type classes and linear types] base_info = noCafIdInfo - `setArityInfo` 1 - `setDmdSigInfo` strict_sig - `setCprSigInfo` topCprSig - `setLevityInfoWithType` sel_ty + `setArityInfo` 1 + `setDmdSigInfo` strict_sig + `setCprSigInfo` topCprSig info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkInlineUnfoldingWithArity 1 - defaultSimpleOpts + `setUnfoldingInfo` mkInlineUnfoldingWithArity defaultSimpleOpts + StableSystemSrc 1 (mkDictSelRhs clas val_index) -- See Note [Single-method classes] in GHC.Tc.TyCl.Instance -- for why alwaysInlinePragma @@ -492,8 +497,8 @@ | otherwise = base_info `setRuleInfo` mkRuleInfo [rule] `setInlinePragInfo` neverInlinePragma - `setUnfoldingInfo` mkInlineUnfoldingWithArity 1 - defaultSimpleOpts + `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. @@ -585,26 +590,25 @@ `setInlinePragInfo` wkr_inline_prag `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 - `setLevityInfoWithType` wkr_ty - -- NB: unboxed tuples have workers, so we can't use - -- setNeverRepPoly + -- No strictness: see Note [Data-con worker strictness] in GHC.Core.DataCon wkr_inline_prag = defaultInlinePragma { inl_rule = ConLike } wkr_arity = dataConRepArity data_con + ----------- 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 - `setLevityInfoWithType` wkr_ty id_arg1 = mkScaledTemplateLocal 1 (head arg_tys) res_ty_args = mkTyCoVarTys univ_tvs - newtype_unf = assertPpr (isVanillaDataCon data_con && isSingleton arg_tys) - (ppr data_con) $ + newtype_unf = assertPpr (null ex_tcvs && isSingleton arg_tys) + (ppr data_con) -- Note [Newtype datacons] - mkCompulsoryUnfolding defaultSimpleOpts $ + mkCompulsoryUnfolding $ mkLams univ_tvs $ Lam id_arg1 $ wrapNewTypeBody tycon res_ty_args (Var id_arg1) @@ -621,7 +625,7 @@ type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) -- Unbox: bind rep vars by decomposing src var -data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr)) +data Boxer = UnitBox | Boxer (Subst -> UniqSM ([Var], CoreExpr)) -- Box: build src arg using these rep vars -- | Data Constructor Boxer @@ -684,8 +688,10 @@ | otherwise = do { wrap_args <- mapM (newLocal (fsLit "conrep")) wrap_arg_tys - ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) + ; wrap_body <- mk_rep_app (dropList stupid_theta wrap_args `zip` dropList eq_spec unboxers) initial_wrap_app + -- Drop the stupid theta arguments, as per + -- Note [Instantiating stupid theta] in GHC.Core.DataCon. ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info wrap_info = noCafIdInfo @@ -698,8 +704,9 @@ -- 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 - `setLevityInfoWithType` wrap_ty + -- 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 wrap_arg_dmds = @@ -722,9 +729,9 @@ -- See Note [Inline partially-applied constructor wrappers] -- Passing Nothing here allows the wrapper to inline when -- unsaturated. - wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding defaultSimpleOpts wrap_rhs + wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs -- See Note [Compulsory newtype unfolding] - | otherwise = mkInlineUnfolding defaultSimpleOpts wrap_rhs + | otherwise = mkDataConUnfolding wrap_rhs wrap_rhs = mkLams wrap_tvs $ mkLams wrap_args $ wrapFamInstBody tycon res_ty_args $ @@ -740,9 +747,10 @@ where (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) - = dataConFullSig data_con + = dataConFullSig data_con + stupid_theta = dataConStupidTheta data_con wrap_tvs = dataConUserTyVars data_con - res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs + res_ty_args = dataConResRepTyArgs data_con tycon = dataConTyCon data_con -- The representation TyCon (not family) wrap_ty = dataConWrapperType data_con @@ -751,7 +759,7 @@ ev_ibangs = map (const HsLazy) ev_tys orig_bangs = dataConSrcBangs data_con - wrap_arg_tys = (map unrestricted theta) ++ orig_arg_tys + wrap_arg_tys = (map unrestricted $ stupid_theta ++ theta) ++ orig_arg_tys wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys -- The wrap_args are the arguments *other than* the eq_spec -- Because we are going to apply the eq_spec args manually in the @@ -776,20 +784,44 @@ (unboxers, boxers) = unzip wrappers (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) + -- This is True if the data constructor or class dictionary constructor + -- needs a wrapper. This wrapper is injected into the program later in the + -- CoreTidy pass. See Note [Injecting implicit bindings] in GHC.Iface.Tidy, + -- along with the accompanying implementation in getTyConImplicitBinds. wrapper_reqd = (not new_tycon -- (Most) newtypes have only a worker, with the exception - -- of some newtypes written with GADT syntax. See below. - && (any isBanged (ev_ibangs ++ arg_ibangs) + -- of some newtypes written with GADT syntax. + -- See dataConUserTyVarsNeedWrapper below. + && (any isBanged (ev_ibangs ++ arg_ibangs))) -- Some forcing/unboxing (includes eq_spec) - || (not $ null eq_spec))) -- GADT || isFamInstTyCon tycon -- Cast result - || dataConUserTyVarsArePermuted data_con + || (dataConUserTyVarsNeedWrapper 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 -- the type variables. -- See Note [Data con wrappers and GADT syntax]. + -- + -- NB: All GADTs return true from this function, but there + -- is one exception that we must check below. + && not (isTypeDataTyCon tycon)) + -- An exception to this rule is `type data` declarations. + -- Their data constructors only live at the type level and + -- therefore do not need wrappers. + -- See Note [Type data declarations] in GHC.Rename.Module. + -- + -- Note that the other checks in this definition will + -- return False for `type data` declarations, as: + -- + -- - They cannot be newtypes + -- - They cannot have strict fields + -- - They cannot be data family instances + -- - They cannot have datatype contexts + || not (null stupid_theta) + -- If the data constructor has a datatype context, + -- we need a wrapper in order to drop the stupid arguments. + -- See Note [Instantiating stupid theta] in GHC.Core.DataCon. initial_wrap_app = Var (dataConWorkId data_con) `mkTyApps` res_ty_args @@ -976,8 +1008,7 @@ -> Scaled Type -- ^ the type of the 'Var' -> UniqSM Var newLocal name_stem (Scaled w ty) = - do { uniq <- getUniqueM - ; return (mkSysLocalOrCoVar name_stem uniq w ty) } + mkSysLocalOrCoVarM name_stem w ty -- We should not have "OrCoVar" here, this is a bug (#17545) @@ -1012,27 +1043,22 @@ = HsLazy -- For !Int#, say, use HsLazy -- See Note [Data con wrappers and unlifted types] - | not (bang_opt_unbox_disable bang_opts) -- Don't unpack if disabled - , let mb_co = topNormaliseType_maybe fam_envs (scaledThing arg_ty) + | let mb_co = topNormaliseType_maybe fam_envs (scaledThing arg_ty) -- Unwrap type families and newtypes arg_ty' = case mb_co of { Just redn -> scaledSet arg_ty (reductionReducedType redn) ; Nothing -> arg_ty } - , isUnpackableType bang_opts fam_envs (scaledThing arg_ty') - , (rep_tys, _) <- dataConArgUnpack arg_ty' - , case unpk_prag of - NoSrcUnpack -> - bang_opt_unbox_strict bang_opts - || (bang_opt_unbox_small bang_opts - && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] - srcUnpack -> isSrcUnpacked srcUnpack - = case mb_co of - Nothing -> HsUnpack Nothing - Just redn -> HsUnpack (Just $ reductionCoercion redn) + , all (not . isNewTyCon . fst) (splitTyConApp_maybe $ scaledThing arg_ty') + , shouldUnpackTy bang_opts unpk_prag fam_envs arg_ty' + = if bang_opt_unbox_disable bang_opts + then HsStrict True -- Not unpacking because of -O0 + -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon + else case mb_co of + Nothing -> HsUnpack Nothing + Just redn -> HsUnpack (Just $ reductionCoercion redn) | otherwise -- Record the strict-but-no-unpack decision - = HsStrict - + = HsStrict False -- | Wrappers/Workers and representation following Unpack/Strictness -- decisions @@ -1045,12 +1071,11 @@ dataConArgRep arg_ty HsLazy = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) -dataConArgRep arg_ty HsStrict +dataConArgRep arg_ty (HsStrict _) = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) dataConArgRep arg_ty (HsUnpack Nothing) - | (rep_tys, wrappers) <- dataConArgUnpack arg_ty - = (rep_tys, wrappers) + = dataConArgUnpack arg_ty dataConArgRep (Scaled w _) (HsUnpack (Just co)) | let co_rep_ty = coercionRKind co @@ -1087,50 +1112,231 @@ unitBoxer = UnitBox ------------------------- + +{- Note [UNPACK for sum types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have a data type D, for example: + data D = D1 [Int] [Bool] + | D2 + +and another data type which unpacks a field of type D: + data U a = MkU {-# UNPACK #-} !D + {-# UNPACK #-} !(a,a) + {-# UNPACK #-} !D + +Then the wrapper and worker for MkU have these types + + -- Wrapper + $WMkU :: D -> (a,a) -> D -> U a + + -- Worker + MkU :: (# (# [Int],[Bool] #) | (# #) #) + -> a + -> a + -> (# (# [Int],[Bool] #) | (# #) #) + -> U a + +For each unpacked /sum/-type argument, the worker gets one argument. +But for each unpacked /product/-type argument, the worker gets N +arguments (here two). + +Why treat them differently? See Note [Why sums and products are treated differently]. + +The wrapper $WMkU looks like this: + + $WMkU :: D -> (a,a) -> D -> U a + $WMkU x1 y x2 + = case (case x1 of { + D1 a b -> (# (# a,b #) | #) + D2 -> (# | (# #) #) }) of { x1_ubx -> + case y of { (y1, y2) -> + case (case x2 of { + D1 a b -> (# (# a,b #) | #) + D2 -> (# | (# #) #) }) of { x2_ubx -> + MkU x1_ubx y1 y2 x2_ubx + +Notice the nested case needed for sums. + +This different treatment for sums and product is implemented in +dataConArgUnpackSum and dataConArgUnpackProduct respectively. + +Note [Why sums and products are treated differently] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can we handle sums like products, with each wrapper argument +occupying multiple argument slots in the worker? No: for a sum +type the number of argument slots varies, and that's exactly what +unboxed sums are designed for. + +Can we handle products like sums, with each wrapper argument occupying +exactly one argument slot (and unboxed tuple) in the worker? Yes, +we could. For example + data P = MkP {-# UNPACK #-} !Q + data Q = MkQ {-# NOUNPACK #-} !Int + {-# NOUNPACK #-} Int + +Currently could unpack P thus, taking two slots in the worker + $WMkP :: Q -> P + $WMkP x = case x of { MkQ a b -> MkP a b } + MkP :: Int -> Int -> P -- Worker + +We could instead do this (uniformly with sums) + + $WMkP1 :: Q -> P + $WMkP1 x = case (case x of { MkQ a b -> (# a, b #) }) of ubx_x + MkP1 ubx_x + MkP1 :: (# Int, Int #) -> P -- Worker + +The representation of MkP and MkP1 would be identical (a constructor +with two fields). + +BUT, with MkP (as with every data constructor) we record its argument +strictness as a bit-vector, actually [StrictnessMark] + MkP strictness: SL +This information is used in Core to record which fields are sure to +be evaluated. (Look for calls to dataConRepStrictness.) E.g. in Core + case v of MkP x y -> ........ + +Alas, with MkP1 this information is hidden by the unboxed pair, +In Core there will be an auxiliary case expression to take apart the pair: + case v of MkP1 xy -> case xy of (# x,y #) -> ... +And now we have no easy way to know that x is evaluated in the "...". + +Fixing this might be possible, but it'd be tricky. So we avoid the +problem entirely by treating sums and products differently here. +-} + dataConArgUnpack :: Scaled Type -> ( [(Scaled Type, StrictnessMark)] -- Rep types , (Unboxer, Boxer) ) - -dataConArgUnpack (Scaled arg_mult arg_ty) +dataConArgUnpack scaledTy@(Scaled _ arg_ty) | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty - , Just con <- tyConSingleAlgDataCon_maybe tc - -- NB: check for an *algebraic* data type - -- A recursive newtype might mean that - -- 'arg_ty' is a newtype - , let rep_tys = map (scaleScaled arg_mult) $ dataConInstArgTys con tc_args - = assert (null (dataConExTyCoVars con)) - -- Note [Unpacking GADTs and existentials] - ( rep_tys `zip` dataConRepStrictness con - ,( \ arg_id -> - do { rep_ids <- mapM (newLocal (fsLit "unbx")) rep_tys - ; let r_mult = idMult arg_id - ; let rep_ids' = map (scaleIdBy r_mult) rep_ids - ; let unbox_fn body - = mkSingleAltCase (Var arg_id) arg_id - (DataAlt con) rep_ids' body - ; return (rep_ids, unbox_fn) } - , Boxer $ \ subst -> - do { rep_ids <- mapM (newLocal (fsLit "bx") . TcType.substScaledTyUnchecked subst) rep_tys - ; return (rep_ids, Var (dataConWorkId con) - `mkTyApps` (substTysUnchecked subst tc_args) - `mkVarApps` rep_ids ) } ) ) + = assert (not (isNewTyCon tc)) $ + case tyConDataCons tc of + [con] -> dataConArgUnpackProduct scaledTy tc_args con + cons -> dataConArgUnpackSum scaledTy tc_args cons | otherwise = pprPanic "dataConArgUnpack" (ppr arg_ty) -- An interface file specified Unpacked, but we couldn't unpack it -isUnpackableType :: BangOpts -> FamInstEnvs -> Type -> Bool --- True if we can unpack the UNPACK the argument type +dataConArgUnpackProduct + :: Scaled Type + -> [Type] + -> DataCon + -> ( [(Scaled Type, StrictnessMark)] -- Rep types + , (Unboxer, Boxer) ) +dataConArgUnpackProduct (Scaled arg_mult _) tc_args con = + assert (null (dataConExTyCoVars con)) $ + -- Note [Unpacking GADTs and existentials] + let rep_tys = map (scaleScaled arg_mult) $ dataConInstArgTys con tc_args + in ( rep_tys `zip` dataConRepStrictness con + , ( \ arg_id -> + do { rep_ids <- mapM (newLocal (fsLit "unbx")) rep_tys + ; let r_mult = idMult arg_id + ; let rep_ids' = map (scaleIdBy r_mult) rep_ids + ; let unbox_fn body + = mkSingleAltCase (Var arg_id) arg_id + (DataAlt con) rep_ids' body + ; return (rep_ids, unbox_fn) } + , Boxer $ \ subst -> + do { rep_ids <- mapM (newLocal (fsLit "bx") . TcType.substScaledTyUnchecked subst) rep_tys + ; return (rep_ids, Var (dataConWorkId con) + `mkTyApps` (substTysUnchecked subst tc_args) + `mkVarApps` rep_ids ) } ) ) + +dataConArgUnpackSum + :: Scaled Type + -> [Type] + -> [DataCon] + -> ( [(Scaled Type, StrictnessMark)] -- Rep types + , (Unboxer, Boxer) ) +dataConArgUnpackSum (Scaled arg_mult arg_ty) tc_args cons = + ( [ (sum_ty, MarkedStrict) ] -- The idea: Unpacked variant will + -- be one field only, and the type of the + -- field will be an unboxed sum. + , ( unboxer, boxer ) ) + where + !ubx_sum_arity = length cons + src_tys = map (\con -> map scaledThing $ dataConInstArgTys con tc_args) cons + sum_alt_tys = map mkUbxSumAltTy src_tys + sum_ty_unscaled = mkSumTy sum_alt_tys + sum_ty = Scaled arg_mult sum_ty_unscaled + newLocal' fs = newLocal fs . Scaled arg_mult + + -- See Note [UNPACK for sum types] + unboxer :: Unboxer + unboxer arg_id = do + con_arg_binders <- mapM (mapM (newLocal' (fsLit "unbx"))) src_tys + ubx_sum_bndr <- newLocal (fsLit "unbx") sum_ty + + let + mk_ubx_sum_alt :: Int -> DataCon -> [Var] -> CoreAlt + mk_ubx_sum_alt alt con [bndr] = Alt (DataAlt con) [bndr] + (mkCoreUnboxedSum ubx_sum_arity alt sum_alt_tys (Var bndr)) + + mk_ubx_sum_alt alt con bndrs = + let tuple = mkCoreUnboxedTuple (map Var bndrs) + in Alt (DataAlt con) bndrs (mkCoreUnboxedSum ubx_sum_arity alt sum_alt_tys tuple ) + + ubx_sum :: CoreExpr + ubx_sum = + let alts = zipWith3 mk_ubx_sum_alt [ 1 .. ] cons con_arg_binders + in Case (Var arg_id) arg_id (coreAltsType alts) alts + + unbox_fn :: CoreExpr -> CoreExpr + unbox_fn body = + mkSingleAltCase ubx_sum ubx_sum_bndr DEFAULT [] body + + return ([ubx_sum_bndr], unbox_fn) + + boxer :: Boxer + boxer = Boxer $ \ subst -> do + unboxed_field_id <- newLocal' (fsLit "bx") (TcType.substTy subst sum_ty_unscaled) + tuple_bndrs <- mapM (newLocal' (fsLit "bx") . TcType.substTy subst) sum_alt_tys + + let tc_args' = substTys subst tc_args + arg_ty' = substTy subst arg_ty + + con_arg_binders <- + mapM (mapM (newLocal' (fsLit "bx")) . map (TcType.substTy subst)) src_tys + + let mk_sum_alt :: Int -> DataCon -> Var -> [Var] -> CoreAlt + mk_sum_alt alt con _ [datacon_bndr] = + ( Alt (DataAlt (sumDataCon alt ubx_sum_arity)) [datacon_bndr] + (Var (dataConWorkId con) `mkTyApps` tc_args' + `mkVarApps` [datacon_bndr] )) + + mk_sum_alt alt con tuple_bndr datacon_bndrs = + ( Alt (DataAlt (sumDataCon alt ubx_sum_arity)) [tuple_bndr] ( + Case (Var tuple_bndr) tuple_bndr arg_ty' + [ Alt (DataAlt (tupleDataCon Unboxed (length datacon_bndrs))) datacon_bndrs + (Var (dataConWorkId con) `mkTyApps` tc_args' + `mkVarApps` datacon_bndrs ) ] )) + + return ( [unboxed_field_id], + Case (Var unboxed_field_id) unboxed_field_id arg_ty' + (zipWith4 mk_sum_alt [ 1 .. ] cons tuple_bndrs con_arg_binders) ) + +-- | Every alternative of an unboxed sum has exactly one field, and we use +-- unboxed tuples when we need more than one field. This generates an unboxed +-- tuple when necessary, to be used in unboxed sum alts. +mkUbxSumAltTy :: [Type] -> Type +mkUbxSumAltTy [ty] = ty +mkUbxSumAltTy tys = mkTupleTy Unboxed tys + +shouldUnpackTy :: BangOpts -> SrcUnpackedness -> FamInstEnvs -> Scaled Type -> Bool +-- True if we ought to unpack the UNPACK the argument type -- See Note [Recursive unboxing] -- We look "deeply" inside rather than relying on the DataCons -- we encounter on the way, because otherwise we might well -- end up relying on ourselves! -isUnpackableType bang_opts fam_envs ty - | Just data_con <- unpackable_type ty - = ok_con_args emptyNameSet data_con +shouldUnpackTy bang_opts prag fam_envs ty + | Just data_cons <- unpackable_type_datacons (scaledThing ty) + = all (ok_con_args emptyNameSet) data_cons && should_unpack data_cons | otherwise = False where + ok_con_args :: NameSet -> DataCon -> Bool ok_con_args dcs con | dc_name `elemNameSet` dcs = False @@ -1143,17 +1349,20 @@ dc_name = getName con dcs' = dcs `extendNameSet` dc_name + ok_arg :: NameSet -> (Scaled Type, HsSrcBang) -> Bool ok_arg dcs (Scaled _ ty, bang) = not (attempt_unpack bang) || ok_ty dcs norm_ty where norm_ty = topNormaliseType fam_envs ty + ok_ty :: NameSet -> Type -> Bool ok_ty dcs ty - | Just data_con <- unpackable_type ty - = ok_con_args dcs data_con + | Just data_cons <- unpackable_type_datacons ty + = all (ok_con_args dcs) data_cons | otherwise = True -- NB True here, in contrast to False at top level + attempt_unpack :: HsSrcBang -> Bool attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict) = bang_opt_strict_data bang_opts attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict) @@ -1164,17 +1373,41 @@ = bang_opt_strict_data bang_opts -- Be conservative attempt_unpack _ = False - unpackable_type :: Type -> Maybe DataCon - -- Works just on a single level - unpackable_type ty - | Just (tc, _) <- splitTyConApp_maybe ty - , Just data_con <- tyConSingleAlgDataCon_maybe tc - , null (dataConExTyCoVars data_con) - -- See Note [Unpacking GADTs and existentials] - = Just data_con - | otherwise - = Nothing + -- Determine whether we ought to unpack a field based on user annotations if present and heuristics if not. + should_unpack data_cons = + case prag of + SrcNoUnpack -> False -- {-# NOUNPACK #-} + SrcUnpack -> True -- {-# UNPACK #-} + NoSrcUnpack -- No explicit unpack pragma, so use heuristics + | (_:_:_) <- data_cons + -> False -- don't unpack sum types automatically, but they can be unpacked with an explicit source UNPACK. + | otherwise + -> bang_opt_unbox_strict bang_opts + || (bang_opt_unbox_small bang_opts + && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] + where (rep_tys, _) = dataConArgUnpack ty + +-- 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] +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 + , Just cons <- tyConDataCons_maybe tc + , not (null cons) + , all (null . dataConExTyCoVars) cons + = Just cons -- See Note [Unpacking GADTs and existentials] + | otherwise + = Nothing + {- Note [Unpacking GADTs and existentials] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1317,17 +1550,16 @@ -- The "occurrence name" of a ccall is the full info about the -- ccall; it is encoded, but may have embedded spaces etc! - name = mkFCallName uniq occ_str + name = mkFCallName uniq (mkFastString occ_str) info = noCafIdInfo - `setArityInfo` arity - `setDmdSigInfo` strict_sig - `setCprSigInfo` topCprSig - `setLevityInfoWithType` ty + `setArityInfo` arity + `setDmdSigInfo` strict_sig + `setCprSigInfo` topCprSig (bndrs, _) = tcSplitPiTys ty - arity = count isAnonTyCoBinder bndrs - strict_sig = mkClosedDmdSig (replicate arity topDmd) topDiv + arity = count isAnonPiTyBinder bndrs + strict_sig = mkVanillaDmdSig arity topDiv -- the call does not claim to be strict in its arguments, since they -- may be lifted (foreign import prim) and the called code doesn't -- necessarily force them. See #11076. @@ -1362,11 +1594,7 @@ dfun_ty where is_nt = isNewTyCon (classTyCon clas) - dfun_ty = mkDictFunTy tvs theta clas tys - -mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type -mkDictFunTy tvs theta clas tys - = mkSpecSigmaTy tvs theta (mkClassPred clas tys) + dfun_ty = TcType.tcMkDFunSigmaTy tvs theta (mkClassPred clas tys) {- ************************************************************************ @@ -1402,23 +1630,22 @@ rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId -- Names listed in magicIds; see Note [magicIds] -lazyIdName, oneShotName, noinlineIdName :: Name +lazyIdName, oneShotName, nospecIdName :: Name lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId -noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId +nospecIdName = mkWiredInIdName gHC_MAGIC (fsLit "nospec") nospecIdKey nospecId ------------------------------------------------ proxyHashId :: Id proxyHashId = pcMiscPrelId proxyName ty - (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setNeverRepPoly` ty) + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings] where -- proxy# :: forall {k} (a:k). Proxy# k a -- -- The visibility of the `k` binder is Inferred to match the type of the -- Proxy data constructor (#16293). - [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id + [kv,tv] = mkTemplateKiTyVar liftedTypeKind (\x -> [x]) kv_ty = mkTyVarTy kv tv_ty = mkTyVarTy tv ty = mkInfForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty @@ -1431,15 +1658,14 @@ nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts (Lit nullAddrLit) - `setNeverRepPoly` addrPrimTy + `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) ------------------------------------------------ seqId :: Id -- See Note [seqId magic] seqId = pcMiscPrelId seqName ty info where info = noCafIdInfo `setInlinePragInfo` inline_prag - `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs + `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setArityInfo` arity inline_prag @@ -1466,20 +1692,42 @@ lazyId :: Id -- See Note [lazyId magic] lazyId = pcMiscPrelId lazyIdName ty info where - info = noCafIdInfo `setNeverRepPoly` ty + info = noCafIdInfo ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) +------------------------------------------------ +noinlineIdName, noinlineConstraintIdName :: Name +noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") + noinlineIdKey noinlineId +noinlineConstraintIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinlineConstraint") + noinlineConstraintIdKey noinlineConstraintId + noinlineId :: Id -- See Note [noinlineId magic] noinlineId = pcMiscPrelId noinlineIdName ty info where - info = noCafIdInfo `setNeverRepPoly` ty + info = noCafIdInfo + ty = mkSpecForAllTys [alphaTyVar] $ + mkVisFunTyMany alphaTy alphaTy + +noinlineConstraintId :: Id -- See Note [noinlineId magic] +noinlineConstraintId = pcMiscPrelId noinlineConstraintIdName ty info + where + info = noCafIdInfo + ty = mkSpecForAllTys [alphaConstraintTyVar] $ + mkFunTy visArgConstraintLike ManyTy alphaTy alphaConstraintTy + +------------------------------------------------ +nospecId :: Id -- See Note [nospecId magic] +nospecId = pcMiscPrelId nospecIdName ty info + where + info = noCafIdInfo ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) oneShotId :: Id -- See Note [The oneShot function] oneShotId = pcMiscPrelId oneShotName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs + `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setArityInfo` arity ty = mkInfForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar ] $ mkSpecForAllTys [ openAlphaTyVar, openBetaTyVar ] $ @@ -1497,11 +1745,11 @@ {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The functions leftSectionId, rightSectionId are -wired in here ONLY because they are use in a representation-polymorphic way +wired in here ONLY because they are used in a representation-polymorphic way by the rebindable syntax mechanism. See GHC.Rename.Expr Note [Handling overloaded and rebindable constructs]. -Alas, we can't currenly give Haskell definitions for +Alas, we can't currently give Haskell definitions for representation-polymorphic functions. They have Compulsory unfoldings, so that the representation polymorphism @@ -1520,7 +1768,7 @@ leftSectionId = pcMiscPrelId leftSectionName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs + `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setArityInfo` arity ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar, multiplicityTyVar1] $ mkSpecForAllTys [openAlphaTyVar, openBetaTyVar] $ @@ -1545,7 +1793,7 @@ rightSectionId = pcMiscPrelId rightSectionName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs + `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setArityInfo` arity ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar,runtimeRep3TyVar , multiplicityTyVar1, multiplicityTyVar2 ] $ @@ -1554,8 +1802,8 @@ mult1 = mkTyVarTy multiplicityTyVar1 mult2 = mkTyVarTy multiplicityTyVar2 - [f,x,y] = mkTemplateLocals [ mkVisFunTys [ Scaled mult1 openAlphaTy - , Scaled mult2 openBetaTy ] openGammaTy + [f,x,y] = mkTemplateLocals [ mkScaledFunTys [ Scaled mult1 openAlphaTy + , Scaled mult2 openBetaTy ] openGammaTy , openAlphaTy, openBetaTy ] xmult = setIdMult x mult1 ymult = setIdMult y mult2 @@ -1571,14 +1819,14 @@ coerceId = pcMiscPrelId coerceName ty info where info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma - `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs + `setUnfoldingInfo` mkCompulsoryUnfolding rhs `setArityInfo` 2 eqRTy = mkTyConApp coercibleTyCon [ tYPE_r, a, b ] eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE_r, tYPE_r, a, b ] ty = mkInvisForAllTys [ Bndr rv InferredSpec , Bndr av SpecifiedSpec , Bndr bv SpecifiedSpec ] $ - mkInvisFunTyMany eqRTy $ + mkInvisFunTy eqRTy $ mkVisFunTyMany a b bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy @@ -1715,21 +1963,45 @@ noinline foo x xs where x::Int, will naturally desugar to noinline @Int (foo @Int dEqInt) x xs - But now it's entirely possible htat (foo @Int dEqInt) will inline foo, + But now it's entirely possible that (foo @Int dEqInt) will inline foo, since 'foo' is no longer a lone variable -- see #18995 Solution: in the desugarer, rewrite noinline (f x y) ==> noinline f x y This is done in GHC.HsToCore.Utils.mkCoreAppDs. + This is only needed for noinlineId, not noInlineConstraintId (wrinkle + (W1) below), because the latter never shows up in user code. -Note that noinline as currently implemented can hide some simplifications since -it hides strictness from the demand analyser. Specifically, the demand analyser -will treat 'noinline f x' as lazy in 'x', even if the demand signature of 'f' -specifies that it is strict in its argument. We considered fixing this this by adding a -special case to the demand analyser to address #16588. However, the special -case seemed like a large and expensive hammer to address a rare case and -consequently we rather opted to use a more minimal solution. +Wrinkles +(W1) Sometimes case (2) above needs to apply `noinline` to a type of kind + Constraint; e.g. + noinline @(Eq Int) $dfEqInt + We don't have type-or-kind polymorphism, so we simply have two `inline` + Ids, namely `noinlineId` and `noinlineConstraintId`. + +(W2) Note that noinline as currently implemented can hide some simplifications + since it hides strictness from the demand analyser. Specifically, the + demand analyser will treat 'noinline f x' as lazy in 'x', even if the + demand signature of 'f' specifies that it is strict in its argument. We + considered fixing this this by adding a special case to the demand + analyser to address #16588. However, the special case seemed like a large + and expensive hammer to address a rare case and consequently we rather + opted to use a more minimal solution. + +Note [nospecId magic] +~~~~~~~~~~~~~~~~~~~~~ +The 'nospec' magic Id is used to ensure to make a value opaque to the typeclass +specialiser. In CorePrep, we inline 'nospec', turning (nospec e) into e. +Note that this happens *after* unfoldings are exposed in the interface file. +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. + Note [The oneShot function] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the context of making left-folds fuse somewhat okish (see ticket #7994 @@ -1782,10 +2054,11 @@ -} realWorldPrimId :: Id -- :: State# RealWorld -realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy +realWorldPrimId = pcMiscPrelId realWorldName id_ty (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] - `setOneShotInfo` stateHackOneShot - `setNeverRepPoly` realWorldStatePrimTy) + `setOneShotInfo` typeOneShot id_ty) + where + id_ty = realWorldStatePrimTy voidPrimId :: Id -- Global constant :: Void# -- The type Void# is now the same as (# #) (ticket #18441), @@ -1794,13 +2067,13 @@ -- We cannot define it in normal Haskell, since it's -- a top-level unlifted value. voidPrimId = pcMiscPrelId voidPrimIdName unboxedUnitTy - (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs - `setNeverRepPoly` unboxedUnitTy) - where rhs = Var (dataConWorkId unboxedUnitDataCon) + (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding unboxedUnitExpr) +unboxedUnitExpr :: CoreExpr +unboxedUnitExpr = Var (dataConWorkId unboxedUnitDataCon) voidArgId :: Id -- Local lambda-bound :: Void# -voidArgId = mkSysLocal (fsLit "void") voidArgIdKey Many unboxedUnitTy +voidArgId = mkSysLocal (fsLit "void") voidArgIdKey ManyTy unboxedUnitTy coercionTokenId :: Id -- :: () ~# () coercionTokenId -- See Note [Coercion tokens] in "GHC.CoreToStg" diff --git a/GHC/Types/Literal.hs b/GHC/Types/Literal.hs --- a/GHC/Types/Literal.hs +++ b/GHC/Types/Literal.hs @@ -67,8 +67,9 @@ import GHC.Prelude import GHC.Builtin.Types.Prim -import GHC.Core.TyCo.Rep ( RuntimeRepType ) -import GHC.Core.Type +import GHC.Core.Type( Type, RuntimeRepType, mkForAllTy, mkTyVarTy, typeOrConstraintKind ) +import GHC.Core.TyCo.Compare( nonDetCmpType ) +import GHC.Types.Var import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Types.Basic @@ -83,7 +84,7 @@ import Data.Word import Data.Char import Data.Data ( Data ) -import GHC.Exts +import GHC.Exts( isTrue#, dataToTag#, (<#) ) import Numeric ( fromRat ) {- @@ -132,15 +133,14 @@ -- that can be represented as a Literal. Create -- with 'nullAddrLit' - | LitRubbish RuntimeRepType -- ^ A nonsense value of the given - -- representation. See Note [Rubbish literals]. - -- - -- The Type argument, rr, is of kind RuntimeRep. - -- The type of the literal is forall (a:TYPE rr). a - -- - -- INVARIANT: the Type has no free variables - -- and so substitution etc can ignore it - -- + | 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 + -- + -- INVARIANT: the Type has no free variables + -- and so substitution etc can ignore it | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' @@ -268,7 +268,7 @@ = do putByte bh 6 put_ bh nt put_ bh i - put_ _ (LitRubbish b) = pprPanic "Binary LitRubbish" (ppr b) + put_ _ lit@(LitRubbish {}) = pprPanic "Binary LitRubbish" (ppr lit) -- We use IfaceLitRubbish; see Note [Rubbish literals], item (6) get bh = do @@ -298,6 +298,7 @@ return (LitNumber nt i) _ -> pprPanic "Binary:Literal" (int (fromIntegral h)) + instance Outputable Literal where ppr = pprLiteral id @@ -579,7 +580,7 @@ mkLitString :: String -> Literal -- stored UTF-8 encoded mkLitString [] = LitString mempty -mkLitString s = LitString (utf8EncodeString s) +mkLitString s = LitString (utf8EncodeByteString s) mkLitBigNat :: Integer -> Literal mkLitBigNat x = assertPpr (x >= 0) (integer x) @@ -851,10 +852,10 @@ LitNumWord64 -> word64PrimTy -- LitRubbish: see Note [Rubbish literals] -literalType (LitRubbish rep) - = mkForAllTy a Inferred (mkTyVarTy a) +literalType (LitRubbish torc rep) + = mkForAllTy (Bndr a Inferred) (mkTyVarTy a) where - a = mkTemplateKindVar (mkTYPEapp rep) + a = mkTemplateKindVar (typeOrConstraintKind torc rep) {- Comparison @@ -870,7 +871,8 @@ cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `lexicalCompareFS` b cmpLit (LitNumber nt1 a) (LitNumber nt2 b) = (nt1 `compare` nt2) `mappend` (a `compare` b) -cmpLit (LitRubbish b1) (LitRubbish b2) = b1 `nonDetCmpType` b2 +cmpLit (LitRubbish tc1 b1) (LitRubbish tc2 b2) = (tc1 `compare` tc2) `mappend` + (b1 `nonDetCmpType` b2) cmpLit lit1 lit2 | isTrue# (dataToTag# lit1 <# dataToTag# lit2) = LT | otherwise = GT @@ -904,9 +906,13 @@ add_par (text "__label" <+> b <+> ppr fod) where b = case mb of Nothing -> pprHsString l - Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) -pprLiteral _ (LitRubbish rep) - = text "RUBBISH" <> parens (ppr rep) + Just x -> doubleQuotes (ftext l <> text ('@':show x)) +pprLiteral _ (LitRubbish torc rep) + = text "RUBBISH" <> pp_tc <> parens (ppr rep) + where + pp_tc = case torc of + TypeLike -> empty + ConstraintLike -> text "[c]" {- Note [Printing of literals in Core] @@ -965,7 +971,7 @@ an IR feature. 2. Core: 'LitRubbish' carries a `Type` of kind RuntimeRep, - describing the runtime representaion of the literal (is it a + describing the runtime representation of the literal (is it a pointer, an unboxed Double#, or whatever). We have it that `RUBBISH[rr]` has type `forall (a :: TYPE rr). a`. @@ -1005,16 +1011,16 @@ all boxed to the host GC anyway. 6. IfaceSyn: `Literal` is part of `IfaceSyn`, but `Type` really isn't. So in - the passage from Core to Iface I put LitRubbish into its owns IfaceExpr data + the passage from Core to Iface we put LitRubbish into its own IfaceExpr data constructor, IfaceLitRubbish. The remaining constructors of Literal are fine as IfaceSyn. Wrinkles a) Why do we put the `Type` (of kind RuntimeRep) inside the literal? Could - we not instead /apply/ the literal to that RuntimeRep? Alas no, becuase + we not instead /apply/ the literal to that RuntimeRep? Alas no, because then LitRubbish :: forall (rr::RuntimeRep) (a::TYPE rr). a - and that's am ill-formed type because its kind is `TYPE rr`, which escapes + and that's an ill-formed type because its kind is `TYPE rr`, which escapes the binding site of `rr`. Annoying. b) A rubbish literal is not bottom, and replies True to exprOkForSpeculation. @@ -1044,9 +1050,9 @@ undefined behavior, of course, but let us list a few examples for failure modes: a) For an value of unboxed numeric type like `Int#`, we just use a silly - value like 42#. The error might propoagate indefinitely, hence we better + value like 42#. The error might propagate indefinitely, hence we better pick a rather unique literal. Same for Word, Floats, Char and VecRep. - b) For AddrRep (like String lits), we mit a null pointer, resulting in a + b) For AddrRep (like String lits), we emit a null pointer, resulting in a definitive segfault when accessed. c) For boxed values, unlifted or not, we use a pointer to a fixed closure, like `()`, so that the GC has a pointer to follow. diff --git a/GHC/Types/Name.hs b/GHC/Types/Name.hs --- a/GHC/Types/Name.hs +++ b/GHC/Types/Name.hs @@ -54,7 +54,9 @@ setNameLoc, tidyNameOcc, localiseName, + namePun_maybe, + pprName, nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, pprFullName, pprTickyName, @@ -83,6 +85,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Types.TyThing ( TyThing ) +import {-# SOURCE #-} GHC.Builtin.Types ( listTyCon ) import GHC.Platform import GHC.Types.Name.Occurrence @@ -99,6 +102,7 @@ import Control.DeepSeq import Data.Data +import qualified Data.Semigroup as S {- ************************************************************************ @@ -332,6 +336,12 @@ is_interactive_or_from :: Module -> Module -> Bool is_interactive_or_from from mod = from == mod || isInteractiveModule mod +-- Return the pun for a name if available. +-- Used for pretty-printing under ListTuplePuns. +namePun_maybe :: Name -> Maybe FastString +namePun_maybe name | getUnique name == getUnique listTyCon = Just (fsLit "[]") +namePun_maybe _ = Nothing + nameIsLocalOrFrom :: Module -> Name -> Bool -- ^ Returns True if the name is -- (a) Internal @@ -484,8 +494,8 @@ mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs) -- | Make a name for a foreign call -mkFCallName :: Unique -> String -> Name -mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan +mkFCallName :: Unique -> FastString -> Name +mkFCallName uniq str = mkInternalName uniq (mkVarOccFS str) noSrcSpan -- The encoded string completely describes the ccall -- When we renumber/rename things, we need to be @@ -527,7 +537,7 @@ stableNameCmp :: Name -> Name -> Ordering stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) (Name { n_sort = s2, n_occ = occ2 }) - = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) + = sort_cmp s1 s2 S.<> compare occ1 occ2 -- The ordinary compare on OccNames is lexicographic where -- Later constructors are bigger @@ -615,15 +625,25 @@ pprInfixOcc = pprInfixName pprPrefixOcc = pprPrefixName -pprName :: Name -> SDoc -pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) - = getPprStyle $ \sty -> - getPprDebug $ \debug -> +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 + where + -- Print GHC.Types.List as [], etc. + handlePuns :: Bool -> Maybe FastString -> doc -> doc + 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) pprFullName :: Module -> Name -> SDoc @@ -654,9 +674,9 @@ pprNameUnqualified :: Name -> SDoc pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ -pprExternal :: Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc +pprExternal :: IsLine doc => Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> doc pprExternal debug sty uniq mod occ is_wired is_builtin - | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ + | 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? @@ -669,13 +689,13 @@ if isHoleModule mod then case qualName sty mod occ of NameUnqual -> ppr_occ_name occ - _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) + _ -> braces (pprModuleName (moduleName mod) <> dot <> ppr_occ_name occ) else pprModulePrefix sty mod occ <> ppr_occ_name occ where pp_mod = ppUnlessOption sdocSuppressModulePrefixes - (ppr mod <> dot) + (pprModule mod <> dot) -pprInternal :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprInternal :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc pprInternal debug sty uniq occ | codeStyle sty = pprUniqueAlways uniq | debug = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), @@ -686,7 +706,7 @@ | otherwise = ppr_occ_name occ -- User style -- Like Internal, except that we only omit the unique in Iface style -pprSystem :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprSystem :: IsLine doc => Bool -> PprStyle -> Unique -> OccName -> doc pprSystem debug sty uniq occ | codeStyle sty = pprUniqueAlways uniq | debug = ppr_occ_name occ <> ppr_underscore_unique uniq @@ -697,38 +717,38 @@ -- so print the unique -pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc +pprModulePrefix :: IsLine doc => PprStyle -> Module -> OccName -> doc -- 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: - NameQual modname -> ppr modname <> dot -- Name is in scope - NameNotInScope1 -> ppr mod <> dot -- Not in scope - NameNotInScope2 -> ppr (moduleUnit mod) <> colon -- Module not in - <> ppr (moduleName mod) <> dot -- scope either + 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 :: Unique -> SDoc +pprUnique :: IsLine doc => Unique -> doc -- Print a unique unless we are suppressing them pprUnique uniq = ppUnlessOption sdocSuppressUniques $ pprUniqueAlways uniq -ppr_underscore_unique :: Unique -> SDoc +ppr_underscore_unique :: IsLine doc => Unique -> doc -- 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 :: OccName -> SDoc +ppr_occ_name :: IsLine doc => OccName -> doc 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 :: OccName -> SDoc +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 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 @@ -8,6 +8,7 @@ import GHC.Types.Unique import GHC.Utils.Outputable import Data.Data (Data) +import Control.DeepSeq (NFData) data Name @@ -15,6 +16,7 @@ instance Data Name instance Uniquable Name instance Outputable Name +instance NFData Name class NamedThing a where getOccName :: a -> OccName 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 @@ -102,7 +102,7 @@ lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name lookupOrigNameCache nc mod occ - | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE + | 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 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 @@ -19,7 +19,7 @@ unitNameEnv, nonDetNameEnvElts, extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnvList, extendNameEnvList_C, - filterNameEnv, anyNameEnv, + filterNameEnv, mapMaybeNameEnv, anyNameEnv, plusNameEnv, plusNameEnv_C, plusNameEnv_CD, plusNameEnv_CD2, alterNameEnv, lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, elemNameEnv, mapNameEnv, disjointNameEnv, @@ -121,6 +121,7 @@ lookupNameEnv :: NameEnv a -> Name -> Maybe a lookupNameEnv_NF :: NameEnv a -> Name -> a filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt +mapMaybeNameEnv :: (a -> Maybe b) -> NameEnv a -> NameEnv b anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 disjointNameEnv :: NameEnv a -> NameEnv a -> Bool @@ -149,6 +150,7 @@ delFromNameEnv x y = delFromUFM x y 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 disjointNameEnv x y = disjointUFM x y seqEltsNameEnv seqElt x = seqEltsUFM seqElt x 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 @@ -6,7 +6,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -- | -- #name_types# @@ -115,6 +114,7 @@ import Control.DeepSeq import Data.Char import Data.Data +import qualified Data.Semigroup as S {- ************************************************************************ @@ -200,7 +200,7 @@ pprNonVarNameSpace VarName = empty pprNonVarNameSpace ns = pprNameSpace ns -pprNameSpaceBrief :: NameSpace -> SDoc +pprNameSpaceBrief :: IsLine doc => NameSpace -> doc pprNameSpaceBrief DataName = char 'd' pprNameSpaceBrief VarName = char 'v' pprNameSpaceBrief TvName = text "tv" @@ -246,8 +246,7 @@ instance Ord OccName where -- Compares lexicographically, *not* by Unique of the string - compare (OccName sp1 s1) (OccName sp2 s2) - = (s1 `lexicalCompareFS` s2) `thenCmp` (sp1 `compare` sp2) + compare (OccName sp1 s1) (OccName sp2 s2) = lexicalCompareFS s1 s2 S.<> compare sp1 sp2 instance Data OccName where -- don't traverse? @@ -277,29 +276,14 @@ pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) -pprOccName :: OccName -> SDoc +pprOccName :: IsLine doc => OccName -> doc pprOccName (OccName sp occ) - = getPprStyle $ \ sty -> - if codeStyle sty + = docWithContext $ \ sty -> + if codeStyle (sdocStyle sty) then ztext (zEncodeFS occ) - else pp_occ <> whenPprDebug (braces (pprNameSpaceBrief sp)) - where - pp_occ = sdocOption sdocSuppressUniques $ \case - True -> text (strip_th_unique (unpackFS occ)) - False -> ftext occ - - -- See Note [Suppressing uniques in OccNames] - strip_th_unique ('[' : c : _) | isAlphaNum c = [] - strip_th_unique (c : cs) = c : strip_th_unique cs - strip_th_unique [] = [] + else ftext occ <> whenPprDebug (braces (pprNameSpaceBrief sp)) {- -Note [Suppressing uniques in OccNames] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This is a hack to de-wobblify the OccNames that contain uniques from -Template Haskell that have been turned into a string in the OccName. -See Note [Unique OccNames from Template Haskell] in "GHC.ThToHs" - ************************************************************************ * * \subsection{Construction} @@ -535,7 +519,9 @@ startsWithUnderscore :: OccName -> Bool -- ^ Haskell 98 encourages compilers to suppress warnings about unused -- names in a pattern if they start with @_@: this implements that test -startsWithUnderscore occ = headFS (occNameFS occ) == '_' +startsWithUnderscore occ = case unpackFS (occNameFS occ) of + '_':_ -> True + _ -> False {- ************************************************************************ @@ -660,8 +646,8 @@ mkGen1R = mk_simple_deriv tcName "Rep1_" -- Overloaded record field selectors -mkRecFldSelOcc :: String -> OccName -mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] +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] @@ -807,7 +793,6 @@ Note [Tidying multiple names at once] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - Consider > :t (id,id,id) @@ -875,13 +860,13 @@ base1 = mkFastString (base ++ "1") find !k !n - = case lookupUFM env new_fs of - Just {} -> find (k+1 :: Int) (n+k) + = case elemUFM new_fs env of + True -> find (k+1 :: Int) (n+k) -- By using n+k, the n argument to find goes -- 1, add 1, add 2, add 3, etc which -- moves at quadratic speed through a dense patch - Nothing -> (new_env, OccName occ_sp new_fs) + False -> (new_env, OccName occ_sp new_fs) where new_fs = mkFastString (base ++ show n) new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1) 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 @@ -1,13 +1,12 @@ module GHC.Types.Name.Occurrence where -import GHC.Prelude (String) -import GHC.Data.FastString +import GHC.Data.FastString ( FastString ) data OccName class HasOccName name where occName :: name -> OccName -occNameString :: OccName -> String -mkRecFldSelOcc :: String -> 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 @@ -1,7 +1,7 @@ module GHC.Types.Name.Ppr - ( mkPrintUnqualified + ( mkNamePprCtx , mkQualModule , mkQualPackage , pkgQual @@ -9,6 +9,7 @@ where import GHC.Prelude +import GHC.Data.FastString import GHC.Unit import GHC.Unit.Env @@ -16,12 +17,12 @@ import GHC.Types.Name import GHC.Types.Name.Reader -import GHC.Builtin.Types import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Builtin.Types.Prim (tYPETyConName, funTyConName) +import GHC.Builtin.Types.Prim ( fUNTyConName ) +import GHC.Builtin.Types {- @@ -52,7 +53,7 @@ things around, P1:M.T and P2:M.T? Then we don't want to print both of them as M.T! However only one of the modules P1:M and P2:M can be exposed (say P2), so we use M.T for that, and P1:M.T for the other one. -This is handled by the qual_mod component of PrintUnqualified, inside +This is handled by the qual_mod component of NamePprCtx, inside the (ppr mod) of case (3), in Name.pprModulePrefix Note [Printing unit ids] @@ -66,14 +67,19 @@ -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics. -mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualified unit_env env - = QueryQualify qual_name +mkNamePprCtx :: PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx +mkNamePprCtx ptc unit_env env + = QueryQualify + (mkQualName env) (mkQualModule unit_state home_unit) (mkQualPackage unit_state) + (mkPromTick ptc env) where unit_state = ue_units unit_env home_unit = ue_homeUnit unit_env + +mkQualName :: GlobalRdrEnv -> QueryQualifyName +mkQualName env = qual_name where qual_name mod occ | [gre] <- unqual_gres , right_name gre @@ -112,7 +118,7 @@ , coercibleTyConName , eqTyConName , tYPETyConName - , funTyConName + , fUNTyConName, unrestrictedFunTyConName , oneDataConName , manyDataConName ] @@ -125,8 +131,38 @@ -- "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 ptc env + | ptcPrintRedundantPromTicks ptc = alwaysPrintPromTick + | otherwise = print_prom_tick + where + print_prom_tick (PromotedItemListSyntax (IsEmptyOrSingleton eos)) = + -- Ticked: '[], '[x] + -- Unticked: [x,y], [x,y,z], and so on + ptcListTuplePuns ptc && eos + print_prom_tick PromotedItemTupleSyntax = + ptcListTuplePuns ptc + print_prom_tick (PromotedItemDataCon occ) + | isPunnedDataConName occ -- '[], '(,), ''(,,) + = ptcListTuplePuns ptc + + | Just occ' <- promoteOccName occ + , [] <- lookupGRE_RdrName (mkRdrUnqual occ') env + = -- Could not find a corresponding type name in the environment, + -- so the data name is unambiguous. Promotion tick not needed. + False + | otherwise = True + +isPunnedDataConName :: OccName -> Bool +isPunnedDataConName occ = + isDataOcc occ && case unpackFS (occNameFS occ) of + '[':_ -> True + '(':_ -> True + _ -> False + {- Note [pretendNameIsInScopeForPpr] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +c.f. Note [pretendNameIsInScope] in GHC.Builtin.Names Normally, a name is printed unqualified if it's in scope and unambiguous: ghci> :t not not :: Bool -> Bool @@ -199,5 +235,5 @@ -- | A function which only qualifies package names if necessary; but -- qualifies all other identifiers. -pkgQual :: UnitState -> PrintUnqualified +pkgQual :: UnitState -> NamePprCtx pkgQual pkgs = alwaysQualify { queryQualifyPackage = mkQualPackage pkgs } 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 @@ -93,8 +93,11 @@ 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 GHC.Data.Bag {- @@ -339,10 +342,10 @@ compare (Qual _ _) (Exact _) = GT compare (Qual _ _) (Unqual _) = GT - compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + 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) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Orig m1 o1) (Orig m2 o2) = compare o1 o2 S.<> compare m1 m2 compare (Orig _ _) _ = GT {- @@ -709,7 +712,7 @@ greQualModName :: GlobalRdrElt -> ModuleName -- Get a suitable module qualifier for the GRE -- (used in mkPrintUnqualified) --- Prerecondition: the greMangledName is always External +-- 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) @@ -822,12 +825,12 @@ remove_locals gres | locals_only = filter isLocalGRE gres | otherwise = gres pp [] = empty - pp gres = hang (ppr occ + pp gres@(gre:_) = hang (ppr occ <+> parens (text "unique" <+> ppr (getUnique occ)) <> colon) 2 (vcat (map ppr gres)) where - occ = nameOccName (greMangledName (head gres)) + occ = nameOccName (greMangledName gre) lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of @@ -867,7 +870,7 @@ -- 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 (flLabel 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' @@ -1243,8 +1246,7 @@ -- 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) `thenCmp` - (best_item item1 item2) `thenCmp` + = (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 diff --git a/GHC/Types/ProfAuto.hs b/GHC/Types/ProfAuto.hs new file mode 100644 --- /dev/null +++ b/GHC/Types/ProfAuto.hs @@ -0,0 +1,15 @@ +module GHC.Types.ProfAuto + ( ProfAuto (..) + ) +where + +import GHC.Prelude + +-- | What kind of {-# SCC #-} to add automatically +data ProfAuto + = NoProfAuto -- ^ no SCC annotations added + | ProfAutoAll -- ^ top-level and nested functions are annotated + | ProfAutoTop -- ^ top-level functions annotated only + | ProfAutoExports -- ^ exported functions annotated only + | ProfAutoCalls -- ^ annotate call-sites + deriving (Eq,Enum) diff --git a/GHC/Types/RepType.hs b/GHC/Types/RepType.hs --- a/GHC/Types/RepType.hs +++ b/GHC/Types/RepType.hs @@ -13,7 +13,7 @@ -- * Type representation for the code generator typePrimRep, typePrimRep1, runtimeRepPrimRep, typePrimRepArgs, - PrimRep(..), primRepToType, primRepToRuntimeRep, + PrimRep(..), primRepToRuntimeRep, primRepToType, countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness, tyConPrimRep, tyConPrimRep1, runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe, @@ -31,7 +31,6 @@ import GHC.Types.Basic (Arity, RepArity) import GHC.Core.DataCon -import GHC.Builtin.Names import GHC.Core.Coercion import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk @@ -56,8 +55,8 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain +import Data.List.NonEmpty (NonEmpty (..)) import Data.List (sort) import qualified Data.IntSet as IS @@ -205,14 +204,14 @@ -- -- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head -- of the list we have the slot for the tag. -ubxSumRepType :: [[PrimRep]] -> [SlotTy] +ubxSumRepType :: [[PrimRep]] -> NonEmpty SlotTy ubxSumRepType constrs0 -- These first two cases never classify an actual unboxed sum, which always -- has at least two disjuncts. But it could happen if a user writes, e.g., -- forall (a :: TYPE (SumRep [IntRep])). ... -- which could never be instantiated. We still don't want to panic. | constrs0 `lengthLessThan` 2 - = [WordSlot] + = WordSlot :| [] | otherwise = let @@ -240,7 +239,7 @@ rep :: [PrimRep] -> SortedSlotTys rep ty = sort (map primRepSlot ty) - sumRep = WordSlot : combine_alts (map rep constrs0) + sumRep = WordSlot :| combine_alts (map rep constrs0) -- WordSlot: for the tag of the sum in sumRep @@ -306,11 +305,10 @@ ppr (VecSlot n e) = text "VecSlot" <+> ppr n <+> ppr e typeSlotTy :: UnaryType -> Maybe SlotTy -typeSlotTy ty - | isZeroBitTy ty - = Nothing - | otherwise - = Just (primRepSlot (typePrimRep1 ty)) +typeSlotTy ty = case typePrimRep ty of + [] -> Nothing + [rep] -> Just (primRepSlot rep) + reps -> pprPanic "typeSlotTy" (ppr ty $$ ppr reps) primRepSlot :: PrimRep -> SlotTy primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") @@ -528,7 +526,7 @@ 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 -to process the LiftedRep and WordRep, concatentating the results. +to process the LiftedRep and WordRep, concatenating the results. -} @@ -584,40 +582,34 @@ -- See also Note [Getting from RuntimeRep to PrimRep] 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 + | Just runtime_rep <- kindRep_maybe ki + = runtimeRepPrimRep doc runtime_rep kindPrimRep doc ki = pprPanic "kindPrimRep" (ppr ki $$ doc) -- NB: We could implement the partial methods by calling into the maybe -- variants here. But then both would need to pass around the doc argument. --- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's +-- | Take a kind (of shape `TYPE rr` or `CONSTRAINT rr`) and produce the 'PrimRep's -- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep] -- Returns Nothing if rep can't be determined. Eg. levity polymorphic types. kindPrimRep_maybe :: HasDebugCallStack => Kind -> Maybe [PrimRep] kindPrimRep_maybe ki - | Just ki' <- coreView ki - = kindPrimRep_maybe ki' -kindPrimRep_maybe (TyConApp typ [runtime_rep]) - = assert (typ `hasKey` tYPETyConKey) $ - runtimeRepPrimRep_maybe runtime_rep -kindPrimRep_maybe _ki - = Nothing + | Just (_torc, rep) <- sORTKind_maybe ki + = runtimeRepPrimRep_maybe rep + | otherwise + = pprPanic "kindPrimRep" (ppr ki) -- | 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 -runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep] +runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep] runtimeRepPrimRep doc rr_ty | Just rr_ty' <- coreView rr_ty = runtimeRepPrimRep doc rr_ty' | TyConApp rr_dc args <- rr_ty - , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc + , RuntimeRep fun <- tyConPromDataConInfo rr_dc = fun args | otherwise = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty) @@ -631,13 +623,13 @@ | Just rr_ty' <- coreView rr_ty = runtimeRepPrimRep_maybe rr_ty' | TyConApp rr_dc args <- rr_ty - , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc + , RuntimeRep fun <- tyConPromDataConInfo rr_dc = Just $! fun args | otherwise = Nothing -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep -primRepToRuntimeRep :: PrimRep -> Type +primRepToRuntimeRep :: PrimRep -> RuntimeRepType primRepToRuntimeRep rep = case rep of VoidRep -> zeroBitRepTy LiftedRep -> liftedRepTy diff --git a/GHC/Types/SafeHaskell.hs b/GHC/Types/SafeHaskell.hs --- a/GHC/Types/SafeHaskell.hs +++ b/GHC/Types/SafeHaskell.hs @@ -43,7 +43,7 @@ ppr = text . show -- | Safe Haskell information for 'ModIface' --- Simply a wrapper around SafeHaskellMode to sepperate iface and flags +-- Simply a wrapper around SafeHaskellMode to separate iface and flags newtype IfaceTrustInfo = TrustInfo SafeHaskellMode getSafeMode :: IfaceTrustInfo -> SafeHaskellMode diff --git a/GHC/Types/SourceError.hs b/GHC/Types/SourceError.hs --- a/GHC/Types/SourceError.hs +++ b/GHC/Types/SourceError.hs @@ -14,7 +14,7 @@ import GHC.Utils.Monad import GHC.Utils.Panic import GHC.Utils.Exception -import GHC.Utils.Error (pprMsgEnvelopeBagWithLoc) +import GHC.Utils.Error (pprMsgEnvelopeBagWithLocDefault) import GHC.Utils.Outputable import GHC.Driver.Errors.Ppr () -- instance Diagnostic GhcMessage @@ -59,7 +59,7 @@ show (SourceError msgs) = renderWithContext defaultSDocContext . vcat - . pprMsgEnvelopeBagWithLoc + . pprMsgEnvelopeBagWithLocDefault . getMessages $ msgs diff --git a/GHC/Types/SourceText.hs b/GHC/Types/SourceText.hs --- a/GHC/Types/SourceText.hs +++ b/GHC/Types/SourceText.hs @@ -76,15 +76,15 @@ Motivating examples for HsLit - HsChar '\n' == '\x20` - HsCharPrim '\x41`# == `A` + HsChar '\n' == '\x20' + HsCharPrim '\x41'# == 'A'# HsString "\x20\x41" == " A" HsStringPrim "\x20"# == " "# HsInt 001 == 1 HsIntPrim 002# == 2# HsWordPrim 003## == 3## - HsInt64Prim 004## == 4## - HsWord64Prim 005## == 5## + HsInt64Prim 004#Int64 == 4#Int64 + HsWord64Prim 005#Word64 == 5#Word64 HsInteger 006 == 6 For OverLitVal @@ -293,7 +293,7 @@ -- source to source manipulation tools. data StringLiteral = StringLiteral { sl_st :: SourceText, -- literal raw source. - -- See not [Literal source text] + -- See Note [Literal source text] sl_fs :: FastString, -- literal string value sl_tc :: Maybe RealSrcSpan -- Location of -- possible diff --git a/GHC/Types/SrcLoc.hs b/GHC/Types/SrcLoc.hs --- a/GHC/Types/SrcLoc.hs +++ b/GHC/Types/SrcLoc.hs @@ -16,6 +16,7 @@ -- ** Constructing SrcLoc mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, + leftmostColumn, noSrcLoc, -- "I'm sorry, I haven't a clue" generatedSrcLoc, -- Code generated within the compiler @@ -61,7 +62,7 @@ -- ** Predicates on SrcSpan isGoodSrcSpan, isOneLineSpan, isZeroWidthSpan, - containsSpan, + containsSpan, isNoSrcSpan, -- * StringBuffer locations BufPos(..), @@ -69,6 +70,7 @@ BufSpan(..), getBufSpan, removeBufSpan, + combineBufSpans, -- * Located Located, @@ -85,9 +87,6 @@ pprLocated, pprLocatedAlways, - -- ** Modifying Located - mapLoc, - -- ** Combining and comparing Located values eqLocated, cmpLocated, cmpBufSpan, combineLocs, addCLoc, @@ -96,8 +95,6 @@ sortLocated, sortRealLocated, lookupSrcLoc, lookupSrcSpan, - liftL, - -- * Parser locations PsLoc(..), PsSpan(..), @@ -109,11 +106,6 @@ mkSrcSpanPs, combineRealSrcSpans, psLocatedToLocated, - - -- * Layout information - LayoutInfo(..), - leftmostColumn - ) where import GHC.Prelude @@ -126,12 +118,11 @@ import qualified GHC.Data.Strict as Strict import Control.DeepSeq -import Control.Applicative (liftA2) import Data.Data import Data.List (sortBy, intercalate) import Data.Function (on) import qualified Data.Map as Map -import qualified Data.Semigroup +import qualified Data.Semigroup as S {- ************************************************************************ @@ -162,7 +153,7 @@ -- -- The parser guarantees that 'BufPos' are monotonic. See #17632. This means -- that syntactic constructs that appear later in the 'StringBuffer' are guaranteed to --- have a higher 'BufPos'. Constrast that with 'RealSrcLoc', which does *not* make the +-- have a higher 'BufPos'. Contrast that with 'RealSrcLoc', which does *not* make the -- analogous guarantee about higher line/column numbers. -- -- This is due to #line and {-# LINE ... #-} pragmas that can arbitrarily @@ -247,6 +238,10 @@ mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc mkRealSrcLoc x line col = SrcLoc (LexicalFastString x) line col +-- | Indentation level is 1-indexed, so the leftmost column is 1. +leftmostColumn :: Int +leftmostColumn = 1 + getBufPos :: SrcLoc -> Strict.Maybe BufPos getBufPos (RealSrcLoc _ mbpos) = mbpos getBufPos (UnhelpfulLoc _) = Strict.Nothing @@ -453,6 +448,10 @@ isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True isGeneratedSrcSpan _ = False +isNoSrcSpan :: SrcSpan -> Bool +isNoSrcSpan (UnhelpfulSpan UnhelpfulNoLocationInfo) = True +isNoSrcSpan _ = False + -- | Create a "bad" 'SrcSpan' that has not location information mkGeneralSrcSpan :: FastString -> SrcSpan mkGeneralSrcSpan = UnhelpfulSpan . UnhelpfulOther @@ -639,9 +638,7 @@ -- We want to order RealSrcSpans first by the start point, then by the -- end point. instance Ord RealSrcSpan where - a `compare` b = - (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp` - (realSrcSpanEnd a `compare` realSrcSpanEnd b) + compare = on compare realSrcSpanStart S.<> on compare realSrcSpanEnd instance Show RealSrcLoc where show (SrcLoc filename row col) @@ -738,13 +735,12 @@ -- | We attach SrcSpans to lots of things, so let's have a datatype for it. data GenLocated l e = L l e deriving (Eq, Ord, Show, Data, Functor, Foldable, Traversable) +instance (NFData l, NFData e) => NFData (GenLocated l e) where + rnf (L l e) = rnf l `seq` rnf e type Located = GenLocated SrcSpan type RealLocated = GenLocated RealSrcSpan -mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b -mapLoc = fmap - unLoc :: GenLocated l e -> e unLoc (L _ e) = e @@ -823,10 +819,8 @@ leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering rightmost_smallest = compareSrcSpanBy (flip compare) leftmost_smallest = compareSrcSpanBy compare -leftmost_largest = compareSrcSpanBy $ \a b -> - (realSrcSpanStart a `compare` realSrcSpanStart b) - `thenCmp` - (realSrcSpanEnd b `compare` realSrcSpanEnd a) +leftmost_largest = compareSrcSpanBy $ + on compare realSrcSpanStart S.<> flip (on compare realSrcSpanEnd) compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b @@ -856,11 +850,6 @@ | otherwise = realSrcSpanStart parent <= realSrcSpanStart src && realSrcSpanEnd parent >= realSrcSpanEnd src -liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b) -liftL f (L loc a) = do - a' <- f a - return $ L loc a' - getRealSrcSpan :: RealLocated a -> RealSrcSpan getRealSrcSpan (L l _) = l @@ -900,33 +889,3 @@ mkSrcSpanPs :: PsSpan -> SrcSpan mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b) - --- | Layout information for declarations. -data LayoutInfo = - - -- | Explicit braces written by the user. - -- - -- @ - -- class C a where { foo :: a; bar :: a } - -- @ - ExplicitBraces - | - -- | 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 - - deriving (Eq, Ord, Show, Data) - --- | Indentation level is 1-indexed, so the leftmost column is 1. -leftmostColumn :: Int -leftmostColumn = 1 diff --git a/GHC/Types/TyThing.hs b/GHC/Types/TyThing.hs --- a/GHC/Types/TyThing.hs +++ b/GHC/Types/TyThing.hs @@ -183,9 +183,8 @@ implicitCoTyCon tc ++ -- for each data constructor in order, - -- the constructor, worker, and (possibly) wrapper - [ thing | dc <- tyConDataCons tc - , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ] + -- the constructor and associated implicit 'Id's + datacon_stuff -- NB. record selectors are *not* implicit, they have fully-fledged -- bindings that pass through the compilation pipeline as normal. where @@ -193,6 +192,23 @@ Nothing -> [] Just cl -> implicitClassThings cl + -- For each data constructor in order, + -- the constructor, worker, and (possibly) wrapper + -- + -- If the data constructor is in a "type data" declaration, + -- promote it to the type level now. + -- See Note [Type data declarations] in GHC.Rename.Module. + datacon_stuff :: [TyThing] + datacon_stuff + | isTypeDataTyCon tc = [ATyCon (promoteDataCon dc) | dc <- cons] + | otherwise + = [ty_thing | dc <- cons, + ty_thing <- AConLike (RealDataCon dc) : + dataConImplicitTyThings dc] + + cons :: [DataCon] + cons = tyConDataCons tc + -- For newtypes and closed type families (only) add the implicit coercion tycon implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc @@ -223,9 +239,19 @@ tyThingParent_maybe (AConLike cl) = case cl of RealDataCon dc -> Just (ATyCon (dataConTyCon dc)) PatSynCon{} -> Nothing -tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of - Just tc -> Just (ATyCon tc) - Nothing -> Nothing +tyThingParent_maybe (ATyCon tc) + | -- Special case for `type data` data constructors. They appear as an + -- ATyCon (not ADataCon) but we want to display them here as if they were + -- a DataCon (i.e. with the parent declaration) (#22817). + -- See Note [Type data declarations] in GHC.Rename.Module. + Just dc <- isPromotedDataCon_maybe tc + , let parent_tc = dataConTyCon dc + , isTypeDataTyCon parent_tc + = Just (ATyCon parent_tc) + | Just tc <- tyConAssoc_maybe tc + = Just (ATyCon tc) + | otherwise + = Nothing tyThingParent_maybe (AnId id) = case idDetails id of RecSelId { sel_tycon = RecSelData tc } -> Just (ATyCon tc) 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 @@ -21,7 +21,7 @@ import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe ) import GHC.Types.Name -import GHC.Core.Type ( ArgFlag(..), mkTyVarBinders ) +import GHC.Core.Type ( ForAllTyFlag(..), mkTyVarBinders ) import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) ) import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp ) @@ -31,8 +31,9 @@ import GHC.Iface.Make ( tyThingToIfaceDecl ) import GHC.Utils.Outputable -import GHC.Utils.Trace +import Data.Maybe ( isJust ) + -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API @@ -178,7 +179,7 @@ ppr_bndr :: Name -> Maybe (OccName -> SDoc) ppr_bndr name - | isBuiltInSyntax name + | isBuiltInSyntax name || isJust (namePun_maybe name) = Nothing | otherwise = case nameModule_maybe name of diff --git a/GHC/Types/Unique.hs b/GHC/Types/Unique.hs --- a/GHC/Types/Unique.hs +++ b/GHC/Types/Unique.hs @@ -59,6 +59,8 @@ import Data.Char ( chr, ord ) +import Language.Haskell.Syntax.Module.Name + {- ************************************************************************ * * @@ -75,7 +77,7 @@ The mask is typically an ASCII character. It is typically used to make it easier to distinguish uniques constructed by different parts of the compiler. There is a (potentially incomplete) list of unique masks used given in -GHC.Builtin.Uniques. See Note [Uniques-prelude - Uniques for wired-in Prelude things] +GHC.Builtin.Uniques. See Note [Uniques for wired-in prelude things and known masks] `mkUnique` constructs a `Unique` from its pieces mkUnique :: Char -> Int -> Unique @@ -187,6 +189,10 @@ instance Uniquable Int where getUnique i = mkUniqueGrimily i +instance Uniquable ModuleName where + getUnique (ModuleName nm) = getUnique nm + + {- ************************************************************************ * * @@ -275,13 +281,15 @@ = case unpkUnique uniq of (tag, u) -> tag : iToBase62 u -pprUniqueAlways :: Unique -> SDoc +pprUniqueAlways :: IsLine doc => Unique -> doc -- The "always" means regardless of -dsuppress-uniques -- It replaces the old pprUnique to remind callers that -- they should consider whether they want to consult -- Opt_SuppressUniques pprUniqueAlways u = text (showUnique u) +{-# SPECIALIZE pprUniqueAlways :: Unique -> SDoc #-} +{-# SPECIALIZE pprUniqueAlways :: Unique -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable instance Outputable Unique where ppr = pprUniqueAlways 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 @@ -58,6 +58,7 @@ udfmMinusUFM, ufmMinusUDFM, partitionUDFM, udfmRestrictKeys, + udfmRestrictKeysSet, anyUDFM, allUDFM, pprUniqDFM, pprUDFM, @@ -81,6 +82,7 @@ import Data.Function (on) import GHC.Types.Unique.FM (UniqFM, nonDetUFMToList, ufmToIntMap, unsafeIntMapToUFM) import Unsafe.Coerce +import qualified Data.IntSet as I -- Note [Deterministic UniqFM] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -300,9 +302,13 @@ k' acc (TaggedVal v _) = k v acc eltsUDFM :: UniqDFM key elt -> [elt] -eltsUDFM (UDFM m _i) = - map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m +{-# INLINE eltsUDFM #-} +-- The INLINE makes it a good producer (from the map) +eltsUDFM (UDFM m _i) = map taggedFst (sort_it m) +sort_it :: M.IntMap (TaggedVal elt) -> [TaggedVal elt] +sort_it m = sortBy (compare `on` taggedSnd) (M.elems m) + filterUDFM :: (elt -> Bool) -> UniqDFM key elt -> UniqDFM key elt filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i @@ -313,6 +319,11 @@ udfmRestrictKeys :: UniqDFM key elt -> UniqDFM key elt2 -> UniqDFM key elt udfmRestrictKeys (UDFM a i) (UDFM b _) = UDFM (M.restrictKeys a (M.keysSet b)) i + +udfmRestrictKeysSet :: UniqDFM key elt -> I.IntSet -> UniqDFM key elt +udfmRestrictKeysSet (UDFM val_set i) set = + let key_set = set + in UDFM (M.restrictKeys val_set key_set) i -- | Converts `UniqDFM` to a list, with elements in deterministic order. -- It's O(n log n) while the corresponding function on `UniqFM` is O(n). 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 @@ -40,7 +40,7 @@ listToUFM_Directly, listToUFM_C, listToIdentityUFM, - addToUFM,addToUFM_C,addToUFM_Acc, + addToUFM,addToUFM_C,addToUFM_Acc,addToUFM_L, addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, @@ -182,6 +182,24 @@ -> 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) + +-- | Add an element, returns previous lookup result and new map. If +-- old element doesn't exist, add the passed element directly, +-- otherwise compute the element to add using the passed function. +addToUFM_L + :: Uniquable key + => (key -> elt -> elt -> elt) -- key,old,new + -> key + -> elt -- new + -> UniqFM key elt + -> (Maybe elt, UniqFM key elt) -- old, result +addToUFM_L f k v (UFM m) = + coerce $ + M.insertLookupWithKey + (\_ _n _o -> f k _o _n) + (getKey $ getUnique k) + v + m alterUFM :: Uniquable key 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 @@ -20,6 +20,7 @@ addListToUniqMap, addToUniqMap_C, addToUniqMap_Acc, + addToUniqMap_L, alterUniqMap, addListToUniqMap_C, adjustUniqMap, @@ -31,6 +32,7 @@ plusUniqMapList, minusUniqMap, intersectUniqMap, + intersectUniqMap_C, disjointUniqMap, mapUniqMap, filterUniqMap, @@ -57,9 +59,10 @@ import Data.Coerce import Data.Maybe import Data.Data +import Control.DeepSeq -- | Maps indexed by 'Uniquable' keys -newtype UniqMap k a = UniqMap (UniqFM k (k, a)) +newtype UniqMap k a = UniqMap { getUniqMap :: UniqFM k (k, a) } deriving (Data, Eq, Functor) type role UniqMap nominal representational @@ -76,6 +79,9 @@ [ ppr k <+> text "->" <+> ppr v | (k, v) <- nonDetEltsUFM m ] +instance (NFData k, NFData a) => NFData (UniqMap k a) where + rnf (UniqMap fm) = seqEltsUFM rnf fm + liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a) liftC f (_, v) (k', v') = (k', f v v') @@ -123,6 +129,22 @@ (\b -> (k0, new b)) m k0 v0 +-- | Add an element, returns previous lookup result and new map. If +-- old element doesn't exist, add the passed element directly, +-- otherwise compute the element to add using the passed function. +addToUniqMap_L :: Uniquable k + => (k -> a -> a -> a) -- key,old,new + -> k + -> a -- new + -> UniqMap k a + -> (Maybe a, UniqMap k a) +addToUniqMap_L f k v (UniqMap m) = case addToUFM_L + (\_k (_, _o) (_, _n) -> (_k, f _k _o _n)) + k + (k, v) + m of + (_maybe, _ufm) -> (snd <$> _maybe, UniqMap _ufm) + alterUniqMap :: Uniquable k => (Maybe a -> Maybe a) -> UniqMap k a @@ -175,6 +197,10 @@ intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2 + +-- | 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 disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2 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 @@ -98,7 +98,7 @@ the same mask 's'. However in some places we create a unique supply using `mkSplitUniqSupply` and thread it through the code, while in GHC.Core.Opt.Simplify.Monad we use the `instance MonadUnique SimplM`, which uses `mkSplitUniqSupply` in getUniqueSupplyM -and `uniqFromMask` in getUniqeM. +and `uniqFromMask` in getUniqueM. Ultimately all these boil down to each new unique consisting of the mask and the result from a call to `genSym`. The later producing a distinct number for each invocation ensuring @@ -158,7 +158,7 @@ benefits of threading the mask this *also* has the benefit of avoiding the mask getting captured in thunks, or being passed around at runtime. It does however come at the cost of having to use a fixed Mask for all -code run in this Monad. But rememeber, the Mask is purely cosmetic: +code run in this Monad. But remember, the Mask is purely cosmetic: See Note [Uniques and masks]. NB: It's *not* an optimization to pass around the UniqSupply inside an diff --git a/GHC/Types/Var.hs b/GHC/Types/Var.hs --- a/GHC/Types/Var.hs +++ b/GHC/Types/Var.hs @@ -7,7 +7,6 @@ {-# LANGUAGE FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable, PatternSynonyms, BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- | @@ -66,20 +65,34 @@ isGlobalId, isExportedId, mustHaveLocalBinding, - -- * ArgFlags - ArgFlag(Invisible,Required,Specified,Inferred), - AnonArgFlag(..), Specificity(..), - isVisibleArgFlag, isInvisibleArgFlag, isInferredArgFlag, - sameVis, + -- * ForAllTyFlags + ForAllTyFlag(Invisible,Required,Specified,Inferred), + Specificity(..), + isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isInferredForAllTyFlag, + -- * FunTyFlag + FunTyFlag(..), isVisibleFunArg, isInvisibleFunArg, isFUNArg, + mkFunTyFlag, visArg, invisArg, + visArgTypeLike, visArgConstraintLike, + invisArgTypeLike, invisArgConstraintLike, + funTyFlagResultTypeOrConstraint, + TypeOrConstraint(..), -- Re-export this: it's an argument of FunTyFlag + + -- * PiTyBinder + PiTyBinder(..), PiTyVarBinder, + isInvisiblePiTyBinder, isVisiblePiTyBinder, + isTyBinder, isNamedPiTyBinder, isAnonPiTyBinder, + namedPiTyBinder_maybe, anonPiTyBinderType_maybe, piTyBinderType, + -- * TyVar's - VarBndr(..), TyCoVarBinder, TyVarBinder, InvisTVBinder, ReqTVBinder, - binderVar, binderVars, binderArgFlag, binderType, - mkTyCoVarBinder, mkTyCoVarBinders, + VarBndr(..), ForAllTyBinder, TyVarBinder, + InvisTyBinder, InvisTVBinder, ReqTyBinder, ReqTVBinder, + binderVar, binderVars, binderFlag, binderFlags, binderType, + mkForAllTyBinder, mkForAllTyBinders, mkTyVarBinder, mkTyVarBinders, isTyVarBinder, tyVarSpecToBinder, tyVarSpecToBinders, tyVarReqToBinder, tyVarReqToBinders, - mapVarBndr, mapVarBndrs, lookupVarBndr, + mapVarBndr, mapVarBndrs, -- ** Constructing TyVar's mkTyVar, mkTcTyVar, @@ -96,7 +109,7 @@ import GHC.Prelude -import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind, Mult ) +import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Kind, Mult, Scaled, scaledThing ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr( pprKind ) import {-# SOURCE #-} GHC.Tc.Utils.TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTvUnk ) import {-# SOURCE #-} GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCoVarDetails, @@ -105,6 +118,7 @@ import GHC.Types.Name hiding (varName) import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique , mkUniqueGrimily, nonDetCmpUnique ) +import GHC.Types.Basic( TypeOrConstraint(..) ) import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Outputable @@ -429,20 +443,20 @@ {- ********************************************************************* * * -* ArgFlag +* ForAllTyFlag * * ********************************************************************* -} --- | Argument Flag +-- | 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, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" -data ArgFlag = Invisible Specificity - | Required +-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" +data ForAllTyFlag = Invisible Specificity + | Required deriving (Eq, Ord, Data) - -- (<) on ArgFlag means "is less visible than" + -- (<) on ForAllTyFlag means "is less visible than" -- | Whether an 'Invisible' argument may appear in source Haskell. data Specificity = InferredSpec @@ -453,35 +467,27 @@ -- required. deriving (Eq, Ord, Data) -pattern Inferred, Specified :: ArgFlag +pattern Inferred, Specified :: ForAllTyFlag pattern Inferred = Invisible InferredSpec pattern Specified = Invisible SpecifiedSpec {-# COMPLETE Required, Specified, Inferred #-} --- | Does this 'ArgFlag' classify an argument that is written in Haskell? -isVisibleArgFlag :: ArgFlag -> Bool -isVisibleArgFlag af = not (isInvisibleArgFlag af) - --- | Does this 'ArgFlag' classify an argument that is not written in Haskell? -isInvisibleArgFlag :: ArgFlag -> Bool -isInvisibleArgFlag (Invisible {}) = True -isInvisibleArgFlag Required = False +-- | Does this 'ForAllTyFlag' classify an argument that is written in Haskell? +isVisibleForAllTyFlag :: ForAllTyFlag -> Bool +isVisibleForAllTyFlag af = not (isInvisibleForAllTyFlag af) -isInferredArgFlag :: ArgFlag -> Bool --- More restrictive than isInvisibleArgFlag -isInferredArgFlag (Invisible InferredSpec) = True -isInferredArgFlag _ = False +-- | Does this 'ForAllTyFlag' classify an argument that is not written in Haskell? +isInvisibleForAllTyFlag :: ForAllTyFlag -> Bool +isInvisibleForAllTyFlag (Invisible {}) = True +isInvisibleForAllTyFlag Required = False --- | 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. -sameVis :: ArgFlag -> ArgFlag -> Bool -sameVis Required Required = True -sameVis (Invisible _) (Invisible _) = True -sameVis _ _ = False +isInferredForAllTyFlag :: ForAllTyFlag -> Bool +-- More restrictive than isInvisibleForAllTyFlag +isInferredForAllTyFlag (Invisible InferredSpec) = True +isInferredForAllTyFlag _ = False -instance Outputable ArgFlag where +instance Outputable ForAllTyFlag where ppr Required = text "[req]" ppr Specified = text "[spec]" ppr Inferred = text "[infrd]" @@ -496,7 +502,7 @@ 0 -> return SpecifiedSpec _ -> return InferredSpec -instance Binary ArgFlag where +instance Binary ForAllTyFlag where put_ bh Required = putByte bh 0 put_ bh Specified = putByte bh 1 put_ bh Inferred = putByte bh 2 @@ -508,54 +514,111 @@ 1 -> return Specified _ -> return Inferred --- | The non-dependent version of 'ArgFlag'. --- See Note [AnonArgFlag] --- Appears here partly so that it's together with its friends ArgFlag +{- ********************************************************************* +* * +* FunTyFlag +* * +********************************************************************* -} + +-- | The non-dependent version of 'ForAllTyFlag'. +-- See Note [FunTyFlag] +-- Appears here partly so that it's together with its friends ForAllTyFlag -- and ForallVisFlag, but also because it is used in IfaceType, rather -- early in the compilation chain -data AnonArgFlag - = VisArg -- ^ Used for @(->)@: an ordinary non-dependent arrow. - -- The argument is visible in source code. - | InvisArg -- ^ Used for @(=>)@: a non-dependent predicate arrow. - -- The argument is invisible in source code. +data FunTyFlag + = FTF_T_T -- (->) Type -> Type + | FTF_T_C -- (-=>) Type -> Constraint + | FTF_C_T -- (=>) Constraint -> Type + | FTF_C_C -- (==>) Constraint -> Constraint deriving (Eq, Ord, Data) -instance Outputable AnonArgFlag where - ppr VisArg = text "[vis]" - ppr InvisArg = text "[invis]" +instance Outputable FunTyFlag where + ppr FTF_T_T = text "[->]" + ppr FTF_T_C = text "[-=>]" + ppr FTF_C_T = text "[=>]" + ppr FTF_C_C = text "[==>]" -instance Binary AnonArgFlag where - put_ bh VisArg = putByte bh 0 - put_ bh InvisArg = putByte bh 1 +instance Binary FunTyFlag where + put_ bh FTF_T_T = putByte bh 0 + put_ bh FTF_T_C = putByte bh 1 + put_ bh FTF_C_T = putByte bh 2 + put_ bh FTF_C_C = putByte bh 3 get bh = do h <- getByte bh case h of - 0 -> return VisArg - _ -> return InvisArg + 0 -> return FTF_T_T + 1 -> return FTF_T_C + 2 -> return FTF_C_T + _ -> return FTF_C_C -{- Note [AnonArgFlag] +mkFunTyFlag :: TypeOrConstraint -> TypeOrConstraint -> FunTyFlag +mkFunTyFlag TypeLike torc = visArg torc +mkFunTyFlag ConstraintLike torc = invisArg torc + +visArg :: TypeOrConstraint -> FunTyFlag +visArg TypeLike = FTF_T_T +visArg ConstraintLike = FTF_T_C + +visArgTypeLike :: FunTyFlag +visArgTypeLike = FTF_T_T + +visArgConstraintLike :: FunTyFlag +visArgConstraintLike = FTF_T_C + +invisArg :: TypeOrConstraint -> FunTyFlag +invisArg TypeLike = FTF_C_T +invisArg ConstraintLike = FTF_C_C + +invisArgTypeLike :: FunTyFlag +invisArgTypeLike = FTF_C_T + +invisArgConstraintLike :: FunTyFlag +invisArgConstraintLike = FTF_C_C + +isInvisibleFunArg :: FunTyFlag -> Bool +isInvisibleFunArg af = not (isVisibleFunArg af) + +isVisibleFunArg :: FunTyFlag -> Bool +isVisibleFunArg FTF_T_T = True +isVisibleFunArg FTF_T_C = True +isVisibleFunArg _ = False + +isFUNArg :: FunTyFlag -> Bool +-- This one, FUN, or (->), has an extra multiplicity argument +isFUNArg FTF_T_T = True +isFUNArg _ = False + +funTyFlagResultTypeOrConstraint :: FunTyFlag -> TypeOrConstraint +-- Whether it /returns/ a type or a constraint +funTyFlagResultTypeOrConstraint FTF_T_T = TypeLike +funTyFlagResultTypeOrConstraint FTF_C_T = TypeLike +funTyFlagResultTypeOrConstraint _ = ConstraintLike + +{- Note [FunTyFlag] ~~~~~~~~~~~~~~~~~~~~~ -AnonArgFlag is used principally in the FunTy constructor of Type. - FunTy VisArg t1 t2 means t1 -> t2 - FunTy InvisArg t1 t2 means t1 => t2 +FunTyFlag is used principally in the FunTy constructor of Type. + FunTy FTF_T_T t1 t2 means t1 -> t2 + FunTy FTF_C_T t1 t2 means t1 => t2 + FunTy FTF_T_C t1 t2 means t1 -=> t2 + FunTy FTF_C_C t1 t2 means t1 ==> t2 -However, the AnonArgFlag in a FunTy is just redundant, cached +However, the FunTyFlag in a FunTy is just redundant, cached information. In (FunTy { ft_af = af, ft_arg = t1, ft_res = t2 }) - * if (isPredTy t1 = True) then af = InvisArg - * if (isPredTy t1 = False) then af = VisArg + --------------------------------------------- + (isPredTy t1) (isPredTy ty) FunTyFlag + --------------------------------------------- + False False FTF_T_T + 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 -kind is Constraint. See GHC.Core.TyCo.Rep -Note [Types for coercions, predicates, and evidence] - -GHC.Core.Utils.mkFunctionType :: Mult -> Type -> Type -> Type -uses isPredTy to decide the AnonArgFlag for the FunTy. +kind is Constraint. See GHC.Core.Type.chooseFunTyFlag, and +GHC.Core.TyCo.Rep Note [Types for coercions, predicates, and evidence] -The term (Lam b e), and coercion (FunCo co1 co2) don't carry -AnonArgFlags; instead they use mkFunctionType when we want to -get their types; see mkLamType and coercionLKind/RKind resp. -This is just an engineering choice; we could cache here too -if we wanted. +The term (Lam b e) donesn'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. Why bother with all this? After all, we are in Core, where (=>) and (->) behave the same. We maintain this distinction throughout Core so @@ -591,7 +654,7 @@ {- ********************************************************************* * * -* VarBndr, TyCoVarBinder +* VarBndr, ForAllTyBinder * * ********************************************************************* -} @@ -600,29 +663,29 @@ VarBndr is polymorphic in both var and visibility fields. Currently there are nine different uses of 'VarBndr': -* Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag +* Var.ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag Binder of a forall-type; see ForAllTy in GHC.Core.TyCo.Rep -* Var.TyVarBinder = VarBndr TyVar ArgFlag - Subset of TyCoVarBinder when we are sure the binder is a TyVar +* Var.TyVarBinder = VarBndr TyVar ForAllTyFlag + Subset of ForAllTyBinder when we are sure the binder is a TyVar * Var.InvisTVBinder = VarBndr TyVar Specificity - Specialised form of TyVarBinder, when ArgFlag = Invisible s + Specialised form of TyVarBinder, when ForAllTyFlag = Invisible s See GHC.Core.Type.splitForAllInvisTVBinders * Var.ReqTVBinder = VarBndr TyVar () - Specialised form of TyVarBinder, when ArgFlag = Required + Specialised form of TyVarBinder, when ForAllTyFlag = Required See GHC.Core.Type.splitForAllReqTVBinders This one is barely used * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis Binders of a TyCon; see TyCon in GHC.Core.TyCon -* TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis +* TyCon.TyConPiTyBinder = VarBndr TyCoVar TyConBndrVis Binders of a PromotedDataCon See Note [Promoted GADT data constructors] in GHC.Core.TyCon -* IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ArgFlag +* IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ForAllTyFlag * IfaceType.IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis -} @@ -633,26 +696,29 @@ -- | Variable Binder -- --- A 'TyCoVarBinder' is the binder of a ForAllTy +-- 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 -- -- A 'TyVarBinder' is a binder with only TyVar -type TyCoVarBinder = VarBndr TyCoVar ArgFlag -type TyVarBinder = VarBndr TyVar ArgFlag -type InvisTVBinder = VarBndr TyVar Specificity -type ReqTVBinder = VarBndr TyVar () +type ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag +type InvisTyBinder = VarBndr TyCoVar Specificity +type ReqTyBinder = VarBndr TyCoVar () -tyVarSpecToBinders :: [VarBndr a Specificity] -> [VarBndr a ArgFlag] +type TyVarBinder = VarBndr TyVar ForAllTyFlag +type InvisTVBinder = VarBndr TyVar Specificity +type ReqTVBinder = VarBndr TyVar () + +tyVarSpecToBinders :: [VarBndr a Specificity] -> [VarBndr a ForAllTyFlag] tyVarSpecToBinders = map tyVarSpecToBinder -tyVarSpecToBinder :: VarBndr a Specificity -> VarBndr a ArgFlag +tyVarSpecToBinder :: VarBndr a Specificity -> VarBndr a ForAllTyFlag tyVarSpecToBinder (Bndr tv vis) = Bndr tv (Invisible vis) -tyVarReqToBinders :: [VarBndr a ()] -> [VarBndr a ArgFlag] +tyVarReqToBinders :: [VarBndr a ()] -> [VarBndr a ForAllTyFlag] tyVarReqToBinders = map tyVarReqToBinder -tyVarReqToBinder :: VarBndr a () -> VarBndr a ArgFlag +tyVarReqToBinder :: VarBndr a () -> VarBndr a ForAllTyFlag tyVarReqToBinder (Bndr tv _) = Bndr tv Required binderVar :: VarBndr tv argf -> tv @@ -661,15 +727,21 @@ binderVars :: [VarBndr tv argf] -> [tv] binderVars tvbs = map binderVar tvbs -binderArgFlag :: VarBndr tv argf -> argf -binderArgFlag (Bndr _ argf) = argf +binderFlag :: VarBndr tv argf -> argf +binderFlag (Bndr _ argf) = argf +binderFlags :: [VarBndr tv argf] -> [argf] +binderFlags tvbs = map binderFlag tvbs + binderType :: VarBndr TyCoVar argf -> Type binderType (Bndr tv _) = varType tv +isTyVarBinder :: VarBndr TyCoVar vis -> Bool +isTyVarBinder (Bndr tcv _) = isTyVar tcv + -- | Make a named binder -mkTyCoVarBinder :: vis -> TyCoVar -> VarBndr TyCoVar vis -mkTyCoVarBinder vis var = Bndr var vis +mkForAllTyBinder :: vis -> TyCoVar -> VarBndr TyCoVar vis +mkForAllTyBinder vis var = Bndr var vis -- | Make a named binder -- 'var' should be a type variable @@ -679,29 +751,21 @@ Bndr var vis -- | Make many named binders -mkTyCoVarBinders :: vis -> [TyCoVar] -> [VarBndr TyCoVar vis] -mkTyCoVarBinders vis = map (mkTyCoVarBinder vis) +mkForAllTyBinders :: vis -> [TyCoVar] -> [VarBndr TyCoVar vis] +mkForAllTyBinders vis = map (mkForAllTyBinder vis) -- | Make many named binders -- Input vars should be type variables mkTyVarBinders :: vis -> [TyVar] -> [VarBndr TyVar vis] mkTyVarBinders vis = map (mkTyVarBinder vis) -isTyVarBinder :: TyCoVarBinder -> Bool -isTyVarBinder (Bndr v _) = isTyVar v - mapVarBndr :: (var -> var') -> (VarBndr var flag) -> (VarBndr var' flag) mapVarBndr f (Bndr v fl) = Bndr (f v) fl mapVarBndrs :: (var -> var') -> [VarBndr var flag] -> [VarBndr var' flag] mapVarBndrs f = map (mapVarBndr f) -lookupVarBndr :: Eq var => var -> [VarBndr var flag] -> Maybe flag -lookupVarBndr var bndrs = lookup var zipped_bndrs - where - zipped_bndrs = map (\(Bndr v f) -> (v,f)) bndrs - -instance Outputable tv => Outputable (VarBndr tv ArgFlag) where +instance Outputable tv => Outputable (VarBndr tv ForAllTyFlag) where ppr (Bndr v Required) = ppr v ppr (Bndr v Specified) = char '@' <> ppr v ppr (Bndr v Inferred) = braces (ppr v) @@ -716,6 +780,270 @@ instance NamedThing tv => NamedThing (VarBndr tv flag) where getName (Bndr tv _) = getName tv + + +{- ********************************************************************** +* * + PiTyBinder +* * +********************************************************************** -} + +-- | A 'PiTyBinder' represents an argument to a function. PiTyBinders can be +-- dependent ('Named') or nondependent ('Anon'). They may also be visible or +-- not. See Note [PiTyBinders] +data PiTyBinder + = Named ForAllTyBinder -- A type-lambda binder, with a ForAllTyFlag + | Anon (Scaled Type) FunTyFlag -- A term-lambda binder. Type here can be CoercionTy. + -- The arrow is described by the FunTyFlag + deriving Data + +instance Outputable PiTyBinder where + ppr (Anon ty af) = ppr af <+> ppr ty + ppr (Named (Bndr v Required)) = ppr v + 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 + +-- | Does this binder bind an invisible argument? +isInvisiblePiTyBinder :: PiTyBinder -> Bool +isInvisiblePiTyBinder (Named (Bndr _ vis)) = isInvisibleForAllTyFlag vis +isInvisiblePiTyBinder (Anon _ af) = isInvisibleFunArg af + +-- | Does this binder bind a visible argument? +isVisiblePiTyBinder :: PiTyBinder -> Bool +isVisiblePiTyBinder = not . isInvisiblePiTyBinder + +isNamedPiTyBinder :: PiTyBinder -> Bool +isNamedPiTyBinder (Named {}) = True +isNamedPiTyBinder (Anon {}) = False + +namedPiTyBinder_maybe :: PiTyBinder -> Maybe TyCoVar +namedPiTyBinder_maybe (Named tv) = Just $ binderVar tv +namedPiTyBinder_maybe _ = Nothing + +-- | Does this binder bind a variable that is /not/ erased? Returns +-- 'True' for anonymous binders. +isAnonPiTyBinder :: PiTyBinder -> Bool +isAnonPiTyBinder (Named {}) = False +isAnonPiTyBinder (Anon {}) = True + +-- | Extract a relevant type, if there is one. +anonPiTyBinderType_maybe :: PiTyBinder -> Maybe Type +anonPiTyBinderType_maybe (Named {}) = Nothing +anonPiTyBinderType_maybe (Anon ty _) = Just (scaledThing ty) + +-- | If its a named binder, is the binder a tyvar? +-- Returns True for nondependent binder. +-- This check that we're really returning a *Ty*Binder (as opposed to a +-- coercion binder). That way, if/when we allow coercion quantification +-- in more places, we'll know we missed updating some function. +isTyBinder :: PiTyBinder -> Bool +isTyBinder (Named bnd) = isTyVarBinder bnd +isTyBinder _ = True + +piTyBinderType :: PiTyBinder -> Type +piTyBinderType (Named (Bndr tv _)) = varType tv +piTyBinderType (Anon ty _) = scaledThing ty + +{- Note [PiTyBinders] +~~~~~~~~~~~~~~~~~~~ +But a type like + forall a. Maybe a -> forall b. (a,b) -> b + +can be decomposed to a telescope of type [PiTyBinder], using splitPiTys. +That function splits off all leading foralls and arrows, giving + ([Named a, Anon (Maybe a), Named b, Anon (a,b)], b) + +A PiTyBinder represents the type of binders -- that is, the type of an +argument to a Pi-type. GHC Core currently supports two different +Pi-types: + + * Anon ty1 fun_flag: a non-dependent function type, + written with ->, e.g. ty1 -> ty2 + represented as FunTy ty1 ty2. These are + lifted to Coercions with the corresponding FunCo. + + * Named (Var tv forall_flag) + A dependent compile-time-only polytype, + written with forall, e.g. forall (a:*). ty + represented as ForAllTy (Bndr a v) ty + +Both forms of Pi-types classify terms/types that take an argument. In other +words, if `x` is either a function or a polytype, `x arg` makes sense +(for an appropriate `arg`). + +Wrinkles + +* The Anon constructor of PiTyBinder contains a FunTyFlag. Since + the PiTyBinder really only describes the /argument/ it should perhaps + only have a TypeOrConstraint rather than a full FunTyFlag. But it's + very convenient to have the full FunTyFlag, say in mkPiTys, so that's + what we do. + + +Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* A ForAllTy (used for both types and kinds) contains a ForAllTyBinder. + Each ForAllTyBinder + Bndr a tvis + is equipped with tvis::ForAllTyFlag, which says whether or not arguments + for this binder should be visible (explicit) in source Haskell. + +* A TyCon contains a list of TyConBinders. Each TyConBinder + Bndr a cvis + is equipped with cvis::TyConBndrVis, which says whether or not type + and kind arguments for this TyCon should be visible (explicit) in + source Haskell. + +This table summarises the visibility rules: +--------------------------------------------------------------------------------------- +| Occurrences look like this +| GHC displays type as in Haskell source code +|-------------------------------------------------------------------------------------- +| Bndr a tvis :: ForAllTyBinder, in the binder of ForAllTy for a term +| tvis :: ForAllTyFlag +| 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] +| +| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon +| cvis :: TyConBndrVis +| cvis = AnonTCB: T :: kind -> kind Required: T * +| cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T +| T :: forall {co}. kind Arg not allowed: T +| cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T +| cvis = NamedTCB Required: T :: forall k -> kind Required: T * +--------------------------------------------------------------------------------------- + +[1] In types, in the Specified case, it would make sense to allow + optional kind applications, thus (T @*), but we have not + yet implemented that + +---- In term declarations ---- + +* Inferred. Function defn, with no signature: f1 x = x + We infer f1 :: forall {a}. a -> a, with 'a' Inferred + It's Inferred because it doesn't appear in any + user-written signature for f1 + +* Specified. Function defn, with signature (implicit forall): + f2 :: a -> a; f2 x = x + So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified + even though 'a' is not bound in the source code by an explicit forall + +* Specified. Function defn, with signature (explicit forall): + f3 :: forall a. a -> a; f3 x = x + So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified + +* 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 + It's Inferred because the user marked it as such, even though it does appear + in the user-written signature for f4 + +* 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 + 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 + This time 'k' is Specified, because it is mentioned explicitly, + so we get f6 :: forall (k:*) (a:k->*) (b:k). a b -> Int + +* Similarly pattern synonyms: + Inferred - from inferred types (e.g. no pattern type signature) + - or from inferred kind polymorphism + +---- In type declarations ---- + +* Inferred (k) + data T1 a b = MkT1 (a b) + Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * + The kind variable 'k' is Inferred, since it is not mentioned + + Note that 'a' and 'b' correspond to /Anon/ PiTyBinders in T1's kind, + and Anon binders don't have a visibility flag. (Or you could think + of Anon having an implicit Required flag.) + +* Specified (k) + data T2 (a::k->*) b = MkT (a b) + Here T's kind is T :: forall (k:*). (k->*) -> k -> * + The kind variable 'k' is Specified, since it is mentioned in + the signature. + +* Required (k) + data T k (a::k->*) b = MkT (a b) + Here T's kind is T :: forall k:* -> (k->*) -> k -> * + The kind is Required, since it bound in a positional way in T's declaration + Every use of T must be explicitly applied to a kind + +* Inferred (k1), Specified (k) + data T a b (c :: k) = MkT (a b) (Proxy c) + Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * + So 'k' is Specified, because it appears explicitly, + but 'k1' is Inferred, because it does not + +Generally, in the list of TyConBinders for a TyCon, + +* Inferred arguments always come first +* Specified, Anon and Required can be mixed + +e.g. + data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... + +Here Foo's TyConBinders are + [Required 'a', Specified 'b', Anon] +and its kind prints as + Foo :: forall a -> forall b. (a -> b -> Type) -> Type + +See also Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl + +---- Printing ----- + + We print forall types with enough syntax to tell you their visibility + flag. But this is not source Haskell, and these types may not all + be parsable. + + Specified: a list of Specified binders is written between `forall` and `.`: + 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 + + Required: binders are put between `forall` and `->`: + T :: forall k -> * + +---- Other points ----- + +* In classic Haskell, all named binders (that is, the type variables in + a polymorphic function type f :: forall a. a -> a) have been Inferred. + +* 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. +-} + + {- ************************************************************************ 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 @@ -9,8 +9,8 @@ -- otherwise-unnecessary import tells the build system that this module -- depends on GhcPrelude, which ensures that GHC.Type is built first. -data ArgFlag -data AnonArgFlag +data ForAllTyFlag +data FunTyFlag data Var instance NamedThing Var data VarBndr var argf 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 @@ -9,7 +9,7 @@ -- ** Manipulating these environments emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, - elemVarEnv, disjointVarEnv, + elemVarEnv, disjointVarEnv, anyVarEnv, extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnvList, plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, @@ -23,7 +23,7 @@ isEmptyVarEnv, elemVarEnvByKey, filterVarEnv, restrictVarEnv, - partitionVarEnv, + partitionVarEnv, varEnvDomain, -- * Deterministic Var environments (maps) DVarEnv, DIdEnv, DTyVarEnv, @@ -47,10 +47,10 @@ anyDVarEnv, -- * The InScopeSet type - InScopeSet, + InScopeSet(..), -- ** Operations on InScopeSets - emptyInScopeSet, mkInScopeSet, delInScopeSet, + emptyInScopeSet, mkInScopeSet, mkInScopeSetList, delInScopeSet, extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, getInScopeVars, lookupInScope, lookupInScope_Directly, unionInScope, elemInScopeSet, uniqAway, @@ -62,7 +62,8 @@ -- ** Operations on RnEnv2s mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var, - rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, + rnOccL, rnOccR, inRnEnvL, inRnEnvR, anyInRnEnvR, + rnOccL_maybe, rnOccR_maybe, rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, delBndrL, delBndrR, delBndrsL, delBndrsR, extendRnInScopeSetList, @@ -82,6 +83,7 @@ import GHC.Types.Name import GHC.Types.Var as Var import GHC.Types.Var.Set +import GHC.Data.Graph.UnVar -- UnVarSet import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique.DFM @@ -148,6 +150,9 @@ mkInScopeSet :: VarSet -> InScopeSet mkInScopeSet in_scope = InScope in_scope +mkInScopeSetList :: [Var] -> InScopeSet +mkInScopeSetList vs = InScope (mkVarSet vs) + extendInScopeSet :: InScopeSet -> Var -> InScopeSet extendInScopeSet (InScope in_scope) v = InScope (extendVarSet in_scope v) @@ -400,6 +405,14 @@ inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env +-- | `anyInRnEnvR env set` == `any (inRnEnvR rn_env) (toList set)` +-- but lazy in the second argument if the right side of the env is empty. +anyInRnEnvR :: RnEnv2 -> VarSet -> Bool +anyInRnEnvR (RV2 { envR = env }) vs + -- Avoid allocating the predicate if we deal with an empty env. + | isEmptyVarEnv env = False + | otherwise = anyVarSet (`elemVarEnv` env) vs + lookupRnInScope :: RnEnv2 -> Var -> Var lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v @@ -493,8 +506,10 @@ plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a plusVarEnvList :: [VarEnv a] -> VarEnv a extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a +varEnvDomain :: VarEnv elt -> UnVarSet 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 delVarEnv :: VarEnv a -> Var -> VarEnv a @@ -509,6 +524,7 @@ lookupVarEnv :: VarEnv a -> Var -> Maybe a lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a +anyVarEnv :: (elt -> Bool) -> UniqFM key elt -> Bool lookupVarEnv_NF :: VarEnv a -> Var -> a lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a elemVarEnv :: Var -> VarEnv a -> Bool @@ -539,6 +555,7 @@ lookupVarEnv = lookupUFM lookupVarEnv_Directly = lookupUFM_Directly filterVarEnv = filterUFM +anyVarEnv = anyUFM lookupWithDefaultVarEnv = lookupWithDefaultUFM mapVarEnv = mapUFM mkVarEnv = listToUFM @@ -546,8 +563,10 @@ emptyVarEnv = emptyUFM unitVarEnv = unitUFM isEmptyVarEnv = isNullUFM -partitionVarEnv = partitionUFM +partitionVarEnv = partitionUFM +varEnvDomain = domUFMUnVarSet + restrictVarEnv env vs = filterUFM_Directly keep env where keep u _ = u `elemVarSetByKey` vs @@ -556,6 +575,7 @@ lookupVarEnv_NF env id = case lookupVarEnv env id of Just xx -> xx Nothing -> panic "lookupVarEnv_NF: Nothing" + {- @modifyVarEnv@: Look up a thing in the VarEnv, diff --git a/GHC/Unit.hs b/GHC/Unit.hs --- a/GHC/Unit.hs +++ b/GHC/Unit.hs @@ -144,7 +144,7 @@ You can think of this as polymorphism at the module level: module signatures give constraints on the "type" of module that can be used to fill the hole -(where "type" means types of the exported module entitites, etc.). +(where "type" means types of the exported module entities, etc.). Module signatures contain enough information (datatypes, abstract types, type synonyms, classes, etc.) to typecheck modules depending on them but not diff --git a/GHC/Unit/Env.hs b/GHC/Unit/Env.hs --- a/GHC/Unit/Env.hs +++ b/GHC/Unit/Env.hs @@ -3,8 +3,10 @@ module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv + , ueEPS , unsafeGetHomeUnit , updateHug + , updateHpt_lazy , updateHpt -- * Unit Env helper functions , ue_units @@ -36,6 +38,7 @@ , addHomeModInfoToHug -- * UnitEnvGraph , UnitEnvGraph (..) + , UnitEnvGraphKey , unitEnv_insert , unitEnv_delete , unitEnv_adjust @@ -49,6 +52,7 @@ , unitEnv_elts , unitEnv_hpts , unitEnv_foldWithKey + , unitEnv_union , unitEnv_mapWithKey -- * Invariants , assertUnitEnvInvariant @@ -99,6 +103,9 @@ -- ^ GHC name/version (used for dynamic library suffix) } +ueEPS :: UnitEnv -> IO ExternalPackageState +ueEPS = eucEPS . ue_eps + initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv initUnitEnv cur_unit hug namever platform = do eps <- initExternalUnitCache @@ -116,6 +123,9 @@ 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 @@ -263,7 +273,9 @@ go (Just hue) = Just (updateHueHpt (addHomeModInfoToHpt hmi) hue) updateHueHpt :: (HomePackageTable -> HomePackageTable) -> HomeUnitEnv -> HomeUnitEnv -updateHueHpt f hue = hue { homeUnitEnv_hpt = f (homeUnitEnv_hpt hue)} +updateHueHpt f hue = + let !hpt = f (homeUnitEnv_hpt hue) + in hue { homeUnitEnv_hpt = hpt } lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> Maybe HomeModInfo @@ -339,6 +351,9 @@ unitEnv_foldWithKey :: (b -> UnitEnvGraphKey -> a -> b) -> b -> UnitEnvGraph a -> b unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g +unitEnv_union :: (a -> a -> a) -> UnitEnvGraph a -> UnitEnvGraph a -> UnitEnvGraph a +unitEnv_union f (UnitEnvGraph env1) (UnitEnvGraph env2) = UnitEnvGraph (Map.unionWith f env1 env2) + -- ------------------------------------------------------- -- Query and modify UnitState in HomeUnitEnv -- ------------------------------------------------------- @@ -366,16 +381,26 @@ 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_updateHPT :: HasDebugCallStack => (HomePackageTable -> HomePackageTable) -> UnitEnv -> UnitEnv ue_updateHPT f e = ue_updateUnitHPT f (ue_currentUnit e) 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 = unitEnv { homeUnitEnv_hpt = f $ homeUnitEnv_hpt unitEnv } + 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)} @@ -531,7 +556,7 @@ a unit is identified by the -this-unit-id flag and dependencies specified by the normal -package-id flag. 2. Downsweep is augmented to know to know how to look for dependencies in any home unit. -3. The rest of the compiler is modified appropiately to offset paths to the right places. +3. The rest of the compiler is modified appropriately to offset paths to the right places. 4. --make mode can parallelise between home units and multiple units are allowed to produce linkables. Closure Property @@ -548,12 +573,12 @@ Offsetting Paths ---------------- -The main complication to the implementation is to do with offsetting paths appropiately. +The main complication to the implementation is to do with offsetting paths appropriately. For a long time it has been assumed that GHC will execute in the top-directory for a unit, normally where the .cabal file is and all paths are interpreted relative to there. When you have multiple home units then it doesn't make sense to pick one of these units to choose as the base-unit, and you can't robustly change directories when -using parralelism. +using parallelism. Therefore there is an option `-working-directory`, which tells GHC where the relative paths for each unit should be interpreted relative to. For example, if you specify diff --git a/GHC/Unit/External.hs b/GHC/Unit/External.hs --- a/GHC/Unit/External.hs +++ b/GHC/Unit/External.hs @@ -1,6 +1,7 @@ module GHC.Unit.External ( ExternalUnitCache (..) , initExternalUnitCache + , eucEPS , ExternalPackageState (..) , initExternalPackageState , EpsStats(..) @@ -20,11 +21,10 @@ import GHC.Unit import GHC.Unit.Module.ModIface -import GHC.Core ( RuleBase ) import GHC.Core.FamInstEnv import GHC.Core.InstEnv ( InstEnv, emptyInstEnv ) import GHC.Core.Opt.ConstantFold -import GHC.Core.Rules (mkRuleBase) +import GHC.Core.Rules ( RuleBase, mkRuleBase) import GHC.Types.Annotations ( AnnEnv, emptyAnnEnv ) import GHC.Types.CompleteMatch @@ -59,6 +59,9 @@ initExternalUnitCache :: IO ExternalUnitCache initExternalUnitCache = ExternalUnitCache <$> newIORef initExternalPackageState +eucEPS :: ExternalUnitCache -> IO ExternalPackageState +eucEPS = readIORef . euc_eps + initExternalPackageState :: ExternalPackageState initExternalPackageState = EPS { eps_is_boot = emptyInstalledModuleEnv @@ -151,7 +154,7 @@ eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external -- packages, keyed off the module that declared them - eps_stats :: !EpsStats -- ^ Stastics about what was loaded from external packages + eps_stats :: !EpsStats -- ^ Statistics about what was loaded from external packages } -- | Accumulated statistics about what we are putting into the 'ExternalPackageState'. diff --git a/GHC/Unit/Home.hs b/GHC/Unit/Home.hs --- a/GHC/Unit/Home.hs +++ b/GHC/Unit/Home.hs @@ -33,8 +33,9 @@ import GHC.Prelude import GHC.Unit.Types -import GHC.Unit.Module.Name import Data.Maybe + +import Language.Haskell.Syntax.Module.Name -- | Information about the home unit (i.e., the until that will contain the -- modules we are compiling) 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,13 @@ -- | Info about modules in the "home" unit module GHC.Unit.Home.ModInfo ( HomeModInfo (..) + , HomeModLinkable(..) + , homeModInfoObject + , homeModInfoByteCode + , emptyHomeModInfoLinkable + , justBytecode + , justObjects + , bytecodeAndObjects , HomePackageTable , emptyHomePackageTable , lookupHpt @@ -27,7 +34,7 @@ import GHC.Unit.Module.ModDetails import GHC.Unit.Module -import GHC.Linker.Types ( Linkable(..) ) +import GHC.Linker.Types ( Linkable(..), isObjectLinkable ) import GHC.Types.Unique import GHC.Types.Unique.DFM @@ -35,6 +42,7 @@ 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 @@ -48,24 +56,77 @@ -- This field is LAZY because a ModDetails is constructed by knot tying. - , hm_linkable :: !(Maybe Linkable) + , hm_linkable :: !HomeModLinkable -- ^ The actual artifact we would like to link to access things in - -- this module. + -- this module. See Note [Home module build products] -- - -- 'hm_linkable' might be Nothing: + -- 'hm_linkable' might be empty: -- -- 1. If this is an .hs-boot module -- -- 2. Temporarily during compilation if we pruned away -- the old linkable because it was out of date. -- - -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields - -- in the 'HomePackageTable' will be @Just@. - -- -- When re-linking a module ('GHC.Driver.Main.HscNoRecomp'), we construct the -- 'HomeModInfo' by building a new 'ModDetails' from the old -- 'ModIface' (only). } + +homeModInfoByteCode :: HomeModInfo -> Maybe Linkable +homeModInfoByteCode = homeMod_bytecode . hm_linkable + +homeModInfoObject :: HomeModInfo -> Maybe Linkable +homeModInfoObject = homeMod_object . hm_linkable + +emptyHomeModInfoLinkable :: HomeModLinkable +emptyHomeModInfoLinkable = HomeModLinkable Nothing Nothing + +-- See Note [Home module build products] +data HomeModLinkable = HomeModLinkable { homeMod_bytecode :: !(Maybe Linkable) + , homeMod_object :: !(Maybe Linkable) } + +instance Outputable HomeModLinkable where + ppr (HomeModLinkable l1 l2) = ppr l1 $$ ppr l2 + +justBytecode :: Linkable -> HomeModLinkable +justBytecode lm = + assertPpr (not (isObjectLinkable lm)) (ppr lm) + $ emptyHomeModInfoLinkable { homeMod_bytecode = Just lm } + +justObjects :: Linkable -> HomeModLinkable +justObjects lm = + assertPpr (isObjectLinkable 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) + (HomeModLinkable (Just bc) (Just o)) + + +{- +Note [Home module build products] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When compiling a home module we can produce some combination of the following +build products. + +1. A byte code linkable, for use with the byte code interpreter. +2. An object file linkable, for linking a final executable or the byte code interpreter + +What we have produced is recorded in the `HomeModLinkable` type. In the case +that these linkables are produced they are stored in the relevant field so that +subsequent modules can retrieve and use them as necessary. + +* `-fbyte-code` will *only* produce a byte code linkable. This is the default in GHCi. +* `-fobject-code` will *only* produce an object file linkable. This is the default in -c and --make mode. +* `-fbyte-code-and-object-code` produces both a byte-code and object file linkable. So both fields are populated. + +Why would you want to produce both an object file and byte code linkable? If you +also want to use `-fprefer-byte-code` then you should probably also use this +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 diff --git a/GHC/Unit/Module.hs b/GHC/Unit/Module.hs --- a/GHC/Unit/Module.hs +++ b/GHC/Unit/Module.hs @@ -18,7 +18,7 @@ ( module GHC.Unit.Types -- * The ModuleName type - , module GHC.Unit.Module.Name + , module Language.Haskell.Syntax.Module.Name -- * The ModLocation type , module GHC.Unit.Module.Location @@ -47,11 +47,13 @@ import GHC.Types.Unique.DSet import GHC.Unit.Types -import GHC.Unit.Module.Name import GHC.Unit.Module.Location import GHC.Unit.Module.Env -import GHC.Utils.Misc +import Language.Haskell.Syntax.Module.Name + +import Data.Semigroup + -- | A 'Module' is definite if it has no free holes. moduleIsDefinite :: Module -> Bool moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles @@ -68,9 +70,7 @@ -- gives an ordering based on the 'Unique's of the components, which may -- not be stable from run to run of the compiler. stableModuleCmp :: Module -> Module -> Ordering -stableModuleCmp (Module p1 n1) (Module p2 n2) - = (p1 `stableUnitCmp` p2) `thenCmp` - (n1 `stableModuleNameCmp` n2) +stableModuleCmp (Module p1 n1) (Module p2 n2) = stableUnitCmp p1 p2 <> stableModuleNameCmp n1 n2 class ContainsModule t where extractModule :: t -> Module 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 @@ -24,7 +24,6 @@ import GHC.Types.SafeHaskell import GHC.Types.Name -import GHC.Unit.Module.Name import GHC.Unit.Module.Imported import GHC.Unit.Module import GHC.Unit.Home 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 @@ -9,7 +9,7 @@ , partitionModuleEnv , moduleEnvKeys, moduleEnvElts, moduleEnvToList , unitModuleEnv, isEmptyModuleEnv - , extendModuleEnvWith, filterModuleEnv + , extendModuleEnvWith, filterModuleEnv, mapMaybeModuleEnv -- * ModuleName mappings , ModuleNameEnv, DModuleNameEnv @@ -37,12 +37,10 @@ import GHC.Prelude -import GHC.Unit.Module.Name (ModuleName) import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Unit.Types -import GHC.Utils.Misc import Data.List (sortBy, sort) import Data.Ord @@ -51,9 +49,12 @@ import Data.Set (Set) import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Semigroup as S import qualified GHC.Data.FiniteMap as Map import GHC.Utils.Outputable +import Language.Haskell.Syntax.Module.Name + -- | A map keyed off of 'Module's newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) @@ -72,7 +73,7 @@ ordering on Module and normalizes by doing the lexicographic sort when turning the env to a list. See Note [Unique Determinism] for more information about the source of -nondeterminismand and Note [Deterministic UniqFM] for explanation of why +nondeterminism and Note [Deterministic UniqFM] for explanation of why it matters for maps. -} @@ -86,12 +87,16 @@ instance Ord NDModule where compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) = - (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp` + (getUnique p1 `nonDetCmpUnique` getUnique p2) S.<> (getUnique n1 `nonDetCmpUnique` getUnique n2) filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a filterModuleEnv f (ModuleEnv e) = ModuleEnv (Map.filterWithKey (f . unNDModule) e) + +mapMaybeModuleEnv :: (Module -> a -> Maybe b) -> ModuleEnv a -> ModuleEnv b +mapMaybeModuleEnv f (ModuleEnv e) = + ModuleEnv (Map.mapMaybeWithKey (f . unNDModule) e) elemModuleEnv :: Module -> ModuleEnv a -> Bool elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e 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 @@ -29,6 +29,7 @@ , NodeKey(..) , nodeKeyUnitId + , nodeKeyModName , ModNodeKey , mkNodeKey , msKey @@ -41,6 +42,7 @@ where import GHC.Prelude +import GHC.Platform import qualified GHC.LanguageExtensions as LangExt @@ -48,7 +50,6 @@ import GHC.Data.Graph.Directed import GHC.Driver.Backend -import GHC.Driver.Ppr import GHC.Driver.Session import GHC.Types.SourceFile ( hscSourceString ) @@ -126,6 +127,10 @@ 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) @@ -258,7 +263,8 @@ _ -> False platform = targetPlatform dflags - exe_file = exeFileName platform staticLink (outputFile_ 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 @@ -273,17 +279,16 @@ where op = normalise - mod = moduleName (ms_mod mod_summary) - mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) + 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 - message = case backend dflags of - Interpreter | recomp -> text "interpreted" - NoBackend -> text "nothing" - _ -> - if gopt Opt_BuildDynamicToo dflags - then text obj_file <> comma <+> text dyn_file - else text obj_file + 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) 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 @@ -1,5 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -128,11 +128,11 @@ -- | Selects a IfaceDecl representation. -- For fully instantiated interfaces we also maintain -- a fingerprint, which is used for recompilation checks. -type family IfaceDeclExts (phase :: ModIfacePhase) where +type family IfaceDeclExts (phase :: ModIfacePhase) = decl | decl -> phase where IfaceDeclExts 'ModIfaceCore = IfaceDecl IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl) -type family IfaceBackendExts (phase :: ModIfacePhase) where +type family IfaceBackendExts (phase :: ModIfacePhase) = bk | bk -> phase where IfaceBackendExts 'ModIfaceCore = () IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend @@ -200,6 +200,11 @@ -- 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 @@ -235,7 +240,7 @@ -- See Note [Trust Own Package] in GHC.Rename.Names mi_complete_matches :: ![IfaceCompleteMatch], - mi_docs :: Maybe Docs, + mi_docs :: !(Maybe Docs), -- ^ Docstrings and related data for use by haddock, the ghci -- @:doc@ command, and other tools. -- @@ -349,6 +354,7 @@ 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, @@ -392,6 +398,7 @@ lazyPut bh warns lazyPut bh anns put_ bh decls + put_ bh extra_decls put_ bh insts put_ bh fam_insts lazyPut bh rules @@ -423,6 +430,7 @@ 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 @@ -446,6 +454,7 @@ 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, @@ -494,6 +503,7 @@ mi_fam_insts = [], mi_rules = [], mi_decls = [], + mi_extra_decls = Nothing, mi_globals = Nothing, mi_hpc = False, mi_trust = noIfaceTrustInfo, @@ -541,11 +551,12 @@ -- 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) = + 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` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq` - rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23 + f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` 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) 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 @@ -76,7 +76,7 @@ ms_textual_imps :: [(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 explicitliy + -- ^ 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. diff --git a/GHC/Unit/Module/Name.hs b/GHC/Unit/Module/Name.hs deleted file mode 100644 --- a/GHC/Unit/Module/Name.hs +++ /dev/null @@ -1,98 +0,0 @@ - --- | The ModuleName type -module GHC.Unit.Module.Name - ( ModuleName - , pprModuleName - , moduleNameFS - , moduleNameString - , moduleNameSlashes, moduleNameColons - , mkModuleName - , mkModuleNameFS - , stableModuleNameCmp - , parseModuleName - ) -where - -import GHC.Prelude - -import GHC.Utils.Outputable -import GHC.Types.Unique -import GHC.Data.FastString -import GHC.Utils.Binary -import GHC.Utils.Misc - -import Control.DeepSeq -import Data.Data -import System.FilePath - -import qualified Text.ParserCombinators.ReadP as Parse -import Text.ParserCombinators.ReadP (ReadP) -import Data.Char (isAlphaNum) - --- | A ModuleName is essentially a simple string, e.g. @Data.List@. -newtype ModuleName = ModuleName FastString deriving Show - -instance Uniquable ModuleName where - getUnique (ModuleName nm) = getUnique nm - -instance Eq ModuleName where - nm1 == nm2 = getUnique nm1 == getUnique nm2 - -instance Ord ModuleName where - nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 - -instance Outputable ModuleName where - ppr = pprModuleName - -instance Binary ModuleName where - put_ bh (ModuleName fs) = put_ bh fs - get bh = do fs <- get bh; return (ModuleName fs) - -instance Data ModuleName where - -- don't traverse? - toConstr _ = abstractConstr "ModuleName" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "ModuleName" - -instance NFData ModuleName where - rnf x = x `seq` () - -stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering --- ^ Compares module names lexically, rather than by their 'Unique's -stableModuleNameCmp n1 n2 = moduleNameFS n1 `lexicalCompareFS` moduleNameFS n2 - -pprModuleName :: ModuleName -> SDoc -pprModuleName (ModuleName nm) = - getPprStyle $ \ sty -> - if codeStyle sty - then ztext (zEncodeFS nm) - else ftext nm - -moduleNameFS :: ModuleName -> FastString -moduleNameFS (ModuleName mod) = mod - -moduleNameString :: ModuleName -> String -moduleNameString (ModuleName mod) = unpackFS mod - -mkModuleName :: String -> ModuleName -mkModuleName s = ModuleName (mkFastString s) - -mkModuleNameFS :: FastString -> ModuleName -mkModuleNameFS s = ModuleName s - --- |Returns the string version of the module name, with dots replaced by slashes. --- -moduleNameSlashes :: ModuleName -> String -moduleNameSlashes = dots_to_slashes . moduleNameString - where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) - --- |Returns the string version of the module name, with dots replaced by colons. --- -moduleNameColons :: ModuleName -> String -moduleNameColons = dots_to_colons . moduleNameString - where dots_to_colons = map (\c -> if c == '.' then ':' else c) - -parseModuleName :: ReadP ModuleName -parseModuleName = fmap mkModuleName - $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") - diff --git a/GHC/Unit/Module/Name.hs-boot b/GHC/Unit/Module/Name.hs-boot deleted file mode 100644 --- a/GHC/Unit/Module/Name.hs-boot +++ /dev/null @@ -1,6 +0,0 @@ -module GHC.Unit.Module.Name where - -import GHC.Prelude () - -data ModuleName - 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 @@ -10,13 +10,13 @@ import GHC.Unit.Module.ModIface import GHC.Utils.Fingerprint -import GHC.Linker.Types import GHC.Utils.Outputable +import GHC.Unit.Home.ModInfo -- | Status of a module in incremental compilation data HscRecompStatus -- | Nothing to do because code already exists. - = HscUpToDate ModIface (Maybe Linkable) + = HscUpToDate ModIface HomeModLinkable -- | Recompilation of module, or update of interface is required. Optionally -- pass the old interface hash to avoid updating the existing interface when -- it has not changed. 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,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -29,6 +30,7 @@ import Language.Haskell.Syntax.Extension import Data.Data +import GHC.Generics ( Generic ) -- | Warning Text -- @@ -40,6 +42,7 @@ | DeprecatedTxt (Located SourceText) [Located (WithHsDocIdentifiers StringLiteral pass)] + deriving Generic deriving instance Eq (IdP pass) => Eq (WarningTxt pass) deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) @@ -58,21 +61,21 @@ instance Binary (WarningTxt GhcRn) where put_ bh (WarningTxt s w) = do putByte bh 0 - put_ bh s - put_ bh w + put_ bh $ unLoc s + put_ bh $ unLoc <$> w put_ bh (DeprecatedTxt s d) = do putByte bh 1 - put_ bh s - put_ bh d + put_ bh $ unLoc s + put_ bh $ unLoc <$> d get bh = do h <- getByte bh case h of - 0 -> do s <- get bh - w <- get bh + 0 -> do s <- noLoc <$> get bh + w <- fmap noLoc <$> get bh return (WarningTxt s w) - _ -> do s <- get bh - d <- get bh + _ -> do s <- noLoc <$> get bh + d <- fmap noLoc <$> get bh return (DeprecatedTxt s d) diff --git a/GHC/Unit/Module/WholeCoreBindings.hs b/GHC/Unit/Module/WholeCoreBindings.hs new file mode 100644 --- /dev/null +++ b/GHC/Unit/Module/WholeCoreBindings.hs @@ -0,0 +1,63 @@ +module GHC.Unit.Module.WholeCoreBindings where + +import GHC.Unit.Types (Module) +import GHC.Unit.Module.Location +import GHC.Iface.Syntax + +{- +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 +is stored in the normal interface file and the other fields populated whilst loading +the interface file. + +The lifecycle of a WholeCoreBindings typically proceeds as follows: + +1. The ModIface which contains mi_extra_decls is loaded from disk. A linkable is + created (which is headed by the `CoreBindings` constructor). This is an unhydrated set of bindings which + is currently unsuitable for linking, but at the point it is loaded, the ModIface + hasn't been hydrated yet (See Note [Hydrating Modules]) either so the CoreBindings constructor allows the delaying of converting + 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 + 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. + 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 + the linkable is used as before. + +The flag `-fwrite-if-simplified-core` determines whether the extra information is written +to an interface file. The program which is written is the core bindings of the module +after whatever simplification the user requested has been performed. So the simplified core bindings +of the interface file agree with the optimisation level as reported by the interface +file. + +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 + +| Project | .hi | .hi (fat) | .o | +| --------| ---- | --------- | -- | +| ghc | 32M | 68M | 127M | +| Cabal | 3.2M | 9.8M | 14M | + +So the interface files gained in size but the end result was still smaller than +the object files. + +-} + +data WholeCoreBindings = WholeCoreBindings + { 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. + } diff --git a/GHC/Unit/Parser.hs b/GHC/Unit/Parser.hs --- a/GHC/Unit/Parser.hs +++ b/GHC/Unit/Parser.hs @@ -10,13 +10,14 @@ import GHC.Prelude import GHC.Unit.Types -import GHC.Unit.Module.Name import GHC.Data.FastString import qualified Text.ParserCombinators.ReadP as Parse import Text.ParserCombinators.ReadP (ReadP, (<++)) import Data.Char (isAlphaNum) +import Language.Haskell.Syntax.Module.Name (ModuleName, parseModuleName) + parseUnit :: ReadP Unit parseUnit = parseVirtUnitId <++ parseDefUnitId where @@ -54,5 +55,4 @@ _ <- Parse.char '=' v <- parseHoleyModule return (k, v) - diff --git a/GHC/Unit/State.hs b/GHC/Unit/State.hs --- a/GHC/Unit/State.hs +++ b/GHC/Unit/State.hs @@ -538,13 +538,13 @@ lookupUnitId' db uid = Map.lookup uid db --- | Looks up the given unit in the unit state, panicing if it is not found +-- | Looks up the given unit in the unit state, panicking if it is not found unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo unsafeLookupUnit state u = case lookupUnit state u of Just info -> info Nothing -> pprPanic "unsafeLookupUnit" (ppr u) --- | Looks up the given unit id in the unit state, panicing if it is not found +-- | Looks up the given unit id in the unit state, panicking if it is not found unsafeLookupUnitId :: HasDebugCallStack => UnitState -> UnitId -> UnitInfo unsafeLookupUnitId state uid = case lookupUnitId state uid of Just info -> info @@ -711,8 +711,8 @@ let base_conf_refs = case e_pkg_path of Left _ -> system_conf_refs Right path - | not (null path) && isSearchPathSeparator (last path) - -> map PkgDbPath (splitSearchPath (init path)) ++ system_conf_refs + | Just (xs, x) <- snocView path, isSearchPathSeparator x + -> map PkgDbPath (splitSearchPath xs) ++ system_conf_refs | otherwise -> map PkgDbPath (splitSearchPath path) @@ -1117,31 +1117,29 @@ -- available. -- findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo)) - findWiredInUnit pkgs wired_pkg = - let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] - all_exposed_ps = - [ p | p <- all_ps - , Map.member (mkUnit p) vis_map ] in - case all_exposed_ps of - [] -> case all_ps of - [] -> notfound - many -> pick (head (sortByPreference prec_map many)) - many -> pick (head (sortByPreference prec_map many)) + 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 ] + + try ps = case sortByPreference prec_map ps of + p:_ -> Just <$> pick p + _ -> pure Nothing + notfound = do debugTraceMsg logger 2 $ text "wired-in package " <> ftext (unitIdFS wired_pkg) <> text " not found." return Nothing - pick :: UnitInfo -> IO (Maybe (UnitId, UnitInfo)) + pick :: UnitInfo -> IO (UnitId, UnitInfo) pick pkg = do debugTraceMsg logger 2 $ text "wired-in package " <> ftext (unitIdFS wired_pkg) <> text " mapped to " <> ppr (unitId pkg) - return (Just (wired_pkg, pkg)) + return (wired_pkg, pkg) mb_wired_in_pkgs <- mapM (findWiredInUnit pkgs) wiredInUnitIds @@ -2050,7 +2048,7 @@ instance Outputable UnitErr where ppr = \case CloseUnitErr p mb_parent - -> (ftext (fsLit "unknown unit:") <+> ppr p) + -> (text "unknown unit:" <+> ppr p) <> case mb_parent of Nothing -> Outputable.empty Just parent -> space <> parens (text "dependency of" diff --git a/GHC/Unit/Types.hs b/GHC/Unit/Types.hs --- a/GHC/Unit/Types.hs +++ b/GHC/Unit/Types.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -- instance Binary IsBootInterface + {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveTraversable #-} @@ -48,6 +50,7 @@ , stableUnitCmp , unitIsDefinite , isHoleUnit + , pprUnit -- * Unit Ids , unitIdString @@ -87,9 +90,9 @@ where import GHC.Prelude + import GHC.Types.Unique import GHC.Types.Unique.DSet -import GHC.Unit.Module.Name import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Data.FastString @@ -105,6 +108,9 @@ 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(..)) + --------------------------------------------------------------------- -- MODULES --------------------------------------------------------------------- @@ -158,19 +164,24 @@ ppr = pprInstantiatedModule instance Outputable InstantiatedUnit where - ppr uid = + ppr = pprInstantiatedUnit + +pprInstantiatedUnit :: IsLine doc => InstantiatedUnit -> doc +pprInstantiatedUnit uid = -- getPprStyle $ \sty -> - ppr cid <> + pprUnitId cid <> (if not (null insts) -- pprIf then brackets (hcat (punctuate comma $ - [ ppr modname <> text "=" <> pprModule m + [ pprModuleName modname <> text "=" <> pprModule m | (modname, m) <- insts])) else empty) 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) -- @@ -191,8 +202,8 @@ unitFS (RealUnit (Definite x)) = unitFS x unitFS HoleUnit = holeFS -pprModule :: Module -> SDoc -pprModule mod@(Module p n) = getPprStyle doc +pprModule :: IsLine doc => Module -> doc +pprModule mod@(Module p n) = docWithContext (doc . sdocStyle) where doc sty | codeStyle sty = @@ -203,10 +214,11 @@ | qualModule sty mod = case p of HoleUnit -> angleBrackets (pprModuleName n) - _ -> ppr (moduleUnit mod) <> char ':' <> pprModuleName n + _ -> pprUnit p <> char ':' <> pprModuleName n | otherwise = pprModuleName n - +{-# SPECIALIZE pprModule :: Module -> SDoc #-} +{-# SPECIALIZE pprModule :: Module -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable pprInstantiatedModule :: InstantiatedModule -> SDoc pprInstantiatedModule (Module uid m) = @@ -340,10 +352,12 @@ instance Outputable Unit where ppr pk = pprUnit pk -pprUnit :: Unit -> SDoc -pprUnit (RealUnit uid) = ppr uid -pprUnit (VirtUnit uid) = ppr uid +pprUnit :: IsLine doc => Unit -> doc +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 @@ -519,9 +533,15 @@ getUnique = getUnique . unitIdFS instance Outputable UnitId where - ppr (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- see Note [Pretty-printing UnitId] - -- in "GHC.Unit" + 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 + -- | A 'DefUnitId' is an 'UnitId' with the invariant that -- it only refers to a definite library; i.e., one we have generated -- code for. @@ -632,13 +652,6 @@ -- themselves, however, one should use not 'IsBoot' or conflate signatures and -- modules in opposition to boot interfaces. Instead, one should use -- 'DriverPhases.HscSource'. See Note [HscSource types]. - --- | 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 Binary IsBootInterface where put_ bh ib = put_ bh $ diff --git a/GHC/Unit/Types.hs-boot b/GHC/Unit/Types.hs-boot --- a/GHC/Unit/Types.hs-boot +++ b/GHC/Unit/Types.hs-boot @@ -1,9 +1,8 @@ {-# LANGUAGE KindSignatures #-} module GHC.Unit.Types where -import GHC.Prelude () -import {-# SOURCE #-} GHC.Utils.Outputable -import {-# SOURCE #-} GHC.Unit.Module.Name ( ModuleName ) +-- No Prelude. See Note [Exporting pprTrace from GHC.Prelude] +import Language.Haskell.Syntax.Module.Name (ModuleName) import Data.Kind (Type) data UnitId @@ -15,4 +14,3 @@ moduleName :: GenModule a -> ModuleName moduleUnit :: GenModule a -> a -pprModule :: Module -> SDoc diff --git a/GHC/Utils/Asm.hs b/GHC/Utils/Asm.hs --- a/GHC/Utils/Asm.hs +++ b/GHC/Utils/Asm.hs @@ -12,9 +12,10 @@ import GHC.Utils.Outputable -- | Generate a section type (e.g. @\@progbits@). See #13937. -sectionType :: Platform -- ^ Target platform +sectionType :: IsLine doc + => Platform -- ^ Target platform -> String -- ^ section type - -> SDoc -- ^ pretty assembler fragment + -> doc -- ^ pretty assembler fragment sectionType platform ty = case platformArch platform of ArchARM{} -> char '%' <> text ty diff --git a/GHC/Utils/Binary.hs b/GHC/Utils/Binary.hs --- a/GHC/Utils/Binary.hs +++ b/GHC/Utils/Binary.hs @@ -34,6 +34,7 @@ SymbolTable, Dictionary, BinData(..), dataHandle, handleData, + unsafeUnpackBinBuffer, openBinMem, -- closeBin, @@ -47,8 +48,10 @@ writeBinMem, readBinMem, + readBinMemN, putAt, getAt, + forwardPut, forwardPut_, forwardGet, -- * For writing instances putByte, @@ -71,12 +74,20 @@ -- * User data UserData(..), getUserData, setUserData, - newReadState, newWriteState, + 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 @@ -84,10 +95,11 @@ 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) +import Foreign hiding (shiftL, shiftR, void) import Data.Array import Data.Array.IO import Data.Array.Unsafe @@ -102,7 +114,7 @@ import qualified Data.Set as Set import Data.Time import Data.List (unfoldr) -import Control.Monad ( when, (<$!>), unless, forM_ ) +import Control.Monad ( when, (<$!>), unless, forM_, void ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) @@ -181,6 +193,12 @@ 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 @@ -217,7 +235,7 @@ openBinMem :: Int -> IO BinHandle openBinMem size - | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" + | size <= 0 = error "GHC.Utils.Binary.openBinMem: size must be >= 0" | otherwise = do arr <- mallocForeignPtrBytes size arr_r <- newIORef arr @@ -235,6 +253,14 @@ 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 @@ -244,16 +270,27 @@ hClose h readBinMem :: FilePath -> IO BinHandle --- Return a BinHandle with a totally undefined State readBinMem filename = do - h <- openBinaryFile filename ReadMode - filesize' <- hFileSize h - let filesize = fromIntegral filesize' + 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") - hClose h arr_r <- newIORef arr ix_r <- newFastMutInt 0 sz_r <- newFastMutInt filesize @@ -552,7 +589,9 @@ -- | 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 } +newtype FixedLengthEncoding a + = FixedLengthEncoding { unFixedLength :: a } + deriving (Eq,Ord,Show) instance Binary (FixedLengthEncoding Word8) where put_ h (FixedLengthEncoding x) = putByte h x @@ -777,7 +816,7 @@ * Start with a tag byte * 0 => Int64 (LEB128 encoded) - * 1 => Negative large interger + * 1 => Negative large integer * 2 => Positive large integer * Followed by the value: * Int64 is encoded as usual @@ -915,6 +954,45 @@ -- ----------------------------------------------------------------------------- +-- 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 () @@ -1021,8 +1099,14 @@ ud_put_fs = put_fs } -noUserData :: a -noUserData = undef "UserData" +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) @@ -1050,6 +1134,58 @@ 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 --------------------------------------------------------- @@ -1075,13 +1211,13 @@ putBS bh bs = BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do put_ bh l - putPrim bh l (\op -> copyBytes op (castPtr ptr) l) + putPrim bh l (\op -> BS.memcpy 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) + getPrim bh l (\src -> BS.memcpy dest src l) instance Binary ByteString where put_ bh f = putBS bh f @@ -1103,6 +1239,10 @@ 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 @@ -1279,18 +1419,23 @@ -- fs <- get bh -- return (StringLiteral st fs Nothing) -instance Binary a => Binary (Located a) where - put_ bh (L l x) = do - put_ bh l +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 <- get bh + l <- unBinSrcSpan <$> get bh x <- get bh - return (L l x) + return $ BinLocated (L l x) -instance Binary RealSrcSpan where - put_ bh ss = do +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) @@ -1303,8 +1448,8 @@ sc <- get bh el <- get bh ec <- get bh - return (mkRealSrcSpan (mkRealSrcLoc f sl sc) - (mkRealSrcLoc f el ec)) + return $ BinSpan (mkRealSrcSpan (mkRealSrcLoc f sl sc) + (mkRealSrcLoc f el ec)) instance Binary UnhelpfulSpanReason where put_ bh r = case r of @@ -1323,24 +1468,44 @@ 3 -> return UnhelpfulGenerated _ -> UnhelpfulOther <$> get bh -instance Binary SrcSpan where - put_ bh (RealSrcSpan ss _sb) = do +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 ss + put_ bh $ BinSpan ss - put_ bh (UnhelpfulSpan s) = do + put_ bh (BinSrcSpan (UnhelpfulSpan s)) = do putByte bh 1 put_ bh s get bh = do h <- getByte bh case h of - 0 -> do ss <- get bh - return (RealSrcSpan ss Strict.Nothing) + 0 -> do BinSpan ss <- get bh + return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing) _ -> do s <- get bh - return (UnhelpfulSpan s) + 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 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,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} ----------------------------------------------------------------------------- -- @@ -24,7 +25,7 @@ bFlush, ) where -import GHC.Prelude +import GHC.Prelude.Basic import GHC.Data.FastString import GHC.Data.FastMutInt @@ -37,6 +38,10 @@ import Foreign.C.String import System.IO +-- for RULES +import GHC.Exts (unpackCString#, unpackNBytes#, Int(..)) +import GHC.Ptr (Ptr(..)) + -- ----------------------------------------------------------------------------- data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8) @@ -61,6 +66,22 @@ bPutChar b c else do pokeElemOff buf i (fromIntegral (ord c) :: Word8) writeFastMutInt r (i+1) + +-- Equivalent of the text/str, text/unpackNBytes#, text/[] rules +-- in GHC.Utils.Ppr. +{-# RULES "hdoc/str" + forall a h. bPutStr h (unpackCString# a) = bPutPtrString h (mkPtrString# a) + #-} +{-# RULES "hdoc/unpackNBytes#" + forall p n h. bPutStr h (unpackNBytes# p n) = bPutPtrString h (PtrString (Ptr p) (I# n)) + #-} +{-# RULES "hdoc/[]#" + forall h. bPutStr h [] = return () + #-} + +{-# NOINLINE [0] bPutStr #-} -- Give the RULE a chance to fire + -- It must wait till after phase 1 when + -- the unpackCString first is manifested bPutStr :: BufHandle -> String -> IO () bPutStr (BufHandle buf r hdl) !str = do diff --git a/GHC/Utils/Constants.hs b/GHC/Utils/Constants.hs --- a/GHC/Utils/Constants.hs +++ b/GHC/Utils/Constants.hs @@ -8,7 +8,7 @@ ) where -import GHC.Prelude +import GHC.Prelude.Basic {- diff --git a/GHC/Utils/Error.hs b/GHC/Utils/Error.hs --- a/GHC/Utils/Error.hs +++ b/GHC/Utils/Error.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} {- (c) The AQUA Project, Glasgow University, 1994-1998 @@ -25,14 +26,14 @@ errorsFound, isEmptyMessages, -- ** Formatting - pprMessageBag, pprMsgEnvelopeBagWithLoc, + pprMessageBag, pprMsgEnvelopeBagWithLoc, pprMsgEnvelopeBagWithLocDefault, pprMessages, - pprLocMsgEnvelope, + pprLocMsgEnvelope, pprLocMsgEnvelopeDefault, formatBulleted, -- ** Construction DiagOpts (..), diag_wopt, diag_fatal_wopt, - emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, + emptyMessages, mkDecorated, mkLocMessage, mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope, mkErrorMsgEnvelope, mkMCDiagnostic, errorDiagnostic, diagReasonSeverity, @@ -58,6 +59,7 @@ ghcExit, prettyPrintGhcErrors, traceCmd, + traceSystoolCommand, sortMsgBag ) where @@ -123,13 +125,13 @@ -- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the -- 'DiagOpts. -mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> MessageClass -mkMCDiagnostic opts reason = MCDiagnostic (diagReasonSeverity opts reason) reason +mkMCDiagnostic :: DiagOpts -> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass +mkMCDiagnostic opts reason code = MCDiagnostic (diagReasonSeverity opts reason) reason code -- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the --- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag'. +-- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag' and there is no diagnostic code. errorDiagnostic :: MessageClass -errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag +errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag Nothing -- -- Creating MsgEnvelope(s) @@ -139,12 +141,12 @@ :: Diagnostic e => Severity -> SrcSpan - -> PrintUnqualified + -> NamePprCtx -> e -> MsgEnvelope e -mk_msg_envelope severity locn print_unqual err +mk_msg_envelope severity locn name_ppr_ctx err = MsgEnvelope { errMsgSpan = locn - , errMsgContext = print_unqual + , errMsgContext = name_ppr_ctx , errMsgDiagnostic = err , errMsgSeverity = severity } @@ -156,22 +158,22 @@ :: Diagnostic e => DiagOpts -> SrcSpan - -> PrintUnqualified + -> NamePprCtx -> e -> MsgEnvelope e -mkMsgEnvelope opts locn print_unqual err - = mk_msg_envelope (diagReasonSeverity opts (diagnosticReason err)) locn print_unqual err +mkMsgEnvelope opts locn name_ppr_ctx err + = mk_msg_envelope (diagReasonSeverity opts (diagnosticReason err)) locn name_ppr_ctx err -- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location. -- Precondition: the diagnostic is, in fact, an error. That is, -- @diagnosticReason msg == ErrorWithoutFlag@. mkErrorMsgEnvelope :: Diagnostic e => SrcSpan - -> PrintUnqualified + -> NamePprCtx -> e -> MsgEnvelope e -mkErrorMsgEnvelope locn unqual msg = - assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn unqual msg +mkErrorMsgEnvelope locn name_ppr_ctx msg = + assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn name_ppr_ctx msg -- | Variant that doesn't care about qualified/unqualified names. mkPlainMsgEnvelope :: Diagnostic e @@ -227,20 +229,31 @@ msgs = filter (not . Outputable.isEmpty ctx) docs starred = (bullet<+>) -pprMessages :: Diagnostic e => Messages e -> SDoc -pprMessages = vcat . pprMsgEnvelopeBagWithLoc . getMessages +pprMessages :: Diagnostic e => DiagnosticOpts e -> Messages e -> SDoc +pprMessages e = vcat . pprMsgEnvelopeBagWithLoc e . getMessages -pprMsgEnvelopeBagWithLoc :: Diagnostic e => Bag (MsgEnvelope e) -> [SDoc] -pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ] +pprMsgEnvelopeBagWithLoc :: Diagnostic e => DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc] +pprMsgEnvelopeBagWithLoc e bag = [ pprLocMsgEnvelope e item | item <- sortMsgBag Nothing bag ] -pprLocMsgEnvelope :: Diagnostic e => MsgEnvelope e -> SDoc -pprLocMsgEnvelope (MsgEnvelope { errMsgSpan = s +-- | Print the messages with the suitable default configuration, usually not what you want but sometimes you don't really +-- care about what the configuration is (for example, if the message is in a panic). +pprMsgEnvelopeBagWithLocDefault :: forall e . Diagnostic e => Bag (MsgEnvelope e) -> [SDoc] +pprMsgEnvelopeBagWithLocDefault bag = [ pprLocMsgEnvelopeDefault item | item <- sortMsgBag Nothing bag ] + +pprLocMsgEnvelopeDefault :: forall e . Diagnostic e => MsgEnvelope e -> SDoc +pprLocMsgEnvelopeDefault = pprLocMsgEnvelope (defaultDiagnosticOpts @e) + +pprLocMsgEnvelope :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc +pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s , errMsgDiagnostic = e , errMsgSeverity = sev - , errMsgContext = unqual }) + , errMsgContext = name_ppr_ctx }) = sdocWithContext $ \ctx -> - withErrStyle unqual $ - mkLocMessage (MCDiagnostic sev (diagnosticReason e)) s (formatBulleted ctx $ diagnosticMessage e) + withErrStyle name_ppr_ctx $ + mkLocMessage + (MCDiagnostic sev (diagnosticReason e) (diagnosticCode e)) + s + (formatBulleted ctx $ diagnosticMessage opts e) sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e] sortMsgBag mopts = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList @@ -417,13 +430,13 @@ putMsg :: Logger -> SDoc -> IO () putMsg logger msg = logInfo logger (withPprStyle defaultUserStyle msg) -printInfoForUser :: Logger -> PrintUnqualified -> SDoc -> IO () -printInfoForUser logger print_unqual msg - = logInfo logger (withUserStyle print_unqual AllTheWay msg) +printInfoForUser :: Logger -> NamePprCtx -> SDoc -> IO () +printInfoForUser logger name_ppr_ctx msg + = logInfo logger (withUserStyle name_ppr_ctx AllTheWay msg) -printOutputForUser :: Logger -> PrintUnqualified -> SDoc -> IO () -printOutputForUser logger print_unqual msg - = logOutput logger (withUserStyle print_unqual AllTheWay msg) +printOutputForUser :: Logger -> NamePprCtx -> SDoc -> IO () +printOutputForUser logger name_ppr_ctx msg + = logOutput logger (withUserStyle name_ppr_ctx AllTheWay msg) logInfo :: Logger -> SDoc -> IO () logInfo logger msg = logMsg logger MCInfo noSrcSpan msg @@ -459,6 +472,20 @@ loggerTraceFlush logger -- And run it! action `catchIO` handle_exn + + +-- * Tracing utility + +-- | Record in the eventlog when the given tool command starts +-- and finishes, prepending the given 'String' with +-- \"systool:\", to easily be able to collect and process +-- all the systool events. +-- +-- For those events to show up in the eventlog, you need +-- to run GHC with @-v2@ or @-ddump-timings@. +traceSystoolCommand :: Logger -> String -> IO a -> IO a +traceSystoolCommand logger tool = withTiming logger (text "systool:" <> text tool) (const ()) + {- Note [withTiming] ~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Utils/Exception.hs b/GHC/Utils/Exception.hs --- a/GHC/Utils/Exception.hs +++ b/GHC/Utils/Exception.hs @@ -8,7 +8,7 @@ ) where -import GHC.Prelude +import GHC.Prelude.Basic import GHC.IO (catchException) import Control.Exception as CE hiding (assert) diff --git a/GHC/Utils/Fingerprint.hs b/GHC/Utils/Fingerprint.hs --- a/GHC/Utils/Fingerprint.hs +++ b/GHC/Utils/Fingerprint.hs @@ -22,7 +22,7 @@ getFileHash ) where -import GHC.Prelude +import GHC.Prelude.Basic import Foreign import GHC.IO diff --git a/GHC/Utils/GlobalVars.hs b/GHC/Utils/GlobalVars.hs --- a/GHC/Utils/GlobalVars.hs +++ b/GHC/Utils/GlobalVars.hs @@ -22,7 +22,7 @@ ) where -import GHC.Prelude +import GHC.Prelude.Basic import GHC.Conc.Sync ( sharedCAF ) diff --git a/GHC/Utils/IO/Unsafe.hs b/GHC/Utils/IO/Unsafe.hs --- a/GHC/Utils/IO/Unsafe.hs +++ b/GHC/Utils/IO/Unsafe.hs @@ -9,7 +9,7 @@ ) where -import GHC.Prelude () +import GHC.Prelude.Basic () import GHC.Exts import GHC.IO (IO(..)) diff --git a/GHC/Utils/Json.hs b/GHC/Utils/Json.hs --- a/GHC/Utils/Json.hs +++ b/GHC/Utils/Json.hs @@ -14,6 +14,7 @@ JSBool :: Bool -> JsonDoc JSInt :: Int -> JsonDoc JSString :: String -> JsonDoc + -- ^ The 'String' is unescaped JSArray :: [JsonDoc] -> JsonDoc JSObject :: [(String, JsonDoc)] -> JsonDoc @@ -23,7 +24,7 @@ renderJSON d = case d of JSNull -> text "null" - JSBool b -> text $ if b then "true" else "false" + JSBool b -> if b then text "true" else text "false" JSInt n -> ppr n JSString s -> doubleQuotes $ text $ escapeJsonString s JSArray as -> brackets $ pprList renderJSON as @@ -57,7 +58,7 @@ json :: a -> JsonDoc instance ToJson String where - json = JSString . escapeJsonString + json = JSString instance ToJson Int where json = JSInt diff --git a/GHC/Utils/Lexeme.hs b/GHC/Utils/Lexeme.hs --- a/GHC/Utils/Lexeme.hs +++ b/GHC/Utils/Lexeme.hs @@ -67,19 +67,17 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs ------------- -isLexConId cs -- Prefix type or data constructors - | nullFS cs = False -- e.g. "Foo", "[]", "(,)" - | cs == (fsLit "[]") = True - | otherwise = startsConId (headFS cs) +isLexConId cs = case unpackFS cs of -- Prefix type or data constructors + [] -> False -- e.g. "Foo", "[]", "(,)" + c:_ -> cs == fsLit "[]" || startsConId c -isLexVarId cs -- Ordinary prefix identifiers - | nullFS cs = False -- e.g. "x", "_x" - | otherwise = startsVarId (headFS cs) +isLexVarId cs = case unpackFS cs of -- Ordinary prefix identifiers + [] -> False -- e.g. "x", "_x" + c:_ -> startsVarId c -isLexConSym cs -- Infix type or data constructors - | nullFS cs = False -- e.g. ":-:", ":", "->" - | cs == (fsLit "->") = True - | otherwise = startsConSym (headFS cs) +isLexConSym cs = case unpackFS cs of -- Infix type or data constructors + [] -> False -- e.g. ":-:", ":", "->" + c:_ -> cs == fsLit "->" || startsConSym c isLexVarSym fs -- Infix identifiers e.g. "+" | fs == (fsLit "~R#") = True diff --git a/GHC/Utils/Logger.hs b/GHC/Utils/Logger.hs --- a/GHC/Utils/Logger.hs +++ b/GHC/Utils/Logger.hs @@ -9,7 +9,7 @@ -- hooks. The compiler itself uses hooks in multithreaded code (--make) and it -- is also probably used by ghc-api users (IDEs, etc.). -- --- In addition to hooks, the Logger suppors LogFlags: basically a subset of the +-- In addition to hooks, the Logger supports LogFlags: basically a subset of the -- command-line flags that control the logger behaviour at a higher level than -- hooks. -- @@ -88,19 +88,18 @@ import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet -import Data.IORef import System.Directory import System.FilePath ( takeDirectory, () ) -import qualified Data.Set as Set -import Data.Set (Set) -import Data.List (intercalate, stripPrefix) -import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Map.Strict (Map) +import Data.List (stripPrefix) import Data.Time import System.IO import Control.Monad import Control.Concurrent.MVar import System.IO.Unsafe import Debug.Trace (trace) +import GHC.Platform.Ways --------------------------------------------------------------- -- Log flags @@ -118,8 +117,10 @@ , log_dump_dir :: !(Maybe FilePath) -- ^ Dump directory , log_dump_prefix :: !FilePath -- ^ Normal dump path ("basename.") , log_dump_prefix_override :: !(Maybe FilePath) -- ^ Overriden dump path + , log_with_ways :: !Bool -- ^ Use different dump files names for different ways , log_enable_debug :: !Bool -- ^ Enable debug output , log_verbosity :: !Int -- ^ Verbosity level + , log_ways :: !(Maybe Ways) -- ^ Current ways (to name dump files) } -- | Default LogFlags @@ -135,13 +136,15 @@ , log_dump_dir = Nothing , log_dump_prefix = "" , log_dump_prefix_override = Nothing + , log_with_ways = True , log_enable_debug = False , log_verbosity = 0 + , log_ways = Nothing } -- | Test if a DumpFlag is enabled log_dopt :: DumpFlag -> LogFlags -> Bool -log_dopt f logflags = f `EnumSet.member` log_dump_flags logflags +log_dopt = getDumpFlagFrom log_verbosity log_dump_flags -- | Enable a DumpFlag log_set_dopt :: DumpFlag -> LogFlags -> LogFlags @@ -198,10 +201,14 @@ | FormatASM -- ^ Assembly code | FormatC -- ^ C code/header | FormatLLVM -- ^ LLVM bytecode + | FormatJS -- ^ JavaScript code | FormatText -- ^ Unstructured dump deriving (Show,Eq) -type DumpCache = IORef (Set FilePath) +-- | A set of the dump files to which we have written thusfar. Each dump file +-- has a corresponding MVar to ensure that a dump file has at most one active +-- writer at a time, avoiding interleaved output. +type DumpCache = MVar (Map FilePath (MVar ())) data Logger = Logger { log_hook :: [LogAction -> LogAction] @@ -239,7 +246,7 @@ initLogger :: IO Logger initLogger = do - dumps <- newIORef Set.empty + dumps <- newMVar Map.empty return $ Logger { log_hook = [] , dump_hook = [] @@ -323,11 +330,11 @@ -- See Note [JSON Error Messages] -- jsonLogAction :: LogAction -jsonLogAction _ (MCDiagnostic SevIgnore _) _ _ = return () -- suppress the message +jsonLogAction _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message jsonLogAction logflags msg_class srcSpan msg = defaultLogActionHPutStrDoc logflags True stdout - (withPprStyle (PprCode CStyle) (doc $$ text "")) + (withPprStyle PprCode (doc $$ text "")) where str = renderWithContext (log_default_user_context logflags) msg doc = renderJSON $ @@ -340,21 +347,21 @@ defaultLogAction logflags msg_class srcSpan msg | log_dopt Opt_D_dump_json logflags = jsonLogAction logflags msg_class srcSpan msg | otherwise = 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 -> printDiagnostics sev rea + 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 -> printDiagnostics where printOut = defaultLogActionHPrintDoc logflags False stdout printErrs = defaultLogActionHPrintDoc logflags False stderr putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout -- Pretty print the warning flag, if any (#10752) - message sev rea = mkLocMessageAnn (flagMsg sev rea) msg_class srcSpan msg + message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg - printDiagnostics severity reason = do + printDiagnostics = do hPutChar stderr '\n' caretDiagnostic <- if log_show_caret logflags @@ -362,35 +369,12 @@ else pure empty printErrs $ getPprStyle $ \style -> withPprStyle (setStyleColoured True style) - (message severity reason $+$ caretDiagnostic) + (message $+$ caretDiagnostic) -- careful (#2302): printErrs prints in UTF-8, -- whereas converting to string first and using -- hPutStr would just emit the low 8 bits of -- each unicode char. - flagMsg :: Severity -> DiagnosticReason -> Maybe String - flagMsg SevIgnore _ = panic "Called flagMsg with SevIgnore" - flagMsg SevError WarningWithoutFlag = Just "-Werror" - flagMsg SevError (WarningWithFlag wflag) = do - let name = NE.head (warnFlagNames wflag) - return $ - "-W" ++ name ++ warnFlagGrp wflag ++ - ", -Werror=" ++ name - flagMsg SevError ErrorWithoutFlag = Nothing - flagMsg SevWarning WarningWithoutFlag = Nothing - flagMsg SevWarning (WarningWithFlag wflag) = do - let name = NE.head (warnFlagNames wflag) - return ("-W" ++ name ++ warnFlagGrp wflag) - flagMsg SevWarning ErrorWithoutFlag = - panic "SevWarning with ErrorWithoutFlag" - - warnFlagGrp flag - | log_show_warn_groups logflags = - case smallestWarningGroups flag of - [] -> "" - groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" - | otherwise = "" - -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO () defaultLogActionHPrintDoc logflags asciiSpace h d @@ -428,7 +412,7 @@ -- | Write out a dump. -- -- If --dump-to-file is set then this goes to a file. --- otherwise emit to stdout (via the the LogAction parameter). +-- otherwise emit to stdout (via the LogAction parameter). -- -- When @hdr@ is empty, we print in a more compact format (no separators and -- blank lines) @@ -462,16 +446,24 @@ -- file, otherwise 'Nothing'. withDumpFileHandle :: DumpCache -> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO () withDumpFileHandle dumps logflags flag action = do - let mFile = chooseDumpFile logflags flag + let dump_ways = log_ways logflags + let mFile = chooseDumpFile logflags dump_ways flag case mFile of Just fileName -> do - gd <- readIORef dumps - let append = Set.member fileName gd - mode = if append then AppendMode else WriteMode - unless append $ - writeIORef dumps (Set.insert fileName gd) - createDirectoryIfMissing True (takeDirectory fileName) - withFile fileName mode $ \handle -> do + lock <- modifyMVar dumps $ \gd -> + case Map.lookup fileName gd of + Nothing -> do + lock <- newMVar () + let gd' = Map.insert fileName lock gd + -- ensure that file exists so we can append to it + createDirectoryIfMissing True (takeDirectory fileName) + writeFile fileName "" + return (gd', lock) + Just lock -> do + return (gd, lock) + + let withLock k = withMVar lock $ \() -> k >> return () + withLock $ withFile fileName AppendMode $ \handle -> do -- We do not want the dump file to be affected by -- environment variables, but instead to always use -- UTF8. See: @@ -482,14 +474,20 @@ Nothing -> action Nothing -- | Choose where to put a dump file based on LogFlags and DumpFlag -chooseDumpFile :: LogFlags -> DumpFlag -> Maybe FilePath -chooseDumpFile logflags flag +chooseDumpFile :: LogFlags -> Maybe Ways -> DumpFlag -> Maybe FilePath +chooseDumpFile logflags ways flag | log_dump_to_file logflags || forced_to_file - = Just $ setDir (getPrefix ++ dump_suffix) + = Just $ setDir (getPrefix ++ way_infix ++ dump_suffix) | otherwise = Nothing where + way_infix = case ways of + _ | not (log_with_ways logflags) -> "" + Nothing -> "" + Just ws + | null ws || null (waysTag ws) -> "" + | otherwise -> waysTag ws ++ "." (forced_to_file, dump_suffix) = case flag of -- -dth-dec-file dumps expansions of TH -- splices into MODULE.th.hs even when @@ -565,29 +563,29 @@ -- | Dump if the given DumpFlag is set -- --- Unlike 'putDumpFileMaybe', has a PrintUnqualified argument +-- Unlike 'putDumpFileMaybe', has a NamePprCtx argument putDumpFileMaybe' :: Logger - -> PrintUnqualified + -> NamePprCtx -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () -putDumpFileMaybe' logger printer flag hdr fmt doc +putDumpFileMaybe' logger name_ppr_ctx flag hdr fmt doc = when (logHasDumpFlag logger flag) $ - logDumpFile' logger printer flag hdr fmt doc + logDumpFile' logger name_ppr_ctx flag hdr fmt doc {-# INLINE putDumpFileMaybe' #-} -- see Note [INLINE conditional tracing utilities] -logDumpFile' :: Logger -> PrintUnqualified -> DumpFlag +logDumpFile' :: Logger -> NamePprCtx -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () {-# NOINLINE logDumpFile' #-} -- NOINLINE: Now we are past the conditional, into the "cold" path, -- don't inline, to reduce code size at the call site -- See Note [INLINE conditional tracing utilities] -logDumpFile' logger printer flag hdr fmt doc - = logDumpFile logger (mkDumpStyle printer) flag hdr fmt doc +logDumpFile' logger name_ppr_ctx flag hdr fmt doc + = logDumpFile logger (mkDumpStyle name_ppr_ctx) flag hdr fmt doc -- | Ensure that a dump file is created even if it stays empty touchDumpFile :: Logger -> DumpFlag -> IO () diff --git a/GHC/Utils/Misc.hs b/GHC/Utils/Misc.hs --- a/GHC/Utils/Misc.hs +++ b/GHC/Utils/Misc.hs @@ -4,12 +4,9 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -- | Highly random utility functions -- module GHC.Utils.Misc ( @@ -18,9 +15,7 @@ -- * General list processing zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, - zipLazy, stretchZipWith, zipWithAndUnzip, zipAndUnzip, - - zipWithLazy, zipWith3Lazy, + stretchZipWith, zipWithAndUnzip, zipAndUnzip, filterByList, filterByLists, partitionByList, @@ -29,7 +24,6 @@ mapFst, mapSnd, chkAppend, mapAndUnzip, mapAndUnzip3, filterOut, partitionWith, - mapAccumM, dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, @@ -45,6 +39,8 @@ chunkList, + holes, + changeLast, mapLastM, @@ -59,10 +55,8 @@ -- * Tuples fstOf3, sndOf3, thdOf3, - firstM, first3M, secondM, fst3, snd3, third3, uncurry3, - liftFst, liftSnd, -- * List operations controlled by another list takeList, dropList, splitAtList, split, @@ -72,8 +66,7 @@ sortWith, minWith, nubSort, ordNub, ordNubOn, -- * Comparisons - isEqual, eqListBy, eqMaybeBy, - thenCmp, cmpList, + isEqual, removeSpaces, (<&&>), (<||>), @@ -127,7 +120,7 @@ HasDebugCallStack, ) where -import GHC.Prelude +import GHC.Prelude.Basic hiding ( head, init, last, tail ) import GHC.Utils.Exception import GHC.Utils.Panic.Plain @@ -136,18 +129,20 @@ import Data.Data import qualified Data.List as List -import Data.List.NonEmpty ( NonEmpty(..) ) +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.Stack (HasCallStack) -import Control.Applicative ( liftA2 ) -import Control.Monad ( liftM, guard ) +import Control.Monad ( guard ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) import System.FilePath +import Data.Bifunctor ( first, second ) import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper , isHexDigit, digitToInt ) import Data.Int @@ -159,9 +154,6 @@ import Data.Time -infixr 9 `thenCmp` - - {- ************************************************************************ * * @@ -203,21 +195,6 @@ uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d uncurry3 f (a, b, c) = f a b c -liftFst :: (a -> b) -> (a, c) -> (b, c) -liftFst f (a,c) = (f a, c) - -liftSnd :: (a -> b) -> (c, a) -> (c, b) -liftSnd f (c,a) = (c, f a) - -firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) -firstM f (x, y) = liftM (\x' -> (x', y)) (f x) - -first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) -first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) - -secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) -secondM f (x, y) = (x,) <$> f y - {- ************************************************************************ * * @@ -251,10 +228,10 @@ DEBUGging on; hey, why not? -} -zipEqual :: String -> [a] -> [b] -> [(a,b)] -zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] -zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +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] #if !defined(DEBUG) zipEqual _ = zip @@ -281,25 +258,6 @@ zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists: "++msg) #endif --- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) -zipLazy :: [a] -> [b] -> [(a,b)] -zipLazy [] _ = [] -zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys - --- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list. --- The length of the output is always the same as the length of the first --- list. -zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] -zipWithLazy _ [] _ = [] -zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs - --- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists. --- The length of the output is always the same as the length of the first --- list. -zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] -zipWith3Lazy _ [] _ _ = [] -zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs - -- | 'filterByList' takes a list of Bools and a list of some elements and -- filters out these elements for which the corresponding value in the list of -- Bools is False. This function does not check whether the lists have equal @@ -350,11 +308,11 @@ [] -> [] (y:ys) -> f x y : stretchZipWith p z f xs ys -mapFst :: (a->c) -> [(a,b)] -> [(c,b)] -mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] +mapFst :: Functor f => (a->c) -> f(a,b) -> f(c,b) +mapSnd :: Functor f => (b->c) -> f(a,b) -> f(a,c) -mapFst f xys = [(f x, y) | (x,y) <- xys] -mapSnd f xys = [(x, f y) | (x,y) <- xys] +mapFst = fmap . first +mapSnd = fmap . second mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) @@ -529,6 +487,13 @@ chunkList _ [] = [] chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs +-- | Compute all the ways of removing a single element from a list. +-- +-- > holes [1,2,3] = [(1, [2,3]), (2, [1,3]), (3, [1,2])] +holes :: [a] -> [(a, [a])] +holes [] = [] +holes (x:xs) = (x, xs) : mapSnd (x:) (holes xs) + -- | Replace the last element of a list with another element. changeLast :: [a] -> a -> [a] changeLast [] _ = panic "changeLast" @@ -536,20 +501,9 @@ changeLast (x:xs) x' = x : changeLast xs x' -- | Apply an effectful function to the last list element. --- Assumes a non-empty list (panics otherwise). -mapLastM :: Functor f => (a -> f a) -> [a] -> f [a] -mapLastM _ [] = panic "mapLastM: empty list" -mapLastM f [x] = (\x' -> [x']) <$> f x -mapLastM f (x:xs) = (x:) <$> mapLastM f xs - -mapAccumM :: (Monad m) => (r -> a -> m (r, b)) -> r -> [a] -> m (r, [b]) -mapAccumM f = go - where - go acc [] = pure (acc,[]) - go acc (x:xs) = do - (acc',y) <- f acc x - (acc'',ys) <- go acc' xs - pure (acc'', y:ys) +mapLastM :: Functor f => (a -> f a) -> NonEmpty a -> f (NonEmpty a) +mapLastM f (x:|[]) = NE.singleton <$> f x +mapLastM f (x0:|x1:xs) = (x0 NE.<|) <$> mapLastM f (x1:|xs) whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty [] _ = pure () @@ -613,7 +567,7 @@ minWith :: Ord b => (a -> b) -> [a] -> a minWith get_key xs = assert (not (null xs) ) - head (sortWith get_key xs) + Partial.head (sortWith get_key xs) nubSort :: Ord a => [a] -> [a] nubSort = Set.toAscList . Set.fromList @@ -764,16 +718,14 @@ | p x = go yes (x : rev_yes) rev_no xs | otherwise = go xs [] (x : rev_yes ++ rev_no) xs --- | Get the last two elements in a list. Partial! +-- | Get the last two elements in a list. {-# INLINE last2 #-} -last2 :: [a] -> (a,a) -last2 = List.foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError) - where - partialError = panic "last2 - list length less than two" +last2 :: [a] -> Maybe (a,a) +last2 = uncurry (liftA2 (,)) . List.foldl' (\(_,x2) x -> (x2, Just x)) (Nothing, Nothing) lastMaybe :: [a] -> Maybe a lastMaybe [] = Nothing -lastMaybe xs = Just $ last xs +lastMaybe (x:xs) = Just $ last (x:|xs) -- | @onJust x m f@ applies f to the value inside the Just or returns the default. onJust :: b -> Maybe a -> (a->b) -> b @@ -787,17 +739,12 @@ -- If you are guaranteed to use both, this will -- be more efficient. snocView :: [a] -> Maybe ([a],a) -snocView [] = Nothing -snocView xs - | (xs,x) <- go xs - = Just (xs,x) +snocView = fmap go . nonEmpty where - go :: [a] -> ([a],a) - go [x] = ([],x) - go (x:xs) - | !(xs',x') <- go xs - = (x:xs', x') - go [] = error "impossible" + go :: NonEmpty a -> ([a],a) + go (x:|xs) = case nonEmpty xs of + Nothing -> ([],x) + Just xs -> case go xs of !(xs', x') -> (x:xs', x') split :: Char -> String -> [String] split c s = case rest of @@ -825,30 +772,6 @@ isEqual EQ = True isEqual LT = False -thenCmp :: Ordering -> Ordering -> Ordering -{-# INLINE thenCmp #-} -thenCmp EQ ordering = ordering -thenCmp ordering _ = ordering - -eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool -eqListBy _ [] [] = True -eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys -eqListBy _ _ _ = False - -eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool -eqMaybeBy _ Nothing Nothing = True -eqMaybeBy eq (Just x) (Just y) = eq x y -eqMaybeBy _ _ _ = False - -cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering - -- `cmpList' uses a user-specified comparer - -cmpList _ [] [] = EQ -cmpList _ [] _ = LT -cmpList _ _ [] = GT -cmpList cmp (a:as) (b:bs) - = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } - removeSpaces :: String -> String removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace @@ -971,10 +894,10 @@ -- | Search for possible matches to the users input in the given list, -- returning a small number of ranked results fuzzyLookup :: String -> [(String,a)] -> [a] -fuzzyLookup user_entered possibilites +fuzzyLookup user_entered possibilities = map fst $ take mAX_RESULTS $ List.sortBy (comparing snd) [ (poss_val, sort_key) - | (poss_str, poss_val) <- possibilites + | (poss_str, poss_val) <- possibilities , let distance = restrictedDamerauLevenshteinDistance poss_str user_entered , distance <= fuzzy_threshold , let sort_key = (distance, length poss_str, poss_str) @@ -1007,7 +930,7 @@ -} unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] -unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs +unzipWith = fmap . uncurry seqList :: [a] -> b -> b seqList [] b = b @@ -1340,9 +1263,9 @@ -- string is returned in the first component (and the second one is just -- empty). splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) -splitLongestPrefix str pred - | null r_pre = (str, []) - | otherwise = (reverse (tail r_pre), reverse r_suf) +splitLongestPrefix str pred = case r_pre of + [] -> (str, []) + _:r_pre' -> (reverse r_pre', reverse r_suf) -- 'tail' drops the char satisfying 'pred' where (r_suf, r_pre) = break pred (reverse str) diff --git a/GHC/Utils/Monad.hs b/GHC/Utils/Monad.hs --- a/GHC/Utils/Monad.hs +++ b/GHC/Utils/Monad.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MonadComprehensions #-} + -- | Utilities related to Monad and Applicative classes -- Mostly for backwards compatibility. @@ -11,16 +13,14 @@ , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M , mapAccumLM - , liftFstM, liftSndM , mapSndM , concatMapM , mapMaybeM - , fmapMaybeM, fmapEitherM , anyM, allM, orM , foldlM, foldlM_, foldrM - , maybeMapM , whenM, unlessM , filterOutM + , partitionM ) where ------------------------------------------------------------------------------- @@ -29,12 +29,14 @@ import GHC.Prelude -import Control.Applicative import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class +import Control.Monad.Trans.State.Strict (StateT (..)) import Data.Foldable (sequenceA_, foldlM, foldrM) import Data.List (unzip4, unzip5, zipWith4) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Tuple (swap) ------------------------------------------------------------------------------- -- Common functions @@ -142,81 +144,80 @@ -- variant and use it where appropriate. -- | Monadic version of mapAccumL -mapAccumLM :: Monad m +mapAccumLM :: (Monad m, Traversable t) => (acc -> x -> m (acc, y)) -- ^ combining function -> acc -- ^ initial state - -> [x] -- ^ inputs - -> m (acc, [y]) -- ^ final state, outputs -mapAccumLM f s xs = - go s xs + -> t x -- ^ inputs + -> m (acc, t y) -- ^ final state, outputs +{-# INLINE [1] mapAccumLM #-} +-- INLINE pragma. mapAccumLM is called in inner loops. Like 'map', +-- we inline it so that we can take advantage of knowing 'f'. +-- This makes a few percent difference (in compiler allocations) +-- when compiling perf/compiler/T9675 +mapAccumLM f s = fmap swap . flip runStateT s . traverse f' where + f' = StateT . (fmap . fmap) swap . flip f +{-# RULES "mapAccumLM/List" mapAccumLM = mapAccumLM_List #-} +{-# RULES "mapAccumLM/NonEmpty" mapAccumLM = mapAccumLM_NonEmpty #-} + +mapAccumLM_List + :: Monad m + => (acc -> x -> m (acc, y)) + -> acc -> [x] -> m (acc, [y]) +{-# INLINE mapAccumLM_List #-} +mapAccumLM_List f s = go s + where go s (x:xs) = do (s1, x') <- f s x (s2, xs') <- go s1 xs return (s2, x' : xs') go s [] = return (s, []) --- | Monadic version of mapSnd -mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] -mapSndM f xs = go xs - where - go [] = return [] - go ((a,b):xs) = do { c <- f b; rs <- go xs; return ((a,c):rs) } - -liftFstM :: Monad m => (a -> b) -> m (a, r) -> m (b, r) -liftFstM f thing = do { (a,r) <- thing; return (f a, r) } +mapAccumLM_NonEmpty + :: Monad m + => (acc -> x -> m (acc, y)) + -> acc -> NonEmpty x -> m (acc, NonEmpty y) +{-# INLINE mapAccumLM_NonEmpty #-} +mapAccumLM_NonEmpty f s (x:|xs) = + [(s2, x':|xs') | (s1, x') <- f s x, (s2, xs') <- mapAccumLM_List f s1 xs] -liftSndM :: Monad m => (a -> b) -> m (r, a) -> m (r, b) -liftSndM f thing = do { (r,a) <- thing; return (r, f a) } +-- | Monadic version of mapSnd +mapSndM :: (Applicative m, Traversable f) => (b -> m c) -> f (a,b) -> m (f (a,c)) +mapSndM = traverse . traverse -- | Monadic version of concatMap -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM :: (Monad m, Traversable f) => (a -> m [b]) -> f a -> m [b] concatMapM f xs = liftM concat (mapM f xs) +{-# INLINE concatMapM #-} +-- It's better to inline to inline this than to specialise +-- concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] +-- Inlining cuts compiler allocation by around 1% -- | Applicative version of mapMaybe mapMaybeM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] mapMaybeM f = foldr g (pure []) where g a = liftA2 (maybe id (:)) (f a) --- | Monadic version of fmap -fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b) -fmapMaybeM _ Nothing = return Nothing -fmapMaybeM f (Just x) = f x >>= (return . Just) - --- | Monadic version of fmap -fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) -fmapEitherM fl _ (Left a) = fl a >>= (return . Left) -fmapEitherM _ fr (Right b) = fr b >>= (return . Right) - -- | Monadic version of 'any', aborts the computation at the first @True@ value -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool -anyM f xs = go xs - where - go [] = return False - go (x:xs) = do b <- f x - if b then return True - else go xs +anyM :: (Monad m, Foldable f) => (a -> m Bool) -> f a -> m Bool +anyM f = foldr (orM . f) (pure False) -- | Monad version of 'all', aborts the computation at the first @False@ value -allM :: Monad m => (a -> m Bool) -> [a] -> m Bool -allM f bs = go bs - where - go [] = return True - go (b:bs) = (f b) >>= (\bv -> if bv then go bs else return False) +allM :: (Monad m, Foldable f) => (a -> m Bool) -> f a -> m Bool +allM f = foldr (andM . f) (pure True) -- | Monadic version of or orM :: Monad m => m Bool -> m Bool -> m Bool orM m1 m2 = m1 >>= \x -> if x then return True else m2 +-- | Monadic version of and +andM :: Monad m => m Bool -> m Bool -> m Bool +andM m1 m2 = m1 >>= \x -> if x then m2 else return False + -- | 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 fmap specialised for Maybe -maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) -maybeMapM _ Nothing = return Nothing -maybeMapM m (Just x) = liftM Just $ m x - -- | Monadic version of @when@, taking the condition in the monad whenM :: Monad m => m Bool -> m () -> m () whenM mb thing = do { b <- mb @@ -232,6 +233,14 @@ filterOutM p = foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure []) +-- | Monadic version of @partition@ +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM _ [] = pure ([], []) +partitionM f (x:xs) = do + res <- f x + (as,bs) <- partitionM f xs + pure ([x | res]++as, [x | not res]++bs) + {- Note [The one-shot state monad trick] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Summary: many places in GHC use a state monad, and we really want those @@ -342,7 +351,7 @@ patterns.) That's the advantage of the pattern-synonym approach, but it is more elaborate. -The pattern synonym approach is due to Sebastian Graaf (#18238) +The pattern synonym approach is due to Sebastian Graf (#18238) Do note that for monads for multiple arguments more than one oneShot function might be required. For example in FCode we use: @@ -355,8 +364,8 @@ where FCode m = FCode' $ oneShot (\cgInfoDown -> oneShot (\state ->m cgInfoDown state)) -INLINE pragmas and (>>) -~~~~~~~~~~~~~~~~~~~~~~~ +Note [INLINE pragmas and (>>)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A nasty gotcha is described in #20008. In brief, be careful if you get (>>) via its default method: @@ -422,7 +431,7 @@ The magic `inline` function does two things * It prevents eta reduction. If we wrote just multiShotIO (IO m) = IO (\s -> m s) - the lamda would eta-reduce to 'm' and all would be lost. + the lambda would eta-reduce to 'm' and all would be lost. * It helps ensure that 'm' really does inline. diff --git a/GHC/Utils/Monad/State/Lazy.hs b/GHC/Utils/Monad/State/Lazy.hs deleted file mode 100644 --- a/GHC/Utils/Monad/State/Lazy.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE PatternSynonyms #-} - --- | A lazy state monad. -module GHC.Utils.Monad.State.Lazy - ( -- * The State monda - State(State) - , state - , evalState - , execState - , runState - -- * Operations - , get - , gets - , put - , modify - ) where - -import GHC.Prelude - -import GHC.Exts (oneShot) - --- | A state monad which is lazy in the state. -newtype State s a = State' { runState' :: s -> (# a, s #) } - deriving (Functor) - -pattern State :: (s -> (# a, s #)) - -> State s a - --- This pattern synonym makes the monad eta-expand, --- which as a very beneficial effect on compiler performance --- See #18202. --- See Note [The one-shot state monad trick] in GHC.Utils.Monad -pattern State m <- State' m - where - State m = State' (oneShot $ \s -> m s) - -instance Applicative (State s) where - pure x = State $ \s -> (# x, s #) - m <*> n = State $ \s -> case runState' m s of - (# f, s' #) -> case runState' n s' of - (# x, s'' #) -> (# f x, s'' #) - -instance Monad (State s) where - m >>= n = State $ \s -> case runState' m s of - (# r, s' #) -> runState' (n r) s' - -state :: (s -> (a, s)) -> State s a -state f = State $ \s -> case f s of - (r, s') -> (# r, s' #) - -get :: State s s -get = State $ \s -> (# s, s #) - -gets :: (s -> a) -> State s a -gets f = State $ \s -> (# f s, s #) - -put :: s -> State s () -put s' = State $ \_ -> (# (), s' #) - -modify :: (s -> s) -> State s () -modify f = State $ \s -> (# (), f s #) - - -evalState :: State s a -> s -> a -evalState s i = case runState' s i of - (# a, _ #) -> a - - -execState :: State s a -> s -> s -execState s i = case runState' s i of - (# _, s' #) -> s' - - -runState :: State s a -> s -> (a, s) -runState s i = case runState' s i of - (# a, s' #) -> (a, s') diff --git a/GHC/Utils/Outputable.hs b/GHC/Utils/Outputable.hs --- a/GHC/Utils/Outputable.hs +++ b/GHC/Utils/Outputable.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} @@ -5,6 +6,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE FlexibleContexts #-} {- (c) The University of Glasgow 2006-2012 @@ -21,27 +24,28 @@ -- * Type classes Outputable(..), OutputableBndr(..), OutputableP(..), + IsOutput(..), IsLine(..), IsDoc(..), + HLine, HDoc, + -- * Pretty printing combinators SDoc, runSDoc, PDoc(..), docToSDoc, interppSP, interpp'SP, interpp'SP', pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, pprWithBars, - empty, isEmpty, nest, - char, - text, ftext, ptext, ztext, + spaceIfSingleQuote, + isEmpty, nest, + ptext, int, intWithCommas, integer, word, float, double, rational, doublePrec, parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, semi, comma, colon, dcolon, space, equals, dot, vbar, arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda, - lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, mulArrow, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, blankLine, forAllLit, bullet, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, + ($+$), + cat, fcat, hang, hangNotEmpty, punctuate, ppWhen, ppUnless, ppWhenOption, ppUnlessOption, speakNth, speakN, speakNOf, plural, singular, @@ -78,44 +82,54 @@ pprFastFilePath, pprFilePathString, + pprModuleName, + -- * Controlling the style in which output is printed BindingSite(..), - PprStyle(..), LabelStyle(..), PrintUnqualified(..), - QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, + PprStyle(..), NamePprCtx(..), + QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, QueryPromotionTick, + PromotedItem(..), IsEmptyOrSingleton(..), isListEmptyOrSingleton, + PromotionTickContext(..), reallyAlwaysQualify, reallyAlwaysQualifyNames, alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, neverQualify, neverQualifyNames, neverQualifyModules, alwaysQualifyPackages, neverQualifyPackages, + alwaysPrintPromTick, QualifyName(..), queryQual, sdocOption, updSDocContext, - SDocContext (..), sdocWithContext, defaultSDocContext, + SDocContext (..), sdocWithContext, + defaultSDocContext, traceSDocContext, getPprStyle, withPprStyle, setStyleColoured, pprDeeper, pprDeeperList, pprSetDepth, - codeStyle, userStyle, dumpStyle, asmStyle, - qualName, qualModule, qualPackage, + codeStyle, userStyle, dumpStyle, + qualName, qualModule, qualPackage, promTick, mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, mkUserStyle, cmdlineParserStyle, Depth(..), withUserStyle, withErrStyle, ifPprDebug, whenPprDebug, getPprDebug, + bPutHDoc ) where -import GHC.Prelude +import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) +import GHC.Prelude.Basic + import {-# SOURCE #-} GHC.Unit.Types ( Unit, Module, moduleName ) -import {-# SOURCE #-} GHC.Unit.Module.Name( ModuleName ) import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) -import GHC.Utils.BufHandle (BufHandle) +import GHC.Utils.BufHandle (BufHandle, bPutChar, bPutStr, bPutFS, bPutFZS) import GHC.Data.FastString import qualified GHC.Utils.Ppr as Pretty import qualified GHC.Utils.Ppr.Colour as Col import GHC.Utils.Ppr ( Doc, Mode(..) ) import GHC.Serialized import GHC.LanguageExtensions (Extension) +import GHC.Utils.GlobalVars( unsafeHasPprDebug ) +import GHC.Utils.Misc (lastMaybe) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -138,6 +152,7 @@ import qualified Data.List.NonEmpty as NEL import Data.Time import Data.Time.Format.ISO8601 +import Data.Void import GHC.Fingerprint import GHC.Show ( showMultiLineString ) @@ -153,32 +168,19 @@ -} data PprStyle - = PprUser PrintUnqualified Depth Coloured + = PprUser NamePprCtx Depth Coloured -- Pretty-print in a way that will make sense to the -- ordinary user; must be very close to Haskell -- syntax, etc. -- Assumes printing tidied code: non-system names are -- printed without uniques. - | PprDump PrintUnqualified + | PprDump NamePprCtx -- For -ddump-foo; less verbose than in ppr-debug mode, but more than PprUser -- Does not assume tidied code: non-external names -- are printed with uniques. - | PprCode !LabelStyle -- ^ Print code; either C or assembler - --- | 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. --- -data LabelStyle - = CStyle -- ^ C label style (used by C and LLVM backends) - | AsmStyle -- ^ Asm label style (used by NCG backend) - deriving (Eq,Ord,Show) + | PprCode -- ^ Print code; either C or assembler data Depth = AllTheWay @@ -196,10 +198,11 @@ -- original names back to something the user understands. This is the -- purpose of the triple of functions that gets passed around -- when rendering 'SDoc'. -data PrintUnqualified = QueryQualify { +data NamePprCtx = QueryQualify { queryQualifyName :: QueryQualifyName, queryQualifyModule :: QueryQualifyModule, - queryQualifyPackage :: QueryQualifyPackage + queryQualifyPackage :: QueryQualifyPackage, + queryPromotionTick :: QueryPromotionTick } -- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify @@ -214,6 +217,31 @@ -- the component id to disambiguate it. type QueryQualifyPackage = Unit -> Bool +-- | Given a promoted data constructor, +-- decide whether to print a tick to disambiguate the namespace. +type QueryPromotionTick = PromotedItem -> Bool + +-- | Flags that affect whether a promotion tick is printed. +data PromotionTickContext = + PromTickCtx { + ptcListTuplePuns :: !Bool, + ptcPrintRedundantPromTicks :: !Bool + } + +data PromotedItem = + PromotedItemListSyntax IsEmptyOrSingleton -- '[x] + | PromotedItemTupleSyntax -- '(x, y) + | PromotedItemDataCon OccName -- 'MkT + +newtype IsEmptyOrSingleton = IsEmptyOrSingleton Bool + +isListEmptyOrSingleton :: [a] -> IsEmptyOrSingleton +isListEmptyOrSingleton xs = + IsEmptyOrSingleton $ case xs of + [] -> True + [_] -> True + _ -> False + -- See Note [Printing original names] in GHC.Types.Name.Ppr data QualifyName -- Given P:M.T = NameUnqual -- It's in scope unqualified as "T" @@ -255,17 +283,23 @@ neverQualifyPackages :: QueryQualifyPackage neverQualifyPackages _ = False -reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified +alwaysPrintPromTick :: QueryPromotionTick +alwaysPrintPromTick _ = True + +reallyAlwaysQualify, alwaysQualify, neverQualify :: NamePprCtx reallyAlwaysQualify = QueryQualify reallyAlwaysQualifyNames alwaysQualifyModules alwaysQualifyPackages + alwaysPrintPromTick alwaysQualify = QueryQualify alwaysQualifyNames alwaysQualifyModules alwaysQualifyPackages + alwaysPrintPromTick neverQualify = QueryQualify neverQualifyNames neverQualifyModules neverQualifyPackages + alwaysPrintPromTick defaultUserStyle :: PprStyle defaultUserStyle = mkUserStyle neverQualify AllTheWay @@ -274,31 +308,31 @@ -- Print without qualifiers to reduce verbosity, unless -dppr-debug defaultDumpStyle = PprDump neverQualify -mkDumpStyle :: PrintUnqualified -> PprStyle -mkDumpStyle print_unqual = PprDump print_unqual +mkDumpStyle :: NamePprCtx -> PprStyle +mkDumpStyle name_ppr_ctx = PprDump name_ppr_ctx --- | Default style for error messages, when we don't know PrintUnqualified +-- | Default style for error messages, when we don't know NamePprCtx -- It's a bit of a hack because it doesn't take into account what's in scope -- Only used for desugarer warnings, and typechecker errors in interface sigs defaultErrStyle :: PprStyle defaultErrStyle = mkErrStyle neverQualify -- | Style for printing error messages -mkErrStyle :: PrintUnqualified -> PprStyle -mkErrStyle unqual = mkUserStyle unqual DefaultDepth +mkErrStyle :: NamePprCtx -> PprStyle +mkErrStyle name_ppr_ctx = mkUserStyle name_ppr_ctx DefaultDepth cmdlineParserStyle :: PprStyle cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay -mkUserStyle :: PrintUnqualified -> Depth -> PprStyle -mkUserStyle unqual depth = PprUser unqual depth Uncoloured +mkUserStyle :: NamePprCtx -> Depth -> PprStyle +mkUserStyle name_ppr_ctx depth = PprUser name_ppr_ctx depth Uncoloured -withUserStyle :: PrintUnqualified -> Depth -> SDoc -> SDoc -withUserStyle unqual depth doc = withPprStyle (PprUser unqual depth Uncoloured) doc +withUserStyle :: NamePprCtx -> Depth -> SDoc -> SDoc +withUserStyle name_ppr_ctx depth doc = withPprStyle (PprUser name_ppr_ctx depth Uncoloured) doc -withErrStyle :: PrintUnqualified -> SDoc -> SDoc -withErrStyle unqual doc = - withPprStyle (mkErrStyle unqual) doc +withErrStyle :: NamePprCtx -> SDoc -> SDoc +withErrStyle name_ppr_ctx doc = + withPprStyle (mkErrStyle name_ppr_ctx) doc setStyleColoured :: Bool -> PprStyle -> PprStyle setStyleColoured col style = @@ -358,7 +392,7 @@ , sdocLineLength :: !Int , sdocCanUseUnicode :: !Bool -- ^ True if Unicode encoding is supported - -- and not disable by GHC_NO_UNICODE environment variable + -- and not disabled by GHC_NO_UNICODE environment variable , sdocHexWordLiterals :: !Bool , sdocPprDebug :: !Bool , sdocPrintUnicodeSyntax :: !Bool @@ -386,7 +420,7 @@ , sdocErrorSpans :: !Bool , sdocStarIsType :: !Bool , sdocLinearTypes :: !Bool - , sdocImpredicativeTypes :: !Bool + , sdocListTuplePuns :: !Bool , sdocPrintTypeAbbreviations :: !Bool , sdocUnitIdForUser :: !(FastString -> SDoc) -- ^ Used to map UnitIds to more friendly "package-version:component" @@ -446,12 +480,24 @@ , sdocSuppressStgReps = True , sdocErrorSpans = False , sdocStarIsType = False - , sdocImpredicativeTypes = False , sdocLinearTypes = False + , sdocListTuplePuns = True , sdocPrintTypeAbbreviations = True , sdocUnitIdForUser = ftext } +traceSDocContext :: SDocContext +-- Used for pprTrace, when we want to see lots of info +traceSDocContext = defaultSDocContext + { sdocPprDebug = unsafeHasPprDebug + , sdocPrintTypecheckerElaboration = True + , sdocPrintExplicitKinds = True + , sdocPrintExplicitCoercions = True + , sdocPrintExplicitRuntimeReps = True + , sdocPrintExplicitForalls = True + , sdocPrintEqualityRelations = True + } + withPprStyle :: PprStyle -> SDoc -> SDoc {-# INLINE CONLIKE withPprStyle #-} withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} @@ -527,18 +573,20 @@ qualPackage (PprDump q) m = queryQualifyPackage q m qualPackage _other _m = True -queryQual :: PprStyle -> PrintUnqualified +promTick :: PprStyle -> QueryPromotionTick +promTick (PprUser q _ _) occ = queryPromotionTick q occ +promTick (PprDump q) occ = queryPromotionTick q occ +promTick _ _ = True + +queryQual :: PprStyle -> NamePprCtx queryQual s = QueryQualify (qualName s) (qualModule s) (qualPackage s) + (promTick s) codeStyle :: PprStyle -> Bool -codeStyle (PprCode _) = True -codeStyle _ = False - -asmStyle :: PprStyle -> Bool -asmStyle (PprCode AsmStyle) = True -asmStyle _other = False +codeStyle PprCode = True +codeStyle _ = False dumpStyle :: PprStyle -> Bool dumpStyle (PprDump {}) = True @@ -549,17 +597,17 @@ userStyle _other = False -- | Indicate if -dppr-debug mode is enabled -getPprDebug :: (Bool -> SDoc) -> SDoc +getPprDebug :: IsOutput doc => (Bool -> doc) -> doc {-# INLINE CONLIKE getPprDebug #-} -getPprDebug d = sdocWithContext $ \ctx -> d (sdocPprDebug ctx) +getPprDebug d = docWithContext $ \ctx -> d (sdocPprDebug ctx) -- | Says what to do with and without -dppr-debug -ifPprDebug :: SDoc -> SDoc -> SDoc +ifPprDebug :: IsOutput doc => doc -> doc -> doc {-# INLINE CONLIKE ifPprDebug #-} ifPprDebug yes no = getPprDebug $ \dbg -> if dbg then yes else no -- | Says what to do with -dppr-debug; without, return empty -whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style +whenPprDebug :: IsOutput doc => doc -> doc -- Empty for non-debug style {-# INLINE CONLIKE whenPprDebug #-} whenPprDebug d = ifPprDebug d empty @@ -586,9 +634,9 @@ bufLeftRenderSDoc ctx bufHandle doc = Pretty.bufLeftRender bufHandle (runSDoc doc ctx) -pprCode :: LabelStyle -> SDoc -> SDoc +pprCode :: SDoc -> SDoc {-# INLINE CONLIKE pprCode #-} -pprCode cs d = withPprStyle (PprCode cs) d +pprCode d = withPprStyle PprCode d renderWithContext :: SDocContext -> SDoc -> String renderWithContext ctx sdoc @@ -626,43 +674,26 @@ docToSDoc :: Doc -> SDoc docToSDoc d = SDoc (\_ -> d) -empty :: SDoc -char :: Char -> SDoc -text :: String -> SDoc -ftext :: FastString -> SDoc -ptext :: PtrString -> SDoc -ztext :: FastZString -> SDoc -int :: Int -> SDoc -integer :: Integer -> SDoc -word :: Integer -> SDoc -float :: Float -> SDoc -double :: Double -> SDoc -rational :: Rational -> SDoc - -{-# INLINE CONLIKE empty #-} -empty = docToSDoc $ Pretty.empty -{-# INLINE CONLIKE char #-} -char c = docToSDoc $ Pretty.char c - -{-# INLINE CONLIKE text #-} -- Inline so that the RULE Pretty.text will fire -text s = docToSDoc $ Pretty.text s +ptext :: PtrString -> SDoc +int :: IsLine doc => Int -> doc +integer :: IsLine doc => Integer -> doc +word :: Integer -> SDoc +float :: IsLine doc => Float -> doc +double :: IsLine doc => Double -> doc +rational :: Rational -> SDoc -{-# INLINE CONLIKE ftext #-} -ftext s = docToSDoc $ Pretty.ftext s {-# INLINE CONLIKE ptext #-} ptext s = docToSDoc $ Pretty.ptext s -{-# INLINE CONLIKE ztext #-} -ztext s = docToSDoc $ Pretty.ztext s {-# INLINE CONLIKE int #-} -int n = docToSDoc $ Pretty.int n +int n = text $ show n {-# INLINE CONLIKE integer #-} -integer n = docToSDoc $ Pretty.integer n +integer n = text $ show n {-# INLINE CONLIKE float #-} -float n = docToSDoc $ Pretty.float n +float n = text $ show n {-# INLINE CONLIKE double #-} -double n = docToSDoc $ Pretty.double n +double n = text $ show n {-# INLINE CONLIKE rational #-} -rational n = docToSDoc $ Pretty.rational n +rational n = text $ show n -- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr {-# INLINE CONLIKE word #-} word n = sdocOption sdocHexWordLiterals $ \case @@ -674,19 +705,19 @@ doublePrec :: Int -> Double -> SDoc doublePrec p n = text (showFFloat (Just p) n "") -parens, braces, brackets, quotes, quote, - doubleQuotes, angleBrackets :: SDoc -> SDoc +quotes, quote :: SDoc -> SDoc +parens, brackets, braces, doubleQuotes, angleBrackets :: IsLine doc => doc -> doc {-# INLINE CONLIKE parens #-} -parens d = SDoc $ Pretty.parens . runSDoc d +parens d = char '(' <> d <> char ')' {-# INLINE CONLIKE braces #-} -braces d = SDoc $ Pretty.braces . runSDoc d +braces d = char '{' <> d <> char '}' {-# INLINE CONLIKE brackets #-} -brackets d = SDoc $ Pretty.brackets . runSDoc d +brackets d = char '[' <> d <> char ']' {-# INLINE CONLIKE quote #-} quote d = SDoc $ Pretty.quote . runSDoc d {-# INLINE CONLIKE doubleQuotes #-} -doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +doubleQuotes d = char '"' <> d <> char '"' {-# INLINE CONLIKE angleBrackets #-} angleBrackets d = char '<' <> d <> char '>' @@ -705,42 +736,40 @@ in case str of [] -> Pretty.quotes pp_d '\'' : _ -> pp_d - _ | '\'' <- last str -> pp_d + _ | Just '\'' <- lastMaybe str -> pp_d | otherwise -> Pretty.quotes pp_d -semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc -arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda :: SDoc -lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc +blankLine, dcolon, arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, + larrowtt, lambda :: SDoc blankLine = docToSDoc Pretty.emptyText -dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") -arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") -lollipop = unicodeSyntax (char '⊸') (docToSDoc $ Pretty.text "%1 ->") -larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") -darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") -arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") -larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") -arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") -larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") +dcolon = unicodeSyntax (char '∷') (text "::") +arrow = unicodeSyntax (char '→') (text "->") +lollipop = unicodeSyntax (char '⊸') (text "%1 ->") +larrow = unicodeSyntax (char '←') (text "<-") +darrow = unicodeSyntax (char '⇒') (text "=>") +arrowt = unicodeSyntax (char '⤚') (text ">-") +larrowt = unicodeSyntax (char '⤙') (text "-<") +arrowtt = unicodeSyntax (char '⤜') (text ">>-") +larrowtt = unicodeSyntax (char '⤛') (text "-<<") lambda = unicodeSyntax (char 'λ') (char '\\') -semi = docToSDoc $ Pretty.semi -comma = docToSDoc $ Pretty.comma -colon = docToSDoc $ Pretty.colon -equals = docToSDoc $ Pretty.equals -space = docToSDoc $ Pretty.space + +semi, comma, colon, equals, space, underscore, dot, vbar :: IsLine doc => doc +lparen, rparen, lbrack, rbrack, lbrace, rbrace :: IsLine doc => doc +semi = char ';' +comma = char ',' +colon = char ':' +equals = char '=' +space = char ' ' underscore = char '_' dot = char '.' vbar = char '|' -lparen = docToSDoc $ Pretty.lparen -rparen = docToSDoc $ Pretty.rparen -lbrack = docToSDoc $ Pretty.lbrack -rbrack = docToSDoc $ Pretty.rbrack -lbrace = docToSDoc $ Pretty.lbrace -rbrace = docToSDoc $ Pretty.rbrace - -mulArrow :: SDoc -> SDoc -mulArrow d = text "%" <> d <+> arrow - +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' forAllLit :: SDoc forAllLit = unicodeSyntax (char '∀') (text "forall") @@ -763,59 +792,26 @@ nest :: Int -> SDoc -> SDoc -- ^ Indent 'SDoc' some specified amount -(<>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally without a gap -(<+>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally with a gap between them -($$) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together vertically; if there is --- no vertical overlap it "dovetails" the two onto one line ($+$) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together vertically {-# INLINE CONLIKE nest #-} nest n d = SDoc $ Pretty.nest n . runSDoc d -{-# INLINE CONLIKE (<>) #-} -(<>) d1 d2 = SDoc $ \ctx -> (Pretty.<>) (runSDoc d1 ctx) (runSDoc d2 ctx) -{-# INLINE CONLIKE (<+>) #-} -(<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx) -{-# INLINE CONLIKE ($$) #-} -($$) d1 d2 = SDoc $ \ctx -> (Pretty.$$) (runSDoc d1 ctx) (runSDoc d2 ctx) {-# INLINE CONLIKE ($+$) #-} ($+$) d1 d2 = SDoc $ \ctx -> (Pretty.$+$) (runSDoc d1 ctx) (runSDoc d2 ctx) -hcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally -hsep :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally with a space between each one -vcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' vertically with dovetailing -sep :: [SDoc] -> SDoc --- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits cat :: [SDoc] -> SDoc --- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits -fsep :: [SDoc] -> SDoc -- ^ A paragraph-fill combinator. It's much like sep, only it -- keeps fitting things on one line until it can't fit any more. fcat :: [SDoc] -> SDoc --- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' +-- ^ This behaves like 'fsep', but it uses '<>' for horizontal composition rather than '<+>' -- Inline all those wrappers to help ensure we create lists of Doc, not of SDoc -- later applied to the same SDocContext. It helps the worker/wrapper -- transformation extracting only the required fields from the SDocContext. -{-# INLINE CONLIKE hcat #-} -hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE hsep #-} -hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE vcat #-} -vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE sep #-} -sep ds = SDoc $ \ctx -> Pretty.sep [runSDoc d ctx | d <- ds] {-# INLINE CONLIKE cat #-} cat ds = SDoc $ \ctx -> Pretty.cat [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE fsep #-} -fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds] {-# INLINE CONLIKE fcat #-} fcat ds = SDoc $ \ctx -> Pretty.fcat [runSDoc d ctx | d <- ds] @@ -833,16 +829,17 @@ hangNotEmpty d1 n d2 = SDoc $ \ctx -> Pretty.hangNotEmpty (runSDoc d1 ctx) n (runSDoc d2 ctx) -punctuate :: SDoc -- ^ The punctuation - -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements - -> [SDoc] -- ^ Punctuated list +punctuate :: IsLine doc + => doc -- ^ The punctuation + -> [doc] -- ^ The list that will have punctuation added between every adjacent pair of elements + -> [doc] -- ^ Punctuated list punctuate _ [] = [] punctuate p (d:ds) = go d ds where go d [] = [d] go d (e:es) = (d <> p) : go e es -ppWhen, ppUnless :: Bool -> SDoc -> SDoc +ppWhen, ppUnless :: IsOutput doc => Bool -> doc -> doc {-# INLINE CONLIKE ppWhen #-} ppWhen True doc = doc ppWhen False _ = empty @@ -858,10 +855,9 @@ False -> empty {-# INLINE CONLIKE ppUnlessOption #-} -ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc -ppUnlessOption f doc = sdocOption f $ \case - True -> empty - False -> doc +ppUnlessOption :: IsLine doc => (SDocContext -> Bool) -> doc -> doc +ppUnlessOption f doc = docWithContext $ + \ctx -> if f ctx then empty else doc -- | Apply the given colour\/style for the argument. -- @@ -888,8 +884,8 @@ class Outputable a where ppr :: a -> SDoc -instance Outputable Char where - ppr c = text [c] +-- 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 Bool where ppr True = text "True" @@ -946,16 +942,16 @@ ppr = text . formatShow iso8601Format instance (Outputable a) => Outputable [a] where - ppr xs = brackets (fsep (punctuate comma (map ppr xs))) + ppr xs = brackets (pprWithCommas ppr xs) instance (Outputable a) => Outputable (NonEmpty a) where ppr = ppr . NEL.toList instance (Outputable a) => Outputable (Set a) where - ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) + ppr s = braces (pprWithCommas ppr (Set.toList s)) instance Outputable IntSet.IntSet where - ppr s = braces (fsep (punctuate comma (map ppr (IntSet.toList s)))) + 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]) @@ -1039,6 +1035,18 @@ instance Outputable Extension where ppr = text . show +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 +{-# SPECIALIZE pprModuleName :: ModuleName -> SDoc #-} +{-# SPECIALIZE pprModuleName :: ModuleName -> HLine #-} -- see Note [SPECIALIZE to HDoc] + ----------------------------------------------------------------------- -- The @OutputableP@ class ----------------------------------------------------------------------- @@ -1176,6 +1184,8 @@ instance (OutputableP env a) => OutputableP env (Set a) where pdoc env s = braces (fsep (punctuate comma (map (pdoc env) (Set.toList s)))) +instance OutputableP env Void where + pdoc _ = \ case {- ************************************************************************ @@ -1256,14 +1266,14 @@ primIntSuffix = char '#' primDoubleSuffix = text "##" primWordSuffix = text "##" -primInt8Suffix = text "#8" -primWord8Suffix = text "##8" -primInt16Suffix = text "#16" -primWord16Suffix = text "##16" -primInt32Suffix = text "#32" -primWord32Suffix = text "##32" -primInt64Suffix = text "#64" -primWord64Suffix = text "##64" +primInt8Suffix = text "#Int8" +primWord8Suffix = text "#Word8" +primInt16Suffix = text "#Int16" +primWord16Suffix = text "#Word16" +primInt32Suffix = text "#Int32" +primWord32Suffix = text "#Word32" +primInt64Suffix = text "#Int64" +primWord64Suffix = text "#Word64" -- | Special combinator for showing unboxed literals. pprPrimChar :: Char -> SDoc @@ -1305,12 +1315,14 @@ -- | Normalise, escape and render a string representing a path -- -- e.g. "c:\\whatever" -pprFilePathString :: FilePath -> SDoc +pprFilePathString :: IsLine doc => FilePath -> doc pprFilePathString path = doubleQuotes $ text (escape (normalise path)) where escape [] = [] escape ('\\':xs) = '\\':'\\':escape xs escape (x:xs) = x:escape xs +{-# SPECIALIZE pprFilePathString :: FilePath -> SDoc #-} +{-# SPECIALIZE pprFilePathString :: FilePath -> HLine #-} -- see Note [SPECIALIZE to HDoc] {- ************************************************************************ @@ -1332,6 +1344,16 @@ -- bar-separated and finally packed into a paragraph. pprWithBars pp xs = fsep (intersperse vbar (map pp xs)) +-- Prefix the document with a space if it starts with a single quote. +-- See Note [Printing promoted type constructors] in GHC.Iface.Type +spaceIfSingleQuote :: SDoc -> SDoc +spaceIfSingleQuote (SDoc m) = + SDoc $ \ctx -> + let (mHead, d) = Pretty.docHead (m ctx) + in if mHead == Just '\'' + then Pretty.space Pretty.<> d + else d + -- | Returns the separated concatenation of the pretty printed things. interppSP :: Outputable a => [a] -> SDoc interppSP xs = sep (map ppr xs) @@ -1489,3 +1511,352 @@ hasOrHave :: [a] -> SDoc hasOrHave [_] = text "has" hasOrHave _ = text "have" + +{- Note [SDoc versus HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The SDoc type is used pervasively throughout the compiler to represent pretty- +printable output. Almost all text written by GHC, from the Haskell types and +expressions included in error messages to debug dumps, is assembled using SDoc. +SDoc is nice because it handles multiline layout in a semi-automatic fashion, +enabling printed expressions to wrap to fit a given line width while correctly +indenting the following lines to preserve alignment. + +SDoc’s niceties necessarily have some performance cost, but this is normally +okay, as printing output is rarely a performance bottleneck. However, one +notable exception to this is code generation: GHC must sometimes write +megabytes’ worth of generated assembly when compiling a single module, in which +case the overhead of SDoc has a significant cost (see #21853 for some numbers). +Moreover, generated assembly does not have the complex layout requirements of +pretty-printed Haskell code, so using SDoc does not buy us much, anyway. + +Nevertheless, we do still want to be able to share some logic between writing +assembly and pretty-printing. For example, the logic for printing basic block +labels (GHC.Cmm.CLabel.pprCLabel) is nontrivial, so we want to have a single +implementation that can be used both when generating code and when generating +Cmm dumps. This is where HDoc comes in: HDoc provides a subset of the SDoc +interface, but it is implemented in a far more efficient way, writing directly +to a `Handle` (via a `BufHandle`) without building any intermediate structures. +We can then use typeclasses to parameterize functions like `pprCLabel` over the +printing implementation. + +One might imagine this would result in one IsDoc typeclass, and two instances, +one for SDoc and one for HDoc. However, in fact, we need two *variants* of HDoc, +as described in Note [HLine versus HDoc], and this gives rise to a small +typeclass hierarchy consisting of IsOutput, IsLine, and IsDoc; +see Note [The outputable class hierarchy] for details. + +Note [HLine versus HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [SDoc versus HDoc], HDoc does not support any of the layout +niceties of SDoc for efficiency. However, this presents a small problem if we +want to be compatible with the SDoc API, as expressions like + + text "foo" <+> (text "bar" $$ text "baz") + +are expected to produce + + foo bar + baz + +which requires tracking line widths to know how far to indent the second line. +We can’t throw out vertical composition altogether, as we need to be able to +construct multiline HDocs, but we *can* restrict vertical composition to +concatenating whole lines at a time, as this is all that is necessary to +generate assembly in the code generator. + +To implement this restriction, we provide two distinct types: HLine and HDoc. +As their names suggests, an HLine represents a single line of output, while an +HDoc represents a multiline document. Atoms formed from `char` and `text` begin +their lives as HLines, which can be horizontally (but not vertically) composed: + + char :: Char -> HLine + text :: String -> HLine + (<+>) :: HLine -> HLine -> HLine + +Once a line has been fully assembled, it can be “locked up” into a single-line +HDoc via `line`, and HDocs can be vertically (but not horizontally) composed: + + line :: HLine -> HDoc + ($$) :: HLine -> HLine -> HLine + +Note that, at runtime, HLine and HDoc use exactly the same representation. This +distinction only exists in the type system to rule out the cases we don’t want +to have to handle. + +Note [The outputable class hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [SDoc versus HDoc], we want to be able to parameterize over +the choice of printing implementation when implementing common bits of printing +logic. However, as described in Note [HLine versus HDoc], we also want to +distinguish code that does single-line printing from code that does multi-line +printing. Therefore, code that is parameterized over the choice of printer must +respect this single- versus multi-line distinction. This naturally leads to two +typeclasses: + + class IsLine doc where + char :: Char -> doc + text :: String -> doc + (<>) :: doc -> doc -> doc + ... + + class IsLine (Line doc) => IsDoc doc where + type Line doc = r | r -> doc + line :: Line doc -> doc + ($$) :: doc -> doc -> doc + ... + +These classes support the following instances: + + instance IsLine SDoc + instance IsLine SDoc where + type Line SDoc = SDoc + + instance IsLine HLine + instance IsDoc HDoc where + type Line HDoc = HLine + +However, we run into a new problem: we provide many useful combinators on docs +that don’t care at all about the single-/multi-line distinction. For example, +ppWhen and ppUnless provide conditional logic, and docWithContext provides +access to the ambient SDocContext. Given the above classes, we would need two +variants of each of these combinators: + + ppWhenL :: IsLine doc => Bool -> doc -> doc + ppWhenL c d = if c then d else emptyL + + ppWhenD :: IsDoc doc => Bool -> doc -> doc + ppWhenD c d = if c then d else emptyD + +This is a needlessly annoying distinction, so we introduce a common superclass, +IsOutput, that allows these combinators to be generic over both variants: + + class IsOutput doc where + empty :: doc + docWithContext :: (SDocContext -> doc) -> doc + + class IsOutput doc => IsLine doc + class (IsOutput doc, IsLine (Line doc)) => IsDoc doc + +In practice, IsOutput isn’t used explicitly very often, but it makes code that +uses the combinators derived from it significantly less noisy. + +Note [SPECIALIZE to HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The IsLine and IsDoc classes are useful to share printing logic between code +that uses SDoc and code that uses HDoc, but we must take some care when doing +so. Much HDoc’s efficiency comes from GHC’s ability to optimize code that uses +it to eliminate unnecessary indirection, but the HDoc primitives must be inlined +before these opportunities can be exposed. Therefore, we want to explicitly +request that GHC generate HDoc (or HLine) specializations of any polymorphic +printing functions used by the code generator. + +In code generators (CmmToAsm.{AArch64,PPC,X86}.Ppr) we add a specialize +pragma just to the entry point pprNatCmmDecl, to avoid cluttering +the entire module. Because specialization is transitive, this makes sure +that other functions in that module are specialized too. + +Note [dualLine and dualDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The IsLine and IsDoc classes provide the dualLine and dualDoc methods, +respectively, which have the following types: + + dualLine :: IsLine doc => SDoc -> HLine -> doc + dualDoc :: IsDoc doc => SDoc -> HDoc -> doc + +These are effectively a form of type-`case`, selecting between each of their two +arguments depending on the type they are instantiated at. They serve as a +“nuclear option” for code that is, for some reason or another, unreasonably +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. + +Use these operations wisely. -} + +-- | 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. +newtype HLine = HLine' { runHLine :: SDocContext -> BufHandle -> IO () } + +-- | Represents a (possibly empty) sequence of lines 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. +newtype HDoc = HDoc' { runHDoc :: SDocContext -> BufHandle -> IO () } + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern HLine :: (SDocContext -> BufHandle -> IO ()) -> HLine +pattern HLine f <- HLine' f + where HLine f = HLine' (oneShot (\ctx -> oneShot (\h -> f ctx h))) +{-# COMPLETE HLine #-} + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern HDoc :: (SDocContext -> BufHandle -> IO ()) -> HDoc +pattern HDoc f <- HDoc' f + where HDoc f = HDoc' (oneShot (\ctx -> oneShot (\h -> f ctx h))) +{-# COMPLETE HDoc #-} + +bPutHDoc :: BufHandle -> SDocContext -> HDoc -> IO () +bPutHDoc h ctx (HDoc f) = f ctx h + +-- | A superclass for 'IsLine' and 'IsDoc' that provides an identity, 'empty', +-- as well as access to the shared 'SDocContext'. +-- +-- See Note [The outputable class hierarchy] for more details. +class IsOutput doc where + empty :: doc + docWithContext :: (SDocContext -> doc) -> doc + +-- | A class of types that represent a single logical line of text, with support +-- for horizontal composition. +-- +-- See Note [HLine versus HDoc] and Note [The outputable class hierarchy] for +-- more details. +class IsOutput doc => IsLine doc where + char :: Char -> doc + text :: String -> doc + ftext :: FastString -> doc + ztext :: FastZString -> doc + + -- | Join two @doc@s together horizontally without a gap. + (<>) :: doc -> doc -> doc + -- | Join two @doc@s together horizontally with a gap between them. + (<+>) :: doc -> doc -> doc + -- | Separate: is either like 'hsep' or like 'vcat', depending on what fits. + sep :: [doc] -> doc + -- | A paragraph-fill combinator. It's much like 'sep', only it keeps fitting + -- things on one line until it can't fit any more. + fsep :: [doc] -> doc + + -- | Concatenate @doc@s horizontally without gaps. + hcat :: [doc] -> doc + hcat docs = foldr (<>) empty docs + {-# INLINE CONLIKE hcat #-} + + -- | Concatenate @doc@s horizontally with a space between each one. + hsep :: [doc] -> doc + hsep docs = foldr (<+>) empty docs + {-# INLINE CONLIKE hsep #-} + + -- | Prints as either the given 'SDoc' or the given 'HLine', depending on + -- which type the result is instantiated to. This should generally be avoided; + -- see Note [dualLine and dualDoc] for details. + dualLine :: SDoc -> HLine -> doc + + +-- | A class of types that represent a multiline document, with support for +-- vertical composition. +-- +-- See Note [HLine versus HDoc] and Note [The outputable class hierarchy] for +-- more details. +class (IsOutput doc, IsLine (Line doc)) => IsDoc doc where + type Line doc = r | r -> doc + line :: Line doc -> doc + + -- | Join two @doc@s together vertically. If there is no vertical overlap it + -- "dovetails" the two onto one line. + ($$) :: doc -> doc -> doc + + lines_ :: [Line doc] -> doc + lines_ = vcat . map line + {-# INLINE CONLIKE lines_ #-} + + -- | Concatenate @doc@s vertically with dovetailing. + vcat :: [doc] -> doc + vcat ls = foldr ($$) empty ls + {-# INLINE CONLIKE vcat #-} + + -- | Prints as either the given 'SDoc' or the given 'HDoc', depending on + -- which type the result is instantiated to. This should generally be avoided; + -- see Note [dualLine and dualDoc] for details. + dualDoc :: SDoc -> HDoc -> doc + +instance IsOutput SDoc where + empty = docToSDoc $ Pretty.empty + {-# INLINE CONLIKE empty #-} + docWithContext = sdocWithContext + {-# INLINE docWithContext #-} + +instance IsLine SDoc where + char c = docToSDoc $ Pretty.char c + {-# INLINE CONLIKE char #-} + text s = docToSDoc $ Pretty.text s + {-# INLINE CONLIKE text #-} -- Inline so that the RULE Pretty.text will fire + ftext s = docToSDoc $ Pretty.ftext s + {-# INLINE CONLIKE ftext #-} + ztext s = docToSDoc $ Pretty.ztext s + {-# INLINE CONLIKE ztext #-} + (<>) d1 d2 = SDoc $ \ctx -> (Pretty.<>) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE (<>) #-} + (<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE (<+>) #-} + hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE hcat #-} + hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE hsep #-} + sep ds = SDoc $ \ctx -> Pretty.sep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE sep #-} + fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE fsep #-} + dualLine s _ = s + {-# INLINE CONLIKE dualLine #-} + +instance IsDoc SDoc where + type Line SDoc = SDoc + line = id + {-# INLINE line #-} + lines_ = vcat + {-# INLINE lines_ #-} + + ($$) d1 d2 = SDoc $ \ctx -> (Pretty.$$) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE ($$) #-} + vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE vcat #-} + dualDoc s _ = s + {-# INLINE CONLIKE dualDoc #-} + +instance IsOutput HLine where + empty = HLine (\_ _ -> pure ()) + {-# INLINE empty #-} + docWithContext f = HLine $ \ctx h -> runHLine (f ctx) ctx h + {-# INLINE CONLIKE docWithContext #-} + +instance IsOutput HDoc where + empty = HDoc (\_ _ -> pure ()) + {-# INLINE empty #-} + docWithContext f = HDoc $ \ctx h -> runHDoc (f ctx) ctx h + {-# INLINE CONLIKE docWithContext #-} + +instance IsLine HLine where + char c = HLine (\_ h -> bPutChar h c) + {-# INLINE CONLIKE char #-} + text str = HLine (\_ h -> bPutStr h str) + {-# INLINE CONLIKE text #-} + ftext fstr = HLine (\_ h -> bPutFS h fstr) + {-# INLINE CONLIKE ftext #-} + ztext fstr = HLine (\_ h -> bPutFZS h fstr) + {-# INLINE CONLIKE ztext #-} + + HLine f <> HLine g = HLine (\ctx h -> f ctx h *> g ctx h) + {-# INLINE CONLIKE (<>) #-} + f <+> g = f <> char ' ' <> g + {-# INLINE CONLIKE (<+>) #-} + sep = hsep + {-# INLINE sep #-} + fsep = hsep + {-# INLINE fsep #-} + + dualLine _ h = h + {-# INLINE CONLIKE dualLine #-} + +instance IsDoc HDoc where + type Line HDoc = HLine + line (HLine f) = HDoc (\ctx h -> f ctx h *> bPutChar h '\n') + {-# INLINE CONLIKE line #-} + HDoc f $$ HDoc g = HDoc (\ctx h -> f ctx h *> g ctx h) + {-# INLINE CONLIKE ($$) #-} + dualDoc _ h = h + {-# INLINE CONLIKE dualDoc #-} diff --git a/GHC/Utils/Outputable.hs-boot b/GHC/Utils/Outputable.hs-boot deleted file mode 100644 --- a/GHC/Utils/Outputable.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -module GHC.Utils.Outputable where - -import GHC.Prelude - -data SDoc -data PprStyle -data SDocContext - -text :: String -> SDoc diff --git a/GHC/Utils/Panic.hs b/GHC/Utils/Panic.hs --- a/GHC/Utils/Panic.hs +++ b/GHC/Utils/Panic.hs @@ -12,30 +12,37 @@ -- It's hard to put these functions anywhere else without causing -- some unnecessary loops in the module dependency graph. module GHC.Utils.Panic - ( GhcException(..) + ( -- * GHC exception type + GhcException(..) , showGhcException , showGhcExceptionUnsafe , throwGhcException , throwGhcExceptionIO , handleGhcException + -- * Command error throwing patterns , pgmError , panic , pprPanic - , assertPanic - , assertPprPanic - , assertPpr - , assertPprM - , massertPpr , sorry , panicDoc , sorryDoc , pgmErrorDoc , cmdLineError , cmdLineErrorIO + -- ** Assertions + , assertPanic + , assertPprPanic + , assertPpr + , assertPprMaybe + , assertPprM + , massertPpr + + -- * Call stacks , callStackDoc , prettyCallStackDoc + -- * Exception utilities , Exception.Exception(..) , showException , safeShowException @@ -46,7 +53,7 @@ ) where -import GHC.Prelude +import GHC.Prelude.Basic import GHC.Stack import GHC.Utils.Outputable @@ -309,6 +316,12 @@ if debugIsOn && not cond then withFrozenCallStack (assertPprPanic msg) else a + +assertPprMaybe :: HasCallStack => Maybe SDoc -> a -> a +{-# INLINE assertPprMaybe #-} +assertPprMaybe mb_msg a + | debugIsOn, Just msg <- mb_msg = withFrozenCallStack (assertPprPanic msg) + | otherwise = a massertPpr :: (HasCallStack, Applicative m) => Bool -> SDoc -> m () {-# INLINE massertPpr #-} 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 @@ -28,7 +28,7 @@ import GHC.Utils.Constants import GHC.Utils.Exception as Exception import GHC.Stack -import GHC.Prelude +import GHC.Prelude.Basic import System.IO.Unsafe -- | This type is very similar to 'GHC.Utils.Panic.GhcException', but it omits @@ -101,11 +101,12 @@ throwPlainGhcException = Exception.throw -- | Panics and asserts. -panic, sorry, pgmError :: String -> a +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) + then throwPlainGhcException (PlainPanic (x ++ '\n' : doc)) else throwPlainGhcException (PlainPanic (x ++ '\n' : renderStack stack)) sorry x = throwPlainGhcException (PlainSorry x) diff --git a/GHC/Utils/Ppr.hs b/GHC/Utils/Ppr.hs --- a/GHC/Utils/Ppr.hs +++ b/GHC/Utils/Ppr.hs @@ -79,7 +79,7 @@ lparen, rparen, lbrack, rbrack, lbrace, rbrace, -- ** Wrapping documents in delimiters - parens, brackets, braces, quotes, quote, doubleQuotes, + parens, brackets, braces, quotes, squotes, quote, doubleQuotes, maybeParens, -- ** Combining documents @@ -93,6 +93,7 @@ -- * Predicates on documents isEmpty, + docHead, -- * Rendering documents @@ -107,11 +108,12 @@ -- ** GHC-specific rendering printDoc, printDoc_, - bufLeftRender -- performance hack + bufLeftRender, printLeftRender -- performance hack ) where -import GHC.Prelude hiding (error) +import GHC.Prelude.Basic hiding (error) +import Control.Applicative ((<|>)) import GHC.Utils.BufHandle import GHC.Data.FastString @@ -350,6 +352,37 @@ isEmpty Empty = True isEmpty _ = False +-- | Get the first character of a document. We also return a new document, +-- equivalent to the original one but faster to render. Use it to avoid work +-- duplication. +docHead :: Doc -> (Maybe Char, Doc) +docHead d = (headChar, rdoc) + where + rdoc = reduceDoc d + headChar = go rdoc + + go :: RDoc -> Maybe Char + go (Union p q) = go (first p q) + go (Nest _ p) = go p + go Empty = Nothing + go (NilAbove _) = Just '\n' + go (TextBeside td _ p) = go_td td <|> go p + go NoDoc = error "docHead: NoDoc" + go (Above {}) = error "docHead: Above" + go (Beside {}) = error "docHead: Beside" + + go_td :: TextDetails -> Maybe Char + go_td (Chr c) = Just c + go_td (Str s) = go_str s + go_td (PStr s) = go_str (unpackFS s) -- O(1) because unpackFS is lazy + go_td (ZStr s) = go_str (zStringTakeN 1 s) + go_td (LStr s) = go_str (unpackPtrStringTakeN 1 s) + go_td (RStr n c) = if n > 0 then Just c else Nothing + + go_str :: String -> Maybe Char + go_str [] = Nothing + go_str (c:_) = Just c + {- Q: What is the reason for negative indentation (i.e. argument to indent is < 0) ? @@ -429,10 +462,12 @@ parens :: Doc -> Doc -- ^ Wrap document in @(...)@ brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ braces :: Doc -> Doc -- ^ Wrap document in @{...}@ -quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ +quotes :: Doc -> Doc -- ^ Wrap document in @\`...\'@ +squotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ quote :: Doc -> Doc doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ quotes p = char '`' <> p <> char '\'' +squotes p = char '\'' <> p <> char '\'' quote p = char '\'' <> p doubleQuotes p = char '"' <> p <> char '"' parens p = char '(' <> p <> char ')' @@ -1137,16 +1172,14 @@ bufLeftRender b doc = layLeft b (reduceDoc doc) layLeft :: BufHandle -> Doc -> IO () -layLeft b _ | b `seq` False = undefined -- make it strict in b -layLeft _ NoDoc = error "layLeft: NoDoc" +layLeft !_ NoDoc = error "layLeft: NoDoc" layLeft b (Union p q) = layLeft b $! first p q layLeft b (Nest _ p) = layLeft b $! p layLeft b Empty = bPutChar b '\n' -layLeft b (NilAbove p) = p `seq` (bPutChar b '\n' >> layLeft b p) -layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p) +layLeft b (NilAbove p) = bPutChar b '\n' >> layLeft b p +layLeft b (TextBeside s _ p) = put b s >> layLeft b p where - put b _ | b `seq` False = undefined - put b (Chr c) = bPutChar b c + put !b (Chr c) = bPutChar b c put b (Str s) = bPutStr b s put b (PStr s) = bPutFS b s put b (ZStr s) = bPutFZS b s diff --git a/GHC/Utils/Ppr/Colour.hs b/GHC/Utils/Ppr/Colour.hs --- a/GHC/Utils/Ppr/Colour.hs +++ b/GHC/Utils/Ppr/Colour.hs @@ -1,5 +1,5 @@ module GHC.Utils.Ppr.Colour where -import GHC.Prelude +import GHC.Prelude.Basic import Data.Maybe (fromMaybe) import GHC.Data.Bool diff --git a/GHC/Utils/Trace.hs b/GHC/Utils/Trace.hs --- a/GHC/Utils/Trace.hs +++ b/GHC/Utils/Trace.hs @@ -13,7 +13,18 @@ ) where -import GHC.Prelude +{- Note [Exporting pprTrace from GHC.Prelude] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For our own sanity we want to export pprTrace from GHC.Prelude. +Since calls to traces should never be performance sensitive it's okay for these +to be source imports/exports. However we still need to make sure that all +transitive imports from Trace.hs-boot do not import GHC.Prelude. + +To get there we import the basic GHC.Prelude.Basic prelude instead of GHC.Prelude +within the transitive dependencies of Trace.hs +-} + +import GHC.Prelude.Basic import GHC.Utils.Outputable import GHC.Utils.Exception import GHC.Utils.Panic @@ -28,7 +39,7 @@ pprTrace :: String -> SDoc -> a -> a pprTrace str doc x | unsafeHasNoDebugOutput = x - | otherwise = pprDebugAndThen defaultSDocContext trace (text str) doc x + | otherwise = pprDebugAndThen traceSDocContext trace (text str) doc x pprTraceM :: Applicative f => String -> SDoc -> f () pprTraceM str doc = pprTrace str doc (pure ()) @@ -69,7 +80,7 @@ warnPprTrace _ _s _msg x | unsafeHasNoDebugOutput = x warnPprTrace False _s _msg x = x warnPprTrace True s msg x - = pprDebugAndThen defaultSDocContext trace (text "WARNING:") + = pprDebugAndThen traceSDocContext trace (text "WARNING:") (text s $$ msg $$ withFrozenCallStack traceCallStackDoc ) x @@ -78,7 +89,7 @@ pprTraceUserWarning :: HasCallStack => SDoc -> a -> a pprTraceUserWarning msg x | unsafeHasNoDebugOutput = x - | otherwise = pprDebugAndThen defaultSDocContext trace (text "WARNING:") + | otherwise = pprDebugAndThen traceSDocContext trace (text "WARNING:") (msg $$ withFrozenCallStack traceCallStackDoc ) x diff --git a/GHC/Wasm/ControlFlow.hs b/GHC/Wasm/ControlFlow.hs new file mode 100644 --- /dev/null +++ b/GHC/Wasm/ControlFlow.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds, GADTs, RankNTypes, KindSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} + +module GHC.Wasm.ControlFlow + ( WasmControl(..), (<>), pattern WasmIf + , BrTableInterval(..), inclusiveInterval + + , WasmType, WasmTypeTag(..) + , TypeList(..) + , WasmFunctionType(..) + ) +where + +import GHC.Prelude + +import GHC.CmmToAsm.Wasm.Types +import GHC.Utils.Panic + +{-| +Module : GHC.Wasm.ControlFlow +Description : Representation of control-flow portion of the WebAssembly instruction set +-} + +inclusiveInterval :: Integer -> Integer -> BrTableInterval +inclusiveInterval lo hi + | lo <= hi = let count = hi - lo + 1 + in BrTableInterval lo count + | otherwise = panic "GHC.Wasm.ControlFlow: empty interval" + +(<>) :: forall s e pre mid post + . WasmControl s e pre mid + -> WasmControl s e mid post + -> WasmControl s e pre post +(<>) = WasmSeq +-- N.B. Fallthrough can't be optimized away because of type checking. + + + +-- Syntactic sugar. +pattern WasmIf :: WasmFunctionType pre post + -> e + -> WasmControl s e pre post + -> WasmControl s e pre post + -> WasmControl s e pre post + +pattern WasmIf ty e t f = + WasmPush TagI32 e `WasmSeq` WasmIfTop ty t f diff --git a/GHC/Wasm/ControlFlow/FromCmm.hs b/GHC/Wasm/ControlFlow/FromCmm.hs new file mode 100644 --- /dev/null +++ b/GHC/Wasm/ControlFlow/FromCmm.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} + +module GHC.Wasm.ControlFlow.FromCmm + ( structuredControl + ) +where + +import GHC.Prelude hiding (succ) + +import Data.Function +import Data.List (sortBy) +import qualified Data.Tree as Tree + +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.Switch + +import GHC.CmmToAsm.Wasm.Types + +import GHC.Platform + +import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr + , pprWithCommas + ) + +import GHC.Wasm.ControlFlow + + +{-| +Module : GHC.Wasm.ControlFlow.FromCmm +Description : Translation of (reducible) Cmm control flow to WebAssembly + +Code in this module can translate any _reducible_ Cmm control-flow +graph to the structured control flow that is required by WebAssembly. +The algorithm is subtle and is described in detail in a draft paper +to be found at https://www.cs.tufts.edu/~nr/pubs/relooper.pdf. +-} + +--------------------- Abstraction of Cmm control flow ----------------------- + +-- | Abstracts the kind of control flow we understand how to convert. +-- A block can be left in one of four ways: +-- +-- * Unconditionally +-- +-- * Conditionally on a predicate of type `e` +-- +-- * To a location determined by the value of a scrutinee of type `e` +-- +-- * Not at all. + +data ControlFlow e = Unconditional Label + | Conditional e Label Label + | Switch { _scrutinee :: e + , _range :: BrTableInterval + , _targets :: [Maybe Label] -- from 0 + , _defaultTarget :: Maybe Label + } + | TailCall e + +flowLeaving :: Platform -> CmmBlock -> ControlFlow CmmExpr +flowLeaving platform b = + case lastNode b of + CmmBranch l -> Unconditional l + CmmCondBranch c t f _ -> Conditional c t f + CmmSwitch e targets -> + let (offset, target_labels) = switchTargetsToTable targets + (lo, hi) = switchTargetsRange targets + default_label = switchTargetsDefault targets + 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 + _ -> panic "flowLeaving: unreachable" + +----------------------- Evaluation contexts ------------------------------ + +-- | The syntactic constructs in which Wasm code may be contained. +-- A list of these constructs represents an evaluation context, +-- which is used to determined what level of `br` instruction +-- reaches a given label. + +data ContainingSyntax + = BlockFollowedBy Label + | LoopHeadedBy Label + | IfThenElse (Maybe Label) -- ^ Carries the label that follows `if...end`, if any + +matchesFrame :: Label -> ContainingSyntax -> Bool +matchesFrame label (BlockFollowedBy l) = label == l +matchesFrame label (LoopHeadedBy l) = label == l +matchesFrame label (IfThenElse (Just l)) = label == l +matchesFrame _ _ = False + +data Context = Context { enclosing :: [ContainingSyntax] + , fallthrough :: Maybe Label -- the label can + -- be reached just by "falling through" + -- the hole + } + +instance Outputable Context where + ppr c | Just l <- fallthrough c = + pprWithCommas ppr (enclosing c) <+> text "fallthrough to" <+> ppr l + | otherwise = pprWithCommas ppr (enclosing c) + +emptyContext :: Context +emptyContext = Context [] Nothing + +inside :: ContainingSyntax -> Context -> Context +withFallthrough :: Context -> Label -> Context + +inside frame c = c { enclosing = frame : enclosing c } +withFallthrough c l = c { fallthrough = Just l } + +type CmmActions = Block CmmNode O O + +type FT pre post = WasmFunctionType pre post + +returns :: FT '[] '[ 'I32] +doesn'tReturn :: FT '[] '[] + +returns = WasmFunctionType TypeListNil (TypeListCons TagI32 TypeListNil) +doesn'tReturn = WasmFunctionType TypeListNil TypeListNil + +emptyPost :: FT pre post -> Bool +emptyPost (WasmFunctionType _ TypeListNil) = True +emptyPost _ = False + +----------------------- Translation ------------------------------ + +-- | Convert a Cmm CFG to WebAssembly's structured control flow. + +structuredControl :: forall expr stmt m . + Applicative 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 + + dominatorTree :: Tree.Tree CmmBlock-- Dominator tree in which children are sorted + -- with highest reverse-postorder number first + dominatorTree = fmap blockLabeled $ sortTree $ gwdDominatorTree gwd + + doTree :: FT '[] post -> Tree.Tree CmmBlock -> Context -> m (WasmControl stmt expr '[] post) + nodeWithin :: forall post . + FT '[] post -> CmmBlock -> [Tree.Tree CmmBlock] -> Maybe Label + -> Context -> m (WasmControl stmt expr '[] post) + doBranch :: FT '[] post -> Label -> Label -> Context -> m (WasmControl stmt expr '[] post) + + doTree fty (Tree.Node x children) context = + let codeForX = nodeWithin fty x selectedChildren Nothing + in if isLoopHeader x then + WasmLoop fty <$> codeForX loopContext + else + codeForX context + where selectedChildren = case lastNode x of + CmmSwitch {} -> children + -- N.B. Unlike `if`, translation of Switch uses only labels. + _ -> filter hasMergeRoot children + loopContext = LoopHeadedBy (entryLabel x) `inside` context + hasMergeRoot = isMergeNode . Tree.rootLabel + + nodeWithin fty x (y_n:ys) (Just zlabel) context = + WasmBlock fty <$> nodeWithin fty x (y_n:ys) Nothing context' + where context' = BlockFollowedBy zlabel `inside` context + nodeWithin fty x (y_n:ys) Nothing context = + nodeWithin doesn'tReturn x ys (Just ylabel) (context `withFallthrough` ylabel) <<>> + doTree fty y_n context + where ylabel = treeEntryLabel y_n + nodeWithin fty x [] (Just zlabel) context + | not (generatesIf x) = + WasmBlock fty <$> nodeWithin fty x [] Nothing context' + where context' = BlockFollowedBy zlabel `inside` context + nodeWithin fty x [] maybeMarks context = + translationOfX context + where xlabel = entryLabel x + + translationOfX :: Context -> m (WasmControl stmt expr '[] post) + translationOfX context = + (WasmActions <$> txBlock xlabel (nodeBody x)) <<>> + case flowLeaving platform x of + Unconditional l -> doBranch fty xlabel l context + Conditional e t f -> + WasmIf fty + <$> txExpr xlabel e + <*> doBranch fty xlabel t (IfThenElse maybeMarks `inside` context) + <*> doBranch fty xlabel f (IfThenElse maybeMarks `inside` context) + TailCall e -> WasmTailCall <$> txExpr xlabel e + Switch e range targets default' -> + WasmBrTable <$> txExpr xlabel e + <$~> range + <$~> map switchIndex targets + <$~> switchIndex default' + where switchIndex :: Maybe Label -> Int + switchIndex Nothing = 0 -- arbitrary; GHC won't go here + switchIndex (Just lbl) = index lbl (enclosing context) + + doBranch fty from to context + | to `elem` fallthrough context && emptyPost fty = pure WasmFallthrough + -- optimization: `br` is not needed, but it typechecks + -- only if nothing is expected to be left on the stack + + | isBackward from to = pure $ WasmBr i -- continue + | isMergeLabel to = pure $ WasmBr i -- exit + | otherwise = doTree fty (subtreeAt to) context -- inline the code here + where i = index to (enclosing context) + + generatesIf :: CmmBlock -> Bool + generatesIf x = case flowLeaving platform x of Conditional {} -> True + _ -> False + + ---- everything else is utility functions + + treeEntryLabel :: Tree.Tree CmmBlock -> Label + treeEntryLabel = entryLabel . Tree.rootLabel + + sortTree :: Tree.Tree Label -> Tree.Tree Label + -- Sort highest rpnum first + sortTree (Tree.Node label children) = + Tree.Node label $ sortBy (flip compare `on` (rpnum . Tree.rootLabel)) $ + map sortTree children + + subtreeAt :: Label -> Tree.Tree CmmBlock + blockLabeled :: Label -> CmmBlock + rpnum :: Label -> RPNum-- reverse postorder number of the labeled block + isMergeLabel :: Label -> Bool + isMergeNode :: CmmBlock -> Bool + isLoopHeader :: CmmBlock -> Bool-- identify loop headers + -- all nodes whose immediate dominator is the given block. + -- They are produced with the largest RP number first, + -- so the largest RP number is pushed on the context first. + dominates :: Label -> Label -> Bool + -- Domination relation (not just immediate domination) + + blockmap :: LabelMap CmmBlock + GMany NothingO blockmap NothingO = g_graph g + + blockLabeled l = findLabelIn l blockmap + + rpblocks :: [CmmBlock] + rpblocks = revPostorderFrom blockmap (g_entry g) + + foldEdges :: forall a . (Label -> Label -> a -> a) -> a -> a + foldEdges f a = + foldl (\a (from, to) -> f from to a) + a + [(entryLabel from, to) | from <- rpblocks, to <- successors from] + + isMergeLabel l = setMember l mergeBlockLabels + isMergeNode = isMergeLabel . entryLabel + + isBackward :: Label -> Label -> Bool + isBackward from to = rpnum to <= rpnum from -- self-edge counts as a backward edge + + subtreeAt label = findLabelIn label subtrees + subtrees :: LabelMap (Tree.Tree CmmBlock) + subtrees = addSubtree mapEmpty dominatorTree + where addSubtree map t@(Tree.Node root children) = + foldl addSubtree (mapInsert (entryLabel root) t map) children + + mergeBlockLabels :: LabelSet + -- N.B. A block is a merge node if it is where control flow merges. + -- That means it is entered by multiple control-flow edges, _except_ + -- back edges don't count. There must be multiple paths that enter the + -- block _without_ passing through the block itself. + mergeBlockLabels = + setFromList [entryLabel n | n <- rpblocks, big (forwardPreds (entryLabel n))] + where big [] = False + big [_] = False + big (_ : _ : _) = True + + forwardPreds :: Label -> [Label] -- reachable predecessors of reachable blocks, + -- via forward edges only + forwardPreds = \l -> mapFindWithDefault [] l predmap + where predmap :: LabelMap [Label] + predmap = foldEdges addForwardEdge mapEmpty + addForwardEdge from to pm + | isBackward from to = pm + | otherwise = addToList (from :) to pm + + isLoopHeader = isHeaderLabel . entryLabel + isHeaderLabel = (`setMember` headers) -- loop headers + where headers :: LabelSet + headers = foldMap headersPointedTo blockmap + headersPointedTo block = + setFromList [label | label <- successors block, + dominates label (entryLabel block)] + + index :: Label -> [ContainingSyntax] -> Int + index _ [] = panic "destination label not in evaluation context" + index label (frame : context) + | label `matchesFrame` frame = 0 + | otherwise = 1 + index label context + + rpnum = gwdRPNumber gwd + dominates lbl blockname = + lbl == blockname || dominatorsMember lbl (gwdDominatorsOf gwd blockname) + + + +nodeBody :: CmmBlock -> CmmActions +nodeBody (BlockCC _first middle _last) = middle + +-- | A CmmSwitch scrutinee may have any width, but a br_table operand +-- must be exactly word sized, hence the extension here. (#22871) +smartExtend :: Platform -> CmmExpr -> CmmExpr +smartExtend p e | w0 == w1 = e + | otherwise = CmmMachOp (MO_UU_Conv w0 w1) [e] + where + w0 = cmmExprWidth p e + w1 = wordWidth p + +smartPlus :: Platform -> CmmExpr -> Int -> CmmExpr +smartPlus _ e 0 = e +smartPlus platform e k = + 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 consx = mapAlter add + where add Nothing = Just (consx []) + add (Just xs) = Just (consx xs) + +------------------------------------------------------------------ +--- everything below here is for diagnostics in case of panic + +instance Outputable ContainingSyntax where + ppr (BlockFollowedBy l) = text "node" <+> ppr l + ppr (LoopHeadedBy l) = text "loop" <+> ppr l + ppr (IfThenElse l) = text "if-then-else" <+> ppr l + +findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a +findLabelIn lbl = mapFindWithDefault failed lbl + where failed = + pprPanic "label not found in control-flow graph" (ppr lbl) + + +infixl 4 <$~> +(<$~>) :: Functor m => m (a -> b) -> a -> m b +(<$~>) f x = fmap ($ x) f + +(<<>>) :: forall m s e pre mid post + . Applicative m + => m (WasmControl s e pre mid) + -> m (WasmControl s e mid post) + -> m (WasmControl s e pre post) +(<<>>) = liftA2 (<>) diff --git a/Language/Haskell/Syntax.hs b/Language/Haskell/Syntax.hs --- a/Language/Haskell/Syntax.hs +++ b/Language/Haskell/Syntax.hs @@ -20,20 +20,29 @@ module Language.Haskell.Syntax.Binds, module Language.Haskell.Syntax.Decls, module Language.Haskell.Syntax.Expr, + module Language.Haskell.Syntax.ImpExp, module Language.Haskell.Syntax.Lit, + 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 import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Expr +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 +import Data.Maybe (Maybe) + {- Note [Language.Haskell.Syntax.* Hierarchy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -55,5 +64,42 @@ https://gitlab.haskell.org/ghc/ghc/-/wikis/implementing-trees-that-grow -} +-- | Haskell Module +-- +-- 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. --- TODO Add TTG parameter to 'HsModule' and move here. + -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation + HsModule { + hsmodExt :: XCModule p, + -- ^ HsModule extension point + hsmodName :: Maybe (XRec p ModuleName), + -- ^ @Nothing@: \"module X where\" is omitted (in which case the next + -- field is Nothing too) + hsmodExports :: Maybe (XRec p [LIE p]), + -- ^ Export list + -- + -- - @Nothing@: export list omitted, so export everything + -- + -- - @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 new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Basic.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +module Language.Haskell.Syntax.Basic where + +import Data.Data +import Data.Eq +import Data.Ord +import Data.Bool +import Data.Int (Int) + +import GHC.Data.FastString (FastString) +import Control.DeepSeq + +{- +************************************************************************ +* * +Boxity +* * +************************************************************************ +-} + +data Boxity + = Boxed + | Unboxed + deriving( Eq, Data ) + +isBoxed :: Boxity -> Bool +isBoxed Boxed = True +isBoxed Unboxed = False + +{- +************************************************************************ +* * +Counts and indices +* * +************************************************************************ +-} + +-- | The width of an unboxed sum +type SumWidth = Int + +-- | A *one-index* constructor tag +-- +-- Type of the tags associated with each constructor possibility or superclass +-- selector +type ConTag = Int + +{- +************************************************************************ +* * +Field Labels +* * +************************************************************************ +-} + +-- | Field labels are just represented as strings; +-- they are not necessarily unique (even within a module) +newtype FieldLabelString = FieldLabelString { field_label:: FastString } + deriving (Data, Eq, NFData) + +{- +************************************************************************ +* * +Field Labels +* * +************************************************************************ +-} + +-- | See Note [Roles] in GHC.Core.Coercion +-- +-- Order of constructors matters: the Ord instance coincides with the *super*typing +-- relation on roles. +data Role = Nominal | Representational | Phantom + deriving (Eq, Ord, Data) + +{- +************************************************************************ +* * +Source Strictness and Unpackedness +* * +************************************************************************ +-} + +-- | Source Strictness +-- +-- What strictness annotation the user wrote +data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' + | SrcStrict -- ^ Strict, ie '!' + | NoSrcStrict -- ^ no strictness annotation + deriving (Eq, Data) + +-- | Source Unpackedness +-- +-- What unpackedness the user requested +data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified + | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified + | NoSrcUnpack -- ^ no unpack pragma + deriving (Eq, Data) 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 @@ -21,8 +21,6 @@ -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax.Binds where -import GHC.Prelude - import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( LHsExpr , MatchGroup @@ -32,19 +30,17 @@ import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type -import GHC.Types.Name.Reader(RdrName) -import GHC.Types.Basic -import GHC.Types.SourceText -import GHC.Types.Tickish -import GHC.Types.Var -import GHC.Types.Fixity -import GHC.Data.Bag -import GHC.Data.BooleanFormula (LBooleanFormula) -import GHC.Utils.Outputable -import GHC.Utils.Panic (pprPanic) +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 {- ************************************************************************ @@ -203,9 +199,8 @@ fun_id :: LIdP idL, -- Note [fun_id in Match] in GHC.Hs.Expr - fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload + fun_matches :: MatchGroup idR (LHsExpr idR) -- ^ The payload - fun_tick :: [CoreTickish] -- ^ Ticks to put on the rhs, if any } -- | Pattern Binding @@ -224,10 +219,7 @@ | PatBind { pat_ext :: XPatBind idL idR, pat_lhs :: LPat idL, - pat_rhs :: GRHSs idR (LHsExpr idR), - pat_ticks :: ([CoreTickish], [[CoreTickish]]) - -- ^ Ticks to put on the rhs, if any, and ticks to put on - -- the bound variables. + pat_rhs :: GRHSs idR (LHsExpr idR) } -- | Variable Binding @@ -372,13 +364,6 @@ -- 'GHC.Parser.Annotation.AnnDcolon' | ClassOpSig (XClassOpSig pass) Bool [LIdP pass] (LHsSigType pass) - -- | 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 just like a type - -- signature: there should be an accompanying binding - | IdSig (XIdSig pass) Id - -- | An ordinary fixity declaration -- -- > infixl 8 *** @@ -435,8 +420,7 @@ -- 'GHC.Parser.Annotation.AnnInstance','GHC.Parser.Annotation.AnnClose' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) - -- Note [Pragma source text] in GHC.Types.SourceText + | SpecInstSig (XSpecInstSig pass) (LHsSigType pass) -- | A minimal complete definition pragma -- @@ -447,9 +431,7 @@ -- 'GHC.Parser.Annotation.AnnClose' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | MinimalSig (XMinimalSig pass) - SourceText (LBooleanFormula (LIdP pass)) - -- Note [Pragma source text] in GHC.Types.SourceText + | MinimalSig (XMinimalSig pass) (LBooleanFormula (LIdP pass)) -- | A "set cost centre" pragma for declarations -- @@ -460,7 +442,6 @@ -- > {-# SCC funName "cost_centre_name" #-} | SCCFunSig (XSCCFunSig pass) - SourceText -- Note [Pragma source text] in GHC.Types.SourceText (LIdP pass) -- Function name (Maybe (XRec pass StringLiteral)) -- | A complete match pragma @@ -471,7 +452,6 @@ -- complete matchings which, for example, arise from pattern -- synonym definitions. | CompleteMatchSig (XCompleteMatchSig pass) - SourceText (XRec pass [LIdP pass]) (Maybe (LIdP pass)) | XSig !(XXSig pass) @@ -490,7 +470,7 @@ isTypeLSig :: forall p. UnXRec p => LSig p -> Bool -- Type signatures isTypeLSig (unXRec @p -> TypeSig {}) = True isTypeLSig (unXRec @p -> ClassOpSig {}) = True -isTypeLSig (unXRec @p -> IdSig {}) = True +isTypeLSig (unXRec @p -> XSig {}) = True isTypeLSig _ = False isSpecLSig :: forall p. UnXRec p => LSig p -> Bool @@ -526,36 +506,6 @@ isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True isCompleteMatchSig _ = False -hsSigDoc :: Sig name -> SDoc -hsSigDoc (TypeSig {}) = text "type signature" -hsSigDoc (PatSynSig {}) = text "pattern synonym signature" -hsSigDoc (ClassOpSig _ is_deflt _ _) - | is_deflt = text "default type signature" - | otherwise = text "class method signature" -hsSigDoc (IdSig {}) = text "id signature" -hsSigDoc (SpecSig _ _ _ 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 --- from the InlineSpec field of the pragma. -hsSigDoc (SpecInstSig _ src _) = text (extractSpecPragName src) <+> text "instance pragma" -hsSigDoc (FixSig {}) = text "fixity declaration" -hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" -hsSigDoc (SCCFunSig {}) = text "SCC pragma" -hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" -hsSigDoc (XSig {}) = text "XSIG TTG extension" - --- | Extracts the name for a SPECIALIZE instance pragma. In 'hsSigDoc', the src --- field of 'SpecInstSig' signature contains the SourceText for a SPECIALIZE --- instance pragma of the form: "SourceText {-# SPECIALIZE" --- --- Extraction ensures that all variants of the pragma name (with a 'Z' or an --- 'S') are output exactly as used in the pragma. -extractSpecPragName :: SourceText -> String -extractSpecPragName srcTxt = case (words $ show srcTxt) of - (_:_:pragName:_) -> filter (/= '\"') pragName - _ -> pprPanic "hsSigDoc: Misformed SPECIALISE instance pragma:" (ppr srcTxt) - {- ************************************************************************ * * @@ -605,9 +555,6 @@ making the distinction between the two names clear. -} -instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where - ppr (RecordPatSynField { recordPatSynField = v }) = ppr v - -- | Haskell Pattern Synonym Direction data HsPatSynDir id diff --git a/Language/Haskell/Syntax/Concrete.hs b/Language/Haskell/Syntax/Concrete.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Concrete.hs @@ -0,0 +1,63 @@ +{-# 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 @@ -2,8 +2,10 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -14,12 +16,9 @@ {- (c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +(c) The GRASP/@type@AQUA Project, Glasgow University, 1992-1998 -} - -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} - -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* -- | Abstract syntax of global declarations. @@ -30,23 +29,23 @@ -- * Toplevel declarations HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..), HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys, - NewOrData(..), newOrDataToFlavour, + NewOrData(..), DataDefnCons(..), dataDefnConsNewOrData, + isTypeDataDefnCons, StandaloneKindSig(..), LStandaloneKindSig, -- ** Class or type declarations - TyClDecl(..), LTyClDecl, DataDeclRn(..), + TyClDecl(..), LTyClDecl, TyClGroup(..), tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, tyClGroupKindSigs, isClassDecl, isDataDecl, isSynDecl, isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, - countTyClDecls, tyClDeclTyVars, FamilyDecl(..), LFamilyDecl, -- ** Instance declarations - InstDecl(..), LInstDecl, FamilyInfo(..), pprFlavour, + InstDecl(..), LInstDecl, FamilyInfo(..), TyFamInstDecl(..), LTyFamInstDecl, TyFamDefltDecl, LTyFamDefltDecl, DataFamInstDecl(..), LDataFamInstDecl, @@ -57,16 +56,14 @@ DerivDecl(..), LDerivDecl, -- ** Deriving strategies DerivStrategy(..), LDerivStrategy, - derivStrategyName, -- ** @RULE@ declarations - LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..), + LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl, RuleBndr(..),LRuleBndr, collectRuleBndrSigTys, - pprFullRuleName, -- ** @default@ declarations DefaultDecl(..), LDefaultDecl, -- ** Template haskell declaration splice - SpliceExplicitFlag(..), + SpliceDecoration(..), SpliceDecl(..), LSpliceDecl, -- ** Foreign function interface declarations ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), @@ -92,33 +89,39 @@ ) where -- friends: -import GHC.Prelude - import {-# SOURCE #-} Language.Haskell.Syntax.Expr - ( HsExpr, HsSplice ) + ( HsExpr, HsUntypedSplice ) -- Because Expr imports Decls via HsBracket import Language.Haskell.Syntax.Binds -import Language.Haskell.Syntax.Type -import GHC.Hs.Doc -import GHC.Core.TyCon -import GHC.Types.Basic -import GHC.Types.ForeignCall +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension -import GHC.Types.Name.Set -import GHC.Types.Fixity +import Language.Haskell.Syntax.Type +import Language.Haskell.Syntax.Basic (Role) --- others: -import GHC.Utils.Outputable -import GHC.Utils.Misc -import GHC.Types.SrcLoc -import GHC.Types.SourceText -import GHC.Core.Type -import GHC.Unit.Module.Warnings +import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation) +import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) +import GHC.Types.Fixity (LexicalFixity) -import GHC.Data.Maybe -import Data.Data hiding (TyCon,Fixity, Infix) +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 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 (..)) {- ************************************************************************ @@ -245,10 +248,18 @@ data SpliceDecl p = SpliceDecl -- Top level splice (XSpliceDecl p) - (XRec p (HsSplice p)) - SpliceExplicitFlag + (XRec p (HsUntypedSplice p)) + SpliceDecoration -- Whether $( ) variant found, for pretty printing | XSpliceDecl !(XXSpliceDecl p) +-- | A splice can appear with various decorations wrapped around it. This data +-- type captures explicitly how it was originally written, for use in the pretty +-- printer. +data SpliceDecoration + = DollarSplice -- ^ $splice + | BareSplice -- ^ bare splice + deriving (Data, Eq, Show) + {- ************************************************************************ * * @@ -412,7 +423,7 @@ -- 'GHC.Parser.Annotation.AnnEqual', -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs + SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renamer, FVs , tcdLName :: LIdP pass -- ^ Type constructor , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an -- associated type these @@ -444,6 +455,8 @@ -- '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 @@ -465,12 +478,6 @@ type LHsFunDep pass = XRec pass (FunDep pass) -data DataDeclRn = DataDeclRn - { tcdDataCusk :: Bool -- ^ does this have a CUSK? - -- See Note [CUSKs: complete user-supplied kind signatures] - , tcdFVs :: NameSet } - deriving Data - {- Note [TyVar binders for associated decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For an /associated/ data, newtype, or type-family decl, the LHsQTyVars @@ -564,22 +571,7 @@ 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 - = (count isClassDecl decls, - count isSynDecl decls, -- excluding... - count isDataTy decls, -- ...family... - count isNewTy decls, -- ...instances - count isFamilyDecl decls) - where - isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True - isDataTy _ = False - isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True - isNewTy _ = False - - {- Note [CUSKs: complete user-supplied kind signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We kind-check declarations differently if they have a complete, user-supplied @@ -599,7 +591,7 @@ Examples: * data T1 (a :: *->*) (b :: *) = .... - -- Has CUSK; equivalant to T1 :: (*->*) -> * -> * + -- Has CUSK; equivalent to T1 :: (*->*) -> * -> * * data T2 a b = ... -- No CUSK; we do not want to guess T2 :: * -> * -> * @@ -710,16 +702,16 @@ tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass] -tyClGroupTyClDecls = concatMap group_tyclds +tyClGroupTyClDecls = Data.List.concatMap group_tyclds tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass] -tyClGroupInstDecls = concatMap group_instds +tyClGroupInstDecls = Data.List.concatMap group_instds tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass] -tyClGroupRoleDecls = concatMap group_roles +tyClGroupRoleDecls = Data.List.concatMap group_roles tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass] -tyClGroupKindSigs = concatMap group_kisigs +tyClGroupKindSigs = Data.List.concatMap group_kisigs {- ********************************************************************* @@ -871,18 +863,6 @@ | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) -------------- Pretty printing FamilyDecls ----------- - -pprFlavour :: FamilyInfo pass -> SDoc -pprFlavour DataFamily = text "data" -pprFlavour OpenTypeFamily = text "type" -pprFlavour (ClosedTypeFamily {}) = text "type" - -instance Outputable (FamilyInfo pass) where - ppr info = pprFlavour info <+> text "family" - - - {- ********************************************************************* * * Data types and data constructors @@ -899,7 +879,6 @@ -- data/newtype instance T [a] = -- @ HsDataDefn { dd_ext :: XCHsDataDefn pass, - dd_ND :: NewOrData, dd_ctxt :: Maybe (LHsContext pass), -- ^ Context dd_cType :: Maybe (XRec pass CType), dd_kindSig:: Maybe (LHsKind pass), @@ -910,7 +889,7 @@ -- -- Always @Nothing@ for H98-syntax decls - dd_cons :: [LConDecl pass], + dd_cons :: DataDefnCons (LConDecl pass), -- ^ Data constructors -- -- For @data T a = T1 | T2 a@ @@ -1007,17 +986,35 @@ 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 + deriving ( Eq, Data ) -- Needed because Demand derives Eq --- | Convert a 'NewOrData' to a 'TyConFlavour' -newOrDataToFlavour :: NewOrData -> TyConFlavour -newOrDataToFlavour NewType = NewtypeFlavour -newOrDataToFlavour DataType = DataTypeFlavour +-- | Whether a data-type declaration is @data@ or @newtype@, and its constructors. +data DataDefnCons a + = NewTypeCon -- @newtype N x = MkN blah@ + a -- Info about the single data constructor @MkN@ + | DataTypeCons + Bool -- True <=> type data T x = ... + -- See Note [Type data declarations] in GHC.Rename.Module + -- False <=> data T x = ... + [a] -- The (possibly empty) list of data constructors + deriving ( Eq, Data, Foldable, Functor, Traversable ) -- Needed because Demand derives Eq +dataDefnConsNewOrData :: DataDefnCons a -> NewOrData +dataDefnConsNewOrData = \ case + NewTypeCon _ -> NewType + DataTypeCons _ _ -> DataType + +-- | Are the constructors within a @type data@ declaration? +-- See Note [Type data declarations] in GHC.Rename.Module. +isTypeDataDefnCons :: DataDefnCons a -> Bool +isTypeDataDefnCons (NewTypeCon _) = False +isTypeDataDefnCons (DataTypeCons is_type_data _) = is_type_data + -- | Located data Constructor Declaration type LConDecl pass = XRec pass (ConDecl pass) -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when @@ -1053,8 +1050,8 @@ data ConDecl pass = ConDeclGADT { con_g_ext :: XConDeclGADT pass - , con_names :: [LIdP 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) @@ -1218,10 +1215,6 @@ = PrefixConGADT [HsScaled pass (LBangType pass)] | RecConGADT (XRec pass [LConDeclField pass]) (LHsUniToken "->" "→" pass) -instance Outputable NewOrData where - ppr NewType = text "newtype" - ppr DataType = text "data" - {- ************************************************************************ * * @@ -1469,14 +1462,6 @@ | ViaStrategy (XViaStrategy pass) -- ^ @-XDerivingVia@ --- | A short description of a @DerivStrategy'@. -derivStrategyName :: DerivStrategy a -> SDoc -derivStrategyName = text . go - where - go StockStrategy {} = "stock" - go AnyclassStrategy {} = "anyclass" - go NewtypeStrategy {} = "newtype" - go ViaStrategy {} = "via" {- ************************************************************************ @@ -1525,13 +1510,13 @@ { fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty , fd_name :: LIdP pass -- defines this name , fd_sig_ty :: LHsSigType pass -- sig_ty - , fd_fi :: ForeignImport } + , fd_fi :: ForeignImport pass } | ForeignExport { fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty , fd_name :: LIdP pass -- uses this name , fd_sig_ty :: LHsSigType pass -- sig_ty - , fd_fe :: ForeignExport } + , fd_fe :: ForeignExport pass } -- ^ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForeign', -- 'GHC.Parser.Annotation.AnnImport','GHC.Parser.Annotation.AnnExport', @@ -1552,27 +1537,26 @@ -- Specification Of an imported external entity in dependence on the calling -- convention -- -data ForeignImport = -- import of a C entity - -- - -- * the two strings specifying a header file or library - -- may be empty, which indicates the absence of a - -- header or object specification (both are not used - -- in the case of `CWrapper' and when `CFunction' - -- has a dynamic target) - -- - -- * the calling convention is irrelevant for code - -- generation in the case of `CLabel', but is needed - -- for pretty printing - -- - -- * `Safety' is irrelevant for `CLabel' and `CWrapper' - -- - CImport (Located CCallConv) -- ccall or stdcall - (Located Safety) -- interruptible, safe or unsafe - (Maybe Header) -- name of C header - CImportSpec -- details of the C entity - (Located SourceText) -- original source text for - -- the C entity - deriving Data +data ForeignImport pass = -- import of a C entity + -- + -- * the two strings specifying a header file or library + -- may be empty, which indicates the absence of a + -- header or object specification (both are not used + -- in the case of `CWrapper' and when `CFunction' + -- has a dynamic target) + -- + -- * the calling convention is irrelevant for code + -- generation in the case of `CLabel', but is needed + -- for pretty printing + -- + -- * `Safety' is irrelevant for `CLabel' and `CWrapper' + -- + CImport (XCImport pass) + (XRec pass CCallConv) -- ccall or stdcall + (XRec pass Safety) -- interruptible, safe or unsafe + (Maybe Header) -- name of C header + CImportSpec -- details of the C entity + | XForeignImport !(XXForeignImport pass) -- details of an external C entity -- @@ -1585,47 +1569,10 @@ -- specification of an externally exported entity in dependence on the calling -- convention -- -data ForeignExport = CExport (Located CExportSpec) -- contains the calling - -- convention - (Located SourceText) -- original source text for - -- the C entity - deriving Data +data ForeignExport pass = CExport (XCExport pass) (XRec pass CExportSpec) -- contains the calling convention + | XForeignExport !(XXForeignExport pass) --- pretty printing of foreign declarations --- -instance Outputable ForeignImport where - ppr (CImport cconv safety mHeader spec (L _ srcText)) = - ppr cconv <+> ppr safety - <+> pprWithSourceText srcText (pprCEntity spec "") - where - pp_hdr = case mHeader of - Nothing -> empty - Just (Header _ header) -> ftext header - - pprCEntity (CLabel lbl) _ = - doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl - pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src = - if dqNeeded then doubleQuotes ce else empty - where - dqNeeded = (take 6 src == "static") - || isJust mHeader - || not isFun - || st /= NoSourceText - ce = - -- We may need to drop leading spaces first - (if take 6 src == "static" then text "static" else empty) - <+> pp_hdr - <+> (if isFun then empty else text "value") - <+> (pprWithSourceText st empty) - pprCEntity (CFunction DynamicTarget) _ = - doubleQuotes $ text "dynamic" - pprCEntity CWrapper _ = doubleQuotes $ text "wrapper" - -instance Outputable ForeignExport where - ppr (CExport (L _ (CExportStatic _ lbl cconv)) _) = - ppr cconv <+> char '"' <> ppr lbl <> char '"' - {- ************************************************************************ * * @@ -1637,10 +1584,8 @@ -- | Located Rule Declarations type LRuleDecls pass = XRec pass (RuleDecls pass) - -- Note [Pragma source text] in GHC.Types.SourceText -- | Rule Declarations data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass - , rds_src :: SourceText , rds_rules :: [LRuleDecl pass] } | XRuleDecls !(XXRuleDecls pass) @@ -1652,7 +1597,7 @@ = HsRule -- Source rule { rd_ext :: XHsRule pass -- ^ After renamer, free-vars from the LHS and RHS - , rd_name :: XRec pass (SourceText,RuleName) + , rd_name :: XRec pass RuleName -- ^ Note [Pragma source text] in "GHC.Types.Basic" , rd_act :: Activation , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)] @@ -1672,9 +1617,6 @@ -- 'GHC.Parser.Annotation.AnnEqual', | XRuleDecl !(XXRuleDecl pass) -data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS - deriving Data - -- | Located Rule Binder type LRuleBndr pass = XRec pass (RuleBndr pass) @@ -1692,9 +1634,6 @@ collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] -pprFullRuleName :: GenLocated a (SourceText, RuleName) -> SDoc -pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) - {- ************************************************************************ * * @@ -1715,10 +1654,6 @@ deriving instance (Data pass, Data (IdP pass)) => Data (DocDecl pass) --- Okay, I need to reconstruct the document comments, but for now: -instance Outputable (DocDecl name) where - ppr _ = text "" - docDeclDoc :: DocDecl pass -> LHsDoc pass docDeclDoc (DocCommentNext d) = d docDeclDoc (DocCommentPrev d) = d @@ -1738,10 +1673,8 @@ -- | Located Warning Declarations type LWarnDecls pass = XRec pass (WarnDecls pass) - -- Note [Pragma source text] in GHC.Types.SourceText -- | Warning pragma Declarations data WarnDecls pass = Warnings { wd_ext :: XWarnings pass - , wd_src :: SourceText , wd_warnings :: [LWarnDecl pass] } | XWarnDecls !(XXWarnDecls pass) @@ -1768,7 +1701,6 @@ -- | Annotation Declaration data AnnDecl pass = HsAnnotation (XHsAnnotation pass) - SourceText -- Note [Pragma source text] in GHC.Types.SourceText (AnnProvenance pass) (XRec pass (HsExpr pass)) -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', -- 'GHC.Parser.Annotation.AnnType' 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 @@ -6,13 +6,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -23,37 +20,30 @@ -- | Abstract Haskell syntax for expressions. module Language.Haskell.Syntax.Expr where -import GHC.Prelude - +import Language.Haskell.Syntax.Basic 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.Type import Language.Haskell.Syntax.Binds -- others: -import GHC.Core.DataCon (FieldLabelString) -import GHC.Types.Name -import GHC.Types.Basic -import GHC.Types.Fixity -import GHC.Types.Name.Reader -import GHC.Types.SourceText -import GHC.Types.SrcLoc +import GHC.Types.Fixity (LexicalFixity(Infix), Fixity) +import GHC.Types.SourceText (StringLiteral, SourceText) + import GHC.Unit.Module (ModuleName) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Data.FastString -import GHC.Core.Type +import GHC.Data.FastString (FastString) -- libraries: import Data.Data hiding (Fixity(..)) -import qualified Data.Data as Data (Fixity(..)) - +import Data.Bool +import Data.Either +import Data.Eq +import Data.Maybe import Data.List.NonEmpty ( NonEmpty ) - -import GHCi.RemoteTypes ( ForeignRef ) -import qualified Language.Haskell.TH as TH (Q) +import GHC.Types.Name.Reader {- Note [RecordDotSyntax field updates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -107,7 +97,7 @@ @ The @fbind@ rule is then given the type @fbind :: { forall b. -DisambECP b => PV (Fbind b) }@ accomodating both alternatives: +DisambECP b => PV (Fbind b) }@ accommodating both alternatives: @ type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) @@ -144,38 +134,6 @@ newtype FieldLabelStrings p = FieldLabelStrings [XRec p (DotFieldOcc p)] -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)) - -pprPrefixFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) - => FieldLabelStrings p -> SDoc -pprPrefixFieldLabelStrings (FieldLabelStrings flds) = - hcat (punctuate dot (map (pprPrefixFieldLabelString . unXRec @p) flds)) - -pprPrefixFieldLabelString :: forall p. UnXRec p => DotFieldOcc p -> SDoc -pprPrefixFieldLabelString (DotFieldOcc _ s) = (pprPrefixFastString . unXRec @p) s -pprPrefixFieldLabelString XDotFieldOcc{} = text "XDotFieldOcc" - -pprPrefixFastString :: FastString -> SDoc -pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs) - -instance UnXRec p => Outputable (DotFieldOcc p) where - ppr (DotFieldOcc _ s) = (pprPrefixFastString . unXRec @p) s - ppr XDotFieldOcc{} = text "XDotFieldOcc" - -- Field projection updates (e.g. @foo.bar.baz = 1@). See Note -- [RecordDotSyntax field updates]. type RecProj p arg = HsFieldBind (LFieldLabelStrings p) arg @@ -241,47 +199,7 @@ -- etc type family SyntaxExpr p --- | 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.) --} - -{- Note [Record selectors in the AST] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is how record selectors are expressed in GHC's AST: @@ -337,7 +255,7 @@ -- See Note [Located RdrNames] | HsUnboundVar (XUnboundVar p) - OccName -- ^ Unbound variable; also used for "holes" + RdrName -- ^ Unbound variable; also used for "holes" -- (_ or _x). -- Turned from HsVar to HsUnboundVar by the -- renamer, when it finds an out-of-scope @@ -353,8 +271,9 @@ -- See Note [Non-overloaded record field selectors] and -- Note [Record selectors in the AST] - | HsOverLabel (XOverLabel p) FastString + | HsOverLabel (XOverLabel p) SourceText 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) @@ -389,6 +308,7 @@ | 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 @@ -454,8 +374,8 @@ -- the expression, (arity - alternative) after it | ExplicitSum (XExplicitSum p) - ConTag -- Alternative (one-based) - Arity -- Sum arity + ConTag -- Alternative (one-based) + SumWidth -- Sum arity (LHsExpr p) -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase', @@ -617,7 +537,8 @@ -- 'GHC.Parser.Annotation.AnnClose' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsSpliceE (XSpliceE p) (HsSplice p) + | HsTypedSplice (XTypedSplice p) (LHsExpr p) -- `$$z` or `$$(f 4)` + | HsUntypedSplice (XUntypedSplice p) (HsUntypedSplice p) ----------------------------------------------------------- -- Arrow notation extension @@ -664,7 +585,6 @@ -- | A pragma, written as {-# ... #-}, that may appear within an expression. data HsPragE p = HsPragSCC (XSCC p) - SourceText -- Note [Pragma source text] in GHC.Types.SourceText StringLiteral -- "set cost centre" SCC pragma -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', @@ -702,10 +622,6 @@ | LamCases -- ^ `\cases` deriving (Data, Eq) -lamCaseKeyword :: LamCaseVariant -> SDoc -lamCaseKeyword LamCase = text "\\case" -lamCaseKeyword LamCases = text "\\cases" - {- Note [Parens in HsSyn] ~~~~~~~~~~~~~~~~~~~~~~ @@ -850,11 +766,6 @@ -} ------------------------ -pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc -pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4)) - = ppr (src,(n1,n2),(n3,n4)) - {- HsSyn records exactly where the user put parens, with HsPar. So generally speaking we print without adding any parens. @@ -997,10 +908,6 @@ | HsFirstOrderApp deriving Data -pprHsArrType :: HsArrAppType -> SDoc -pprHsArrType HsHigherOrderApp = text "higher order arrow application" -pprHsArrType HsFirstOrderApp = text "first order arrow application" - {- | Top-level command, introducing a new arrow. This may occur inside a proc (where the stack is empty) or as an argument of a command-forming operator. @@ -1052,20 +959,13 @@ -} data MatchGroup p body - = MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result - , mg_alts :: XRec p [LMatch p body] -- The alternatives - , mg_origin :: Origin } + = MG { mg_ext :: XMG p body -- Post-typechecker, types of args and result, and origin + , mg_alts :: XRec p [LMatch p body] } -- The alternatives -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns | XMatchGroup !(XXMatchGroup p body) -data MatchGroupTc - = MatchGroupTc - { mg_arg_tys :: [Scaled Type] -- Types of the arguments, t1..tn - , mg_res_ty :: Type -- Type of the result, tr - } deriving Data - -- | Located Match type LMatch id body = XRec id (Match id body) -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a @@ -1266,7 +1166,7 @@ (SyntaxExpr idR) -- The `>>=` operator -- See notes [Monad Comprehensions] -- After renaming, the ids are the binders - -- bound by the stmts and used after themp + -- bound by the stmts and used after them | TransStmt { trS_ext :: XTransStmt idL idR body, -- Post typecheck, @@ -1554,84 +1454,38 @@ ************************************************************************ -} --- | Haskell Splice -data HsSplice id - = HsTypedSplice -- $$z or $$(f 4) - (XTypedSplice id) - SpliceDecoration -- Whether $$( ) variant found, for pretty printing - (IdP id) -- A unique name to identify this splice point - (LHsExpr id) -- See Note [Pending Splices] - - | HsUntypedSplice -- $z or $(f 4) - (XUntypedSplice id) - SpliceDecoration -- Whether $( ) variant found, for pretty printing - (IdP id) -- A unique name to identify this splice point - (LHsExpr id) -- See Note [Pending Splices] - - | HsQuasiQuote -- See Note [Quasi-quote overview] in GHC.Tc.Gen.Splice - (XQuasiQuote id) - (IdP id) -- Splice point - (IdP id) -- Quoter - SrcSpan -- The span of the enclosed string - FastString -- The enclosed string - - -- AZ:TODO: use XSplice instead of HsSpliced - | HsSpliced -- 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. - (XSpliced id) - ThModFinalizers -- TH finalizers produced by the splice. - (HsSplicedThing id) -- The result of splicing - | XSplice !(XXSplice id) -- Extension point; see Note [Trees That Grow] - -- in Language.Haskell.Syntax.Extension - --- | A splice can appear with various decorations wrapped around it. This data --- type captures explicitly how it was originally written, for use in the pretty --- printer. -data SpliceDecoration - = DollarSplice -- ^ $splice or $$splice - | BareSplice -- ^ bare splice - deriving (Data, Eq, Show) - -instance Outputable SpliceDecoration where - ppr x = text $ show x - - -isTypedSplice :: HsSplice id -> Bool -isTypedSplice (HsTypedSplice {}) = True -isTypedSplice _ = False -- Quasi-quotes are untyped splices +{- +Note [Quasi-quote overview] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "quasi-quote" extension is described by Geoff Mainland's paper +"Why it's nice to be quoted: quasiquoting for Haskell" (Haskell +Workshop 2007). --- | 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 ())] +Briefly, one writes + [p| stuff |] +and the arbitrary string "stuff" gets parsed by the parser 'p', whose type +should be Language.Haskell.TH.Quote.QuasiQuoter. 'p' must be defined in +another module, because we are going to run it here. It's a bit like an +/untyped/ TH splice where the parser is applied the "stuff" as a string, thus: + $(p "stuff") --- 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] +Notice that it's an /untyped/ TH splice: it can occur in patterns and types, as well +as in expressions; and it runs in the renamer. +-} --- | Haskell Spliced Thing --- --- Values that can result from running a splice. -data HsSplicedThing id - = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression - | HsSplicedTy (HsType id) -- ^ Haskell Spliced Type - | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern +-- | Haskell Splice +data HsUntypedSplice id + = HsUntypedSpliceExpr -- $z or $(f 4) + (XUntypedSpliceExpr id) + (LHsExpr id) + | HsQuasiQuote -- See Note [Quasi-quote overview] + (XQuasiQuote id) + (IdP id) -- The quoter (the bit between `[` and `|`) + (XRec id FastString) -- The enclosed string -data UntypedSpliceFlavour - = UntypedExpSplice - | UntypedPatSplice - | UntypedTypeSplice - | UntypedDeclSplice - deriving Data + | XUntypedSplice !(XXUntypedSplice id) -- Extension point; see Note [Trees That Grow] + -- in Language.Haskell.Syntax.Extension -- | Haskell (Untyped) Quote = Expr + Pat + Type + Var data HsQuote p @@ -1802,114 +1656,3 @@ isMonadDoCompContext GhciStmtCtxt = False isMonadDoCompContext (DoExpr _) = False isMonadDoCompContext (MDoExpr _) = False - -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) - -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 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 @@ -12,9 +12,9 @@ type role HsExpr nominal type role MatchGroup nominal nominal type role GRHSs nominal nominal -type role HsSplice nominal +type role HsUntypedSplice nominal data HsExpr (i :: Type) -data HsSplice (i :: Type) +data HsUntypedSplice (i :: Type) data MatchGroup (a :: Type) (body :: Type) data GRHSs (a :: Type) (body :: Type) type family SyntaxExpr (i :: Type) 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,10 +1,10 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -- for unXRec, etc. +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -21,13 +21,16 @@ -- This module captures the type families to precisely identify the extension -- points for GHC.Hs syntax -import GHC.Prelude +#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) +import Data.Type.Equality (type (~)) +#endif -import GHC.TypeLits (Symbol, KnownSymbol) import Data.Data hiding ( Fixity ) import Data.Kind (Type) -import GHC.Utils.Outputable +import Data.Eq +import Data.Ord + {- Note [Trees That Grow] ~~~~~~~~~~~~~~~~~~~~~~ @@ -73,9 +76,6 @@ data NoExtField = NoExtField deriving (Data,Eq,Ord) -instance Outputable NoExtField where - ppr _ = text "NoExtField" - -- | Used when constructing a term with an unused extension point. noExtField :: NoExtField noExtField = NoExtField @@ -111,9 +111,6 @@ data DataConCantHappen deriving (Data,Eq,Ord) -instance Outputable DataConCantHappen where - ppr = dataConCantHappen - -- | Eliminate a 'DataConCantHappen'. See Note [Constructor cannot occur]. dataConCantHappen :: DataConCantHappen -> a dataConCantHappen x = case x of {} @@ -354,6 +351,10 @@ type family XForeignImport x type family XForeignExport x type family XXForeignDecl x +type family XCImport x +type family XXForeignImport x +type family XCExport x +type family XXForeignExport x -- ------------------------------------- -- RuleDecls type families @@ -397,6 +398,12 @@ type family XXInjectivityAnn x -- ===================================================================== +-- Type families for the HsModule extension points + +type family XCModule x +type family XXModule x + +-- ===================================================================== -- Type families for the HsExpr extension points type family XVar x @@ -431,7 +438,8 @@ type family XArithSeq x type family XTypedBracket x type family XUntypedBracket x -type family XSpliceE x +type family XTypedSplice x +type family XUntypedSplice x type family XProc x type family XStatic x type family XTick x @@ -463,12 +471,10 @@ type family XXTupArg x -- ------------------------------------- --- HsSplice type families -type family XTypedSplice x -type family XUntypedSplice x -type family XQuasiQuote x -type family XSpliced x -type family XXSplice x +-- HsUntypedSplice type families +type family XUntypedSpliceExpr x +type family XQuasiQuote x +type family XXUntypedSplice x -- ------------------------------------- -- HsQuoteBracket type families @@ -653,6 +659,13 @@ type family XXType x -- --------------------------------------------------------------------- +-- HsTyLit type families +type family XNumTy x +type family XStrTy x +type family XCharTy x +type family XXTyLit x + +-- --------------------------------------------------------------------- -- HsForAllTelescope type families type family XHsForAllVis x type family XHsForAllInvis x @@ -681,6 +694,7 @@ -- ImportDecl type families type family XCImportDecl x type family XXImportDecl x +type family ImportDeclPkgQual x -- stores the package qualifier in an import statement -- ------------------------------------- -- IE type families @@ -695,7 +709,14 @@ type family XXIE x -- ------------------------------------- +-- IEWrappedName type families +type family XIEName p +type family XIEPattern p +type family XIEType p +type family XXIEWrappedName p + + -- ===================================================================== -- Misc @@ -707,27 +728,3 @@ -- ===================================================================== -- End of Type family definitions -- ===================================================================== - - - --- ===================================================================== --- Token information - -type LHsToken tok p = XRec p (HsToken tok) - -data HsToken (tok :: Symbol) = HsTok - -deriving instance KnownSymbol tok => Data (HsToken tok) - -type LHsUniToken tok utok p = XRec p (HsUniToken tok utok) - --- 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, KnownSymbol utok) => Data (HsUniToken tok utok) diff --git a/Language/Haskell/Syntax/ImpExp.hs b/Language/Haskell/Syntax/ImpExp.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/ImpExp.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Language.Haskell.Syntax.ImpExp where + +import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Module.Name + +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 and export declaration lists +* * +************************************************************************ + +One per import declaration in a module. +-} + +-- | 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. + | QualifiedPost -- ^ 'qualified' appears in postpositive position. + | 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) + +-- | Import Declaration +-- +-- A single Haskell @import@ declaration. +data ImportDecl pass + = ImportDecl { + ideclExt :: XCImportDecl pass, + ideclName :: XRec pass ModuleName, -- ^ Module name. + ideclPkgQual :: ImportDeclPkgQual pass, -- ^ Package qualifier. + ideclSource :: IsBootInterface, -- ^ IsBoot <=> {-\# SOURCE \#-} import + ideclSafe :: Bool, -- ^ True => safe import + ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified. + ideclAs :: Maybe (XRec pass ModuleName), -- ^ as Module + ideclImportList :: Maybe (ImportListInterpretation, XRec pass [LIE pass]) + -- ^ 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 +-- used, and therefore everything but what was listed should be imported +data ImportListInterpretation = Exactly | EverythingBut + deriving (Eq, Data) + +-- | 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 + +-- | Imported or exported entity. +data IE pass + = IEVar (XIEVar pass) (LIEWrappedName pass) + -- ^ Imported or Exported Variable + + | IEThingAbs (XIEThingAbs pass) (LIEWrappedName pass) + -- ^ Imported or exported Thing with Absent 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' + + -- 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 + -- + -- 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' + + -- 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 + -- + -- 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 + | IEModuleContents (XIEModuleContents pass) (XRec pass ModuleName) + -- ^ Imported or exported module contents + -- + -- (Export Only) + -- + -- - '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 + | XIE !(XXIE pass) + +-- | Wildcard in an import or export sublist, like the @..@ in +-- @import Mod ( T(Mk1, Mk2, ..) )@. +data IEWildcard + = NoIEWildcard -- ^ no wildcard in this list + | IEWildcard Int -- ^ wildcard after the given \# of items in this list + -- The @Int@ is in the range [0..n], where n is the length + -- of the list. + deriving (Eq, Data) + +-- | 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. +data IEWrappedName p + = IEName (XIEName p) (LIdP p) -- ^ no extra + | IEPattern (XIEPattern p) (LIdP p) -- ^ pattern X + | IEType (XIEType p) (LIdP p) -- ^ type (:+:) + | 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 new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/ImpExp.hs-boot @@ -0,0 +1,16 @@ +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/Lit.hs b/Language/Haskell/Syntax/Lit.hs --- a/Language/Haskell/Syntax/Lit.hs +++ b/Language/Haskell/Syntax/Lit.hs @@ -18,18 +18,21 @@ -- | Source-language literals module Language.Haskell.Syntax.Lit where -import GHC.Prelude - -import GHC.Types.Basic (PprPrec(..), topPrec ) -import GHC.Types.SourceText -import GHC.Core.Type -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Data.FastString 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.Data.FastString (FastString, lexicalCompareFS) + import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) +import Data.Bool +import Data.Ord +import Data.Eq +import Data.Char +import Prelude (Integer) {- ************************************************************************ @@ -147,38 +150,3 @@ compare (HsIsString _ _) (HsIntegral _) = GT compare (HsIsString _ _) (HsFractional _) = GT -instance Outputable OverLitVal where - ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) - ppr (HsFractional f) = ppr f - ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) - --- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs --- to be parenthesized under precedence @p@. -hsLitNeedsParens :: PprPrec -> HsLit x -> Bool -hsLitNeedsParens p = go - where - go (HsChar {}) = False - go (HsCharPrim {}) = False - go (HsString {}) = False - go (HsStringPrim {}) = False - go (HsInt _ x) = p > topPrec && il_neg x - go (HsIntPrim _ x) = p > topPrec && x < 0 - go (HsWordPrim {}) = False - go (HsInt64Prim _ x) = p > topPrec && x < 0 - go (HsWord64Prim {}) = False - go (HsInteger _ x _) = p > topPrec && x < 0 - go (HsRat _ x _) = p > topPrec && fl_neg x - go (HsFloatPrim _ x) = p > topPrec && fl_neg x - go (HsDoublePrim _ x) = p > topPrec && fl_neg x - go (XLit _) = False - --- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal --- @ol@ needs to be parenthesized under precedence @p@. -hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool -hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv - where - go :: OverLitVal -> Bool - go (HsIntegral x) = p > topPrec && il_neg x - go (HsFractional x) = p > topPrec && fl_neg x - go (HsIsString {}) = False -hsOverLitNeedsParens _ (XOverLit { }) = False diff --git a/Language/Haskell/Syntax/Module/Name.hs b/Language/Haskell/Syntax/Module/Name.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Module/Name.hs @@ -0,0 +1,60 @@ +module Language.Haskell.Syntax.Module.Name where + +import Prelude + +import Data.Data +import Data.Char (isAlphaNum) +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" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ModuleName" + +instance NFData ModuleName where + rnf x = x `seq` () + +stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering +-- ^ Compares module names lexically, rather than by their 'Unique's +stableModuleNameCmp n1 n2 = moduleNameFS n1 `lexicalCompareFS` moduleNameFS n2 + +moduleNameFS :: ModuleName -> FastString +moduleNameFS (ModuleName mod) = mod + +moduleNameString :: ModuleName -> String +moduleNameString (ModuleName mod) = unpackFS mod + +mkModuleName :: String -> ModuleName +mkModuleName s = ModuleName (mkFastString s) + +mkModuleNameFS :: FastString -> ModuleName +mkModuleNameFS s = ModuleName s + +-- |Returns the string version of the module name, with dots replaced by slashes. +-- +moduleNameSlashes :: ModuleName -> String +moduleNameSlashes = dots_to_slashes . moduleNameString + where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) + +-- |Returns the string version of the module name, with dots replaced by colons. +-- +moduleNameColons :: ModuleName -> String +moduleNameColons = dots_to_colons . moduleNameString + where dots_to_colons = map (\c -> if c == '.' then ':' else c) + +parseModuleName :: Parse.ReadP ModuleName +parseModuleName = fmap mkModuleName + $ 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 @@ -1,4 +1,5 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,7 +9,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} {- (c) The University of Glasgow 2006 @@ -23,26 +23,35 @@ ConLikeP, HsConPatDetails, hsConPatArgs, + HsConPatTyArg(..), HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, + RecFieldsDotDot(..), hsRecFields, hsRecFieldSel, hsRecFieldsArgs, ) where -import GHC.Prelude - -import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsSplice) +import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsUntypedSplice) -- 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 -import GHC.Types.Basic --- others: -import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) -import GHC.Utils.Outputable -import GHC.Types.SrcLoc + -- libraries: +import Data.Maybe +import Data.Functor +import Data.Foldable +import Data.Traversable +import Data.Bool +import Data.Data +import Data.Eq +import Data.Ord +import Data.Int +import Data.Function +import qualified Data.List type LPat p = XRec p (Pat p) @@ -69,7 +78,9 @@ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | AsPat (XAsPat p) - (LIdP p) (LPat p) -- ^ As pattern + (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 @@ -129,7 +140,7 @@ | SumPat (XSumPat p) -- after typechecker, types of the alternative (LPat p) -- Sum sub-pattern ConTag -- Alternative (one-based) - Arity -- Arity (INVARIANT: ≥ 2) + SumWidth -- Arity (INVARIANT: ≥ 2) -- ^ Anonymous sum pattern -- -- - 'GHC.Parser.Annotation.AnnKeywordId' : @@ -161,7 +172,7 @@ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | SplicePat (XSplicePat p) - (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) + (HsUntypedSplice p) -- ^ Splice Pattern (Includes quasi-quotes) ------------ Literal and n+k patterns --------------- | LitPat (XLitPat p) @@ -217,13 +228,19 @@ -- --------------------------------------------------------------------- +-- | Type argument in a data constructor pattern, +-- e.g. the @\@a@ in @f (Just \@a x) = ...@. +data HsConPatTyArg p = + HsConPatTyArg + !(LHsToken "@" p) + (HsPatSigType p) -- | Haskell Constructor Pattern Details -type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p)) +type HsConPatDetails p = HsConDetails (HsConPatTyArg (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p)) hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p] hsConPatArgs (PrefixCon _ ps) = ps -hsConPatArgs (RecCon fs) = map (hfbRHS . unXRec @p) (rec_flds fs) +hsConPatArgs (RecCon fs) = Data.List.map (hfbRHS . unXRec @p) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] -- | Haskell Record Fields @@ -234,10 +251,13 @@ -- { x = 3, y = True } -- Used for both expressions and patterns = HsRecFields { rec_flds :: [LHsRecField p arg], - rec_dotdot :: Maybe (Located Int) } -- Note [DotDot fields] + rec_dotdot :: Maybe (XRec p RecFieldsDotDot) } -- Note [DotDot fields] -- AZ:The XRec for LHsRecField makes the derivings fail. -- deriving (Functor, Foldable, Traversable) +-- | 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) -- Note [DotDot fields] -- ~~~~~~~~~~~~~~~~~~~~ @@ -336,34 +356,11 @@ -- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Head. hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [XCFieldOcc p] -hsRecFields rbinds = map (hsRecFieldSel . unXRec @p) (rec_flds rbinds) +hsRecFields rbinds = Data.List.map (hsRecFieldSel . unXRec @p) (rec_flds rbinds) hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg] -hsRecFieldsArgs rbinds = map (hfbRHS . unXRec @p) (rec_flds rbinds) +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 - -{- -************************************************************************ -* * -* Printing patterns -* * -************************************************************************ --} - -instance (Outputable arg, Outputable (XRec p (HsRecField p arg))) - => Outputable (HsRecFields p arg) where - ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) - = braces (fsep (punctuate comma (map ppr flds))) - ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) }) - = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) - where - dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) - -instance (Outputable p, OutputableBndr p, Outputable arg) - => Outputable (HsFieldBind p arg) where - ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg, - hfbPun = pun }) - = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg) 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 @@ -6,7 +6,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension @@ -20,28 +19,28 @@ -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax.Type ( - Mult, HsScaled(..), + HsScaled(..), hsMult, hsScaledThing, HsArrow(..), HsLinearArrowTokens(..), - HsType(..), HsCoreTy, LHsType, HsKind, LHsKind, + HsType(..), LHsType, HsKind, LHsKind, HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, HsWildCardBndrs(..), - HsPatSigType(..), HsPSRn(..), + HsPatSigType(..), HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType, HsTupleSort(..), HsContext, LHsContext, HsTyLit(..), HsIPName(..), hsIPNameFS, - HsArg(..), numVisibleArgs, pprHsArgsApp, + HsArg(..), LHsTypeArg, LBangType, BangType, - HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..), + HsSrcBang(..), + PromotionFlag(..), isPromoted, ConDeclField(..), LConDeclField, @@ -56,33 +55,48 @@ hsPatSigType, ) where -import GHC.Prelude - -import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsSplice ) +import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice ) +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension -import GHC.Types.SourceText -import GHC.Types.Name( Name ) import GHC.Types.Name.Reader ( RdrName ) -import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..) ) -import GHC.Core.Type -import GHC.Hs.Doc -import GHC.Types.Basic -import GHC.Types.Fixity -import GHC.Types.SrcLoc -import GHC.Utils.Outputable -import GHC.Data.FastString -import GHC.Utils.Misc ( count ) -import GHC.Parser.Annotation +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 Data.Data hiding ( Fixity, Prefix, Infix ) import Data.Void +import Data.Maybe +import Data.Eq +import Data.Bool +import Data.Char +import Prelude (Integer) {- ************************************************************************ * * +\subsection{Promotion flag} +* * +************************************************************************ +-} + +-- | Is a TyCon a promoted data constructor or just a normal type constructor? +data PromotionFlag + = NotPromoted + | IsPromoted + deriving ( Eq, Data ) + +isPromoted :: PromotionFlag -> Bool +isPromoted IsPromoted = True +isPromoted NotPromoted = False + +{- +************************************************************************ +* * \subsection{Bang annotations} * * ************************************************************************ @@ -155,7 +169,7 @@ HsOuterImplicit (implicit quantification, added by renamer) f :: a -> a -- Desugars to f :: forall {a}. a -> a - HsOuterExplicit (explicit user quantifiation): + HsOuterExplicit (explicit user quantification): f :: forall a. a -> a See Note [forall-or-nothing rule]. @@ -348,7 +362,7 @@ -- HsOuterImplicit (implicit quantification, added by renamer) -- f :: a -> a -- Desugars to f :: forall {a}. a -> a -- type instance F (a,b) = a->b --- HsOuterExplicit (explicit user quantifiation): +-- HsOuterExplicit (explicit user quantification): -- f :: forall a. a -> a -- type instance forall a b. F (a,b) = a->b -- @@ -422,14 +436,6 @@ } | XHsPatSigType !(XXHsPatSigType pass) --- | The extension field for 'HsPatSigType', which is only used in the --- renamer onwards. See @Note [Pattern signature binders and scoping]@. -data HsPSRn = HsPSRn - { hsps_nwcs :: [Name] -- ^ Wildcard names - , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names - } - deriving Data - -- | Located Haskell Signature Type type LHsSigType pass = XRec pass (HsSigType pass) -- Implicit only @@ -482,7 +488,7 @@ -- if you quantify a, you must also quantify b type F4 :: forall a -> b -> b -- Legal; the top quantifier (forall a) is a /visible/ - -- quantifer, so the "nothing" part of the forall-or-nothing + -- quantifier, so the "nothing" part of the forall-or-nothing -- rule applies, and b is therefore implicitly quantified. -- Equivalently: forall b. forall a -> b -> b @@ -680,14 +686,6 @@ hsIPNameFS :: HsIPName -> FastString hsIPNameFS (HsIPName n) = n -instance Outputable HsIPName where - ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters - -instance OutputableBndr HsIPName where - pprBndr _ n = ppr n -- Simple for now - pprInfixOcc n = ppr n - pprPrefixOcc n = ppr n - -------------------------------------------------- -- | Haskell Type Variable Binder @@ -836,7 +834,7 @@ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | HsSpliceTy (XSpliceTy pass) - (HsSplice pass) -- Includes quasi-quotes + (HsUntypedSplice pass) -- Includes quasi-quotes -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@, -- 'GHC.Parser.Annotation.AnnClose' @')'@ @@ -881,7 +879,7 @@ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal. + | 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 @@ -896,30 +894,22 @@ | XHsType !(XXType pass) --- 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 - --- Note [Literal source text] in GHC.Types.Basic for SourceText fields in --- the following -- | Haskell Type Literal -data HsTyLit - = HsNumTy SourceText Integer - | HsStrTy SourceText FastString - | HsCharTy SourceText Char - deriving Data +data HsTyLit pass + = HsNumTy (XNumTy pass) Integer + | HsStrTy (XStrTy pass) FastString + | 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 + | HsLinearArrow !(HsLinearArrowTokens pass) -- ^ a %1 -> b or a %1 → b, or a ⊸ b + | HsExplicitMult !(LHsToken "%" pass) !(LHsType pass) !(LHsUniToken "->" "→" pass) -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`! -- This is how the programmer wrote it). It is stored as an @@ -1046,7 +1036,7 @@ data ConDeclField pass -- Record fields have Haddock docs on them = ConDeclField { cd_fld_ext :: XConDeclField pass, cd_fld_names :: [LFieldOcc pass], - -- ^ See Note [ConDeclField passs] + -- ^ See Note [ConDeclField pass] cd_fld_type :: LBangType pass, cd_fld_doc :: Maybe (LHsDoc pass)} -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon' @@ -1081,14 +1071,8 @@ noTypeArgs :: [Void] noTypeArgs = [] -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] - {- -Note [ConDeclField passs] +Note [ConDeclField pass] ~~~~~~~~~~~~~~~~~~~~~~~~~ A ConDeclField contains a list of field occurrences: these always @@ -1196,71 +1180,16 @@ ************************************************************************ -} --- Arguments in an expression/type after splitting +-- | 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] -numVisibleArgs :: [HsArg tm ty] -> Arity -numVisibleArgs = count is_vis - where is_vis (HsValArg _) = True - is_vis _ = False - -- type level equivalent type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) --- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@ --- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix --- or infix. Examples: --- --- @ --- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int] = T \@Bool Int --- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int] = (T \@Bool) Int --- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double] = Char ++ Double --- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering --- @ -pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty) - => id -> LexicalFixity -> [HsArg tm ty] -> SDoc -pprHsArgsApp thing fixity (argl:argr:args) - | Infix <- fixity - = let pp_op_app = hsep [ ppr_single_hs_arg argl - , pprInfixOcc thing - , ppr_single_hs_arg argr ] in - case args of - [] -> pp_op_app - _ -> ppr_hs_args_prefix_app (parens pp_op_app) args - -pprHsArgsApp thing _fixity args - = ppr_hs_args_prefix_app (pprPrefixOcc thing) args - --- | 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 -ppr_hs_args_prefix_app acc [] = acc -ppr_hs_args_prefix_app acc (arg:args) = - case arg of - HsValArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args - HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args - HsArgPar{} -> ppr_hs_args_prefix_app (parens acc) args - --- | 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 -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 --- allows this to be reachable, so don't fail here. -ppr_single_hs_arg (HsArgPar{}) = empty - --- | 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 - ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp {- Note [HsArgPar] ~~~~~~~~~~~~~~~ @@ -1276,9 +1205,7 @@ -} --------------------------------- - {- ************************************************************************ * * @@ -1312,17 +1239,6 @@ , Eq (XXFieldOcc pass) ) => Eq (FieldOcc pass) -instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) 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 (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where - pprInfixOcc = pprInfixOcc . unLoc - pprPrefixOcc = pprPrefixOcc . unLoc - -- | Located Ambiguous Field Occurence type LAmbiguousFieldOcc pass = XRec pass (AmbiguousFieldOcc pass) @@ -1338,8 +1254,8 @@ -- See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat". -- See Note [Located RdrNames] in "GHC.Hs.Expr". data AmbiguousFieldOcc pass - = Unambiguous (XUnambiguous pass) (LocatedN RdrName) - | Ambiguous (XAmbiguous pass) (LocatedN RdrName) + = Unambiguous (XUnambiguous pass) (XRec pass RdrName) + | Ambiguous (XAmbiguous pass) (XRec pass RdrName) | XAmbiguousFieldOcc !(XXAmbiguousFieldOcc pass) @@ -1350,11 +1266,3 @@ * * ************************************************************************ -} - -instance Outputable HsTyLit where - ppr = ppr_tylit --------------------------- -ppr_tylit :: HsTyLit -> SDoc -ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i) -ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s)) -ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c)) diff --git a/Language/Haskell/Syntax/Type.hs-boot b/Language/Haskell/Syntax/Type.hs-boot new file mode 100644 --- /dev/null +++ b/Language/Haskell/Syntax/Type.hs-boot @@ -0,0 +1,21 @@ +module Language.Haskell.Syntax.Type where + +import Data.Bool +import Data.Eq + +{- +************************************************************************ +* * +\subsection{Promotion flag} +* * +************************************************************************ +-} + +-- | Is a TyCon a promoted data constructor or just a normal type constructor? +data PromotionFlag + = NotPromoted + | IsPromoted + +instance Eq PromotionFlag + +isPromoted :: PromotionFlag -> Bool diff --git a/MachRegs.h b/MachRegs.h --- a/MachRegs.h +++ b/MachRegs.h @@ -591,6 +591,92 @@ #define MAX_REAL_FLOAT_REG 6 #define MAX_REAL_DOUBLE_REG 6 +#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. + + -------------------------------------------------------------------------- */ +#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 + #else #error Cannot find platform to give register info for diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -116,7 +116,7 @@ , " , cStage" , " ) where" , "" - , "import GHC.Prelude" + , "import GHC.Prelude.Basic" , "" , "import GHC.Version" , "" diff --git a/ghc-llvm-version.h b/ghc-llvm-version.h --- a/ghc-llvm-version.h +++ b/ghc-llvm-version.h @@ -3,9 +3,9 @@ #define __GHC_LLVM_VERSION_H__ /* The maximum supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION_MAX (15) +#define sUPPORTED_LLVM_VERSION_MAX (16) /* The minimum supported LLVM version number */ -#define sUPPORTED_LLVM_VERSION_MIN (10) +#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.4.8 +Version: 9.6.1 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team @@ -39,18 +39,13 @@ custom-setup - setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.9, directory, process, filepath + setup-depends: base >= 3 && < 5, Cabal >= 1.6 && <3.10, directory, process, filepath Flag internal-interpreter Description: Build with internal interpreter support. Default: False Manual: True -Flag terminfo - Description: Build GHC with terminfo support on non-Windows platforms. - Default: True - Manual: True - Flag dynamic-system-linker Description: The system can load dynamic code. This is not the case for musl. Default: True @@ -76,7 +71,7 @@ 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.18, + Build-Depends: base >= 4.11 && < 4.19, deepseq >= 1.4 && < 1.5, directory >= 1 && < 1.4, process >= 1 && < 1.7, @@ -86,20 +81,18 @@ containers >= 0.6.2.1 && < 0.7, array >= 0.1 && < 0.6, filepath >= 1 && < 1.5, - template-haskell == 2.19.*, + template-haskell == 2.20.*, hpc == 0.6.*, - transformers == 0.5.*, + transformers >= 0.5 && < 0.7, exceptions == 0.10.*, stm, - ghc-boot == 9.4.8, - ghc-heap == 9.4.8, - ghci == 9.4.8 + ghc-boot == 9.6.1, + ghc-heap == 9.6.1, + ghci == 9.6.1 if os(windows) - Build-Depends: Win32 >= 2.3 && < 2.13 + Build-Depends: Win32 >= 2.3 && < 2.14 else - if flag(terminfo) - Build-Depends: terminfo == 0.4.* Build-Depends: unix >= 2.7 && < 2.9 GHC-Options: -Wall @@ -206,15 +199,15 @@ GHC.Cmm.Node GHC.Cmm.Opt GHC.Cmm.Parser + GHC.Cmm.Parser.Config GHC.Cmm.Parser.Monad GHC.Cmm.Pipeline - GHC.Cmm.Ppr - GHC.Cmm.Ppr.Decl - GHC.Cmm.Ppr.Expr GHC.Cmm.ProcPoint + GHC.Cmm.Reg GHC.Cmm.Sink GHC.Cmm.Switch GHC.Cmm.Switch.Implement + GHC.Cmm.ThreadSanitizer GHC.CmmToAsm GHC.Cmm.LRegSet GHC.CmmToAsm.AArch64 @@ -286,6 +279,8 @@ GHC.CmmToLlvm.Mangler GHC.CmmToLlvm.Ppr GHC.CmmToLlvm.Regs + GHC.Cmm.Dominators + GHC.Cmm.Reducibility GHC.Cmm.Type GHC.Cmm.Utils GHC.Core @@ -299,6 +294,7 @@ GHC.Core.FVs GHC.Core.InstEnv GHC.Core.Lint + GHC.Core.Lint.Interactive GHC.Core.LateCC GHC.Core.Make GHC.Core.Map.Expr @@ -318,14 +314,17 @@ GHC.Core.Opt.Monad GHC.Core.Opt.OccurAnal GHC.Core.Opt.Pipeline + GHC.Core.Opt.Pipeline.Types GHC.Core.Opt.SetLevels GHC.Core.Opt.Simplify GHC.Core.Opt.Simplify.Env + GHC.Core.Opt.Simplify.Iteration GHC.Core.Opt.Simplify.Monad GHC.Core.Opt.Simplify.Utils GHC.Core.Opt.SpecConstr GHC.Core.Opt.Specialise GHC.Core.Opt.StaticArgs + GHC.Core.Opt.Stats GHC.Core.Opt.WorkWrap GHC.Core.Opt.WorkWrap.Utils GHC.Core.PatSyn @@ -334,6 +333,7 @@ GHC.Core.Predicate GHC.Core.Reduction GHC.Core.Rules + GHC.Core.Rules.Config GHC.Core.Seq GHC.Core.SimpleOpt GHC.Core.Stats @@ -343,6 +343,7 @@ GHC.CoreToStg GHC.CoreToStg.Prep GHC.Core.TyCo.FVs + GHC.Core.TyCo.Compare GHC.Core.TyCon GHC.Core.TyCon.Env GHC.Core.TyCon.RecWalk @@ -369,11 +370,15 @@ GHC.Data.FiniteMap GHC.Data.Graph.Base GHC.Data.Graph.Color + GHC.Data.Graph.Collapse GHC.Data.Graph.Directed + 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.Infinite GHC.Data.List.SetOps GHC.Data.Maybe GHC.Data.OrdList @@ -383,19 +388,34 @@ GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap + GHC.Data.Unboxed GHC.Data.UnionFind GHC.Driver.Backend + GHC.Driver.Backend.Internal GHC.Driver.Backpack GHC.Driver.Backpack.Syntax GHC.Driver.CmdLine GHC.Driver.CodeOutput GHC.Driver.Config GHC.Driver.Config.Cmm + GHC.Driver.Config.Cmm.Parser GHC.Driver.Config.CmmToAsm GHC.Driver.Config.CmmToLlvm + GHC.Driver.Config.Core.Lint + GHC.Driver.Config.Core.Lint.Interactive + GHC.Driver.Config.Core.Opt.Arity + GHC.Driver.Config.Core.Opt.LiberateCase + GHC.Driver.Config.Core.Opt.Simplify + GHC.Driver.Config.Core.Opt.WorkWrap + GHC.Driver.Config.Core.Rules + GHC.Driver.Config.CoreToStg + GHC.Driver.Config.CoreToStg.Prep GHC.Driver.Config.Diagnostic GHC.Driver.Config.Finder GHC.Driver.Config.HsToCore + GHC.Driver.Config.HsToCore.Ticks + GHC.Driver.Config.HsToCore.Usage + GHC.Driver.Config.Linker GHC.Driver.Config.Logger GHC.Driver.Config.Parser GHC.Driver.Config.Stg.Debug @@ -404,6 +424,7 @@ GHC.Driver.Config.Stg.Ppr GHC.Driver.Config.StgToCmm GHC.Driver.Config.Tidy + GHC.Driver.Config.StgToJS GHC.Driver.Env GHC.Driver.Env.KnotVars GHC.Driver.Env.Types @@ -413,6 +434,7 @@ GHC.Driver.Flags GHC.Driver.GenerateCgIPEStub GHC.Driver.Hooks + GHC.Driver.LlvmConfigCache GHC.Driver.Main GHC.Driver.Make GHC.Driver.MakeFile @@ -424,6 +446,7 @@ GHC.Driver.Pipeline.Phases GHC.Driver.Pipeline.Monad GHC.Driver.Plugins + GHC.Driver.Plugins.External GHC.Driver.Ppr GHC.Driver.Session GHC.Hs @@ -443,13 +466,18 @@ GHC.HsToCore GHC.HsToCore.Arrows GHC.HsToCore.Binds + GHC.HsToCore.Breakpoints GHC.HsToCore.Coverage GHC.HsToCore.Docs GHC.HsToCore.Errors.Ppr GHC.HsToCore.Errors.Types GHC.HsToCore.Expr + GHC.HsToCore.Foreign.C GHC.HsToCore.Foreign.Call GHC.HsToCore.Foreign.Decl + GHC.HsToCore.Foreign.JavaScript + GHC.HsToCore.Foreign.Prim + GHC.HsToCore.Foreign.Utils GHC.HsToCore.GuardedRHSs GHC.HsToCore.ListComp GHC.HsToCore.Match @@ -465,6 +493,7 @@ GHC.HsToCore.Pmc.Types GHC.HsToCore.Pmc.Utils GHC.HsToCore.Quote + GHC.HsToCore.Ticks GHC.HsToCore.Types GHC.HsToCore.Usage GHC.HsToCore.Utils @@ -490,7 +519,12 @@ GHC.Iface.Tidy.StaticPtrTable GHC.IfaceToCore GHC.Iface.Type + GHC.JS.Make + GHC.JS.Ppr + GHC.JS.Syntax + GHC.JS.Transform GHC.Linker + GHC.Linker.Config GHC.Linker.Dynamic GHC.Linker.ExtraObj GHC.Linker.Loader @@ -529,12 +563,15 @@ GHC.Platform.Reg.Class GHC.Platform.Regs GHC.Platform.RISCV64 + GHC.Platform.LoongArch64 GHC.Platform.S390X + GHC.Platform.Wasm32 GHC.Platform.Ways GHC.Platform.X86 GHC.Platform.X86_64 GHC.Plugins GHC.Prelude + GHC.Prelude.Basic GHC.Rename.Bind GHC.Rename.Doc GHC.Rename.Env @@ -603,10 +640,43 @@ GHC.StgToCmm.Ticky GHC.StgToCmm.Types GHC.StgToCmm.Utils + GHC.StgToJS + GHC.StgToJS.Apply + GHC.StgToJS.Arg + GHC.StgToJS.Closure + GHC.StgToJS.CodeGen + GHC.StgToJS.CoreUtils + GHC.StgToJS.DataCon + GHC.StgToJS.Deps + GHC.StgToJS.Expr + GHC.StgToJS.ExprCtx + GHC.StgToJS.FFI + GHC.StgToJS.Heap + GHC.StgToJS.Ids + GHC.StgToJS.Literal + GHC.StgToJS.Monad + 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.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.Stg.Unarise GHC.SysTools GHC.SysTools.Ar GHC.SysTools.BaseDir + GHC.SysTools.Cpp GHC.SysTools.Elf GHC.SysTools.Info GHC.SysTools.Process @@ -684,6 +754,7 @@ GHC.Types.Cpr GHC.Types.Demand GHC.Types.Error + GHC.Types.Error.Codes GHC.Types.FieldLabel GHC.Types.Fixity GHC.Types.Fixity.Env @@ -707,6 +778,7 @@ GHC.Types.Name.Shape GHC.Types.Name.Ppr GHC.Types.PkgQual + GHC.Types.ProfAuto GHC.Types.RepType GHC.Types.SafeHaskell GHC.Types.SourceError @@ -746,8 +818,8 @@ GHC.Unit.Module.ModDetails GHC.Unit.Module.ModGuts GHC.Unit.Module.ModIface + GHC.Unit.Module.WholeCoreBindings GHC.Unit.Module.ModSummary - GHC.Unit.Module.Name GHC.Unit.Module.Status GHC.Unit.Module.Warnings GHC.Unit.Parser @@ -772,7 +844,6 @@ GHC.Utils.Misc GHC.Utils.Monad GHC.Utils.Monad.State.Strict - GHC.Utils.Monad.State.Lazy GHC.Utils.Outputable GHC.Utils.Panic GHC.Utils.Panic.Plain @@ -780,13 +851,24 @@ GHC.Utils.Ppr.Colour GHC.Utils.TmpFs GHC.Utils.Trace + GHC.Wasm.ControlFlow + GHC.Wasm.ControlFlow.FromCmm + GHC.CmmToAsm.Wasm + GHC.CmmToAsm.Wasm.Asm + GHC.CmmToAsm.Wasm.FromCmm + GHC.CmmToAsm.Wasm.Types + GHC.CmmToAsm.Wasm.Utils Language.Haskell.Syntax + Language.Haskell.Syntax.Basic Language.Haskell.Syntax.Binds + Language.Haskell.Syntax.Concrete Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension + Language.Haskell.Syntax.ImpExp Language.Haskell.Syntax.Lit + Language.Haskell.Syntax.Module.Name Language.Haskell.Syntax.Pat Language.Haskell.Syntax.Type