ghc-lib-parser 0.20201001 → 0.20201101
raw patch · 164 files changed
+10504/−8416 lines, 164 files
Files
- compiler/GHC/Builtin/Names.hs +3/−11
- compiler/GHC/Builtin/PrimOps.hs +4/−3
- compiler/GHC/Builtin/Types.hs +17/−11
- compiler/GHC/Builtin/Types.hs-boot +1/−1
- compiler/GHC/Builtin/Types/Prim.hs +6/−4
- compiler/GHC/ByteCode/Types.hs +2/−1
- compiler/GHC/Cmm/CLabel.hs +10/−10
- compiler/GHC/Cmm/Dataflow/Collections.hs +1/−3
- compiler/GHC/Cmm/Dataflow/Label.hs +2/−5
- compiler/GHC/Cmm/Node.hs +1/−2
- compiler/GHC/Cmm/Type.hs +2/−0
- compiler/GHC/Core.hs +1/−1
- compiler/GHC/Core/Coercion.hs +77/−14
- compiler/GHC/Core/Coercion/Axiom.hs +9/−4
- compiler/GHC/Core/ConLike.hs-boot +0/−9
- compiler/GHC/Core/DataCon.hs +12/−8
- compiler/GHC/Core/FamInstEnv.hs +9/−7
- compiler/GHC/Core/InstEnv.hs +3/−2
- compiler/GHC/Core/Lint.hs +19/−15
- compiler/GHC/Core/Make.hs +19/−17
- compiler/GHC/Core/Map.hs +8/−9
- compiler/GHC/Core/Multiplicity.hs +1/−2
- compiler/GHC/Core/Opt/Arity.hs +163/−89
- compiler/GHC/Core/Opt/ConstantFold.hs +376/−197
- compiler/GHC/Core/Opt/Monad.hs +17/−11
- compiler/GHC/Core/Opt/OccurAnal.hs +33/−6
- compiler/GHC/Core/PatSyn.hs-boot +0/−13
- compiler/GHC/Core/Ppr.hs +3/−4
- compiler/GHC/Core/Predicate.hs +1/−0
- compiler/GHC/Core/SimpleOpt.hs +14/−3
- compiler/GHC/Core/TyCo/Ppr.hs +1/−4
- compiler/GHC/Core/TyCo/Rep.hs +33/−93
- compiler/GHC/Core/TyCo/Rep.hs-boot +0/−1
- compiler/GHC/Core/TyCo/Subst.hs +2/−2
- compiler/GHC/Core/TyCon.hs +6/−86
- compiler/GHC/Core/TyCon/Env.hs +138/−0
- compiler/GHC/Core/TyCon/RecWalk.hs +99/−0
- compiler/GHC/Core/Type.hs +22/−18
- compiler/GHC/Core/Unfold.hs +1/−2
- compiler/GHC/Core/Unify.hs +1/−1
- compiler/GHC/Core/UsageEnv.hs +15/−4
- compiler/GHC/Core/Utils.hs +4/−7
- compiler/GHC/Data/BooleanFormula.hs +2/−2
- compiler/GHC/Data/FastString.hs +7/−3
- compiler/GHC/Data/StringBuffer.hs +10/−6
- compiler/GHC/Data/TrieMap.hs +6/−7
- compiler/GHC/Driver/Backpack/Syntax.hs +7/−2
- compiler/GHC/Driver/Config.hs +0/−1
- compiler/GHC/Driver/Env.hs +375/−0
- compiler/GHC/Driver/Flags.hs +4/−0
- compiler/GHC/Driver/Hooks.hs +23/−11
- compiler/GHC/Driver/Monad.hs +5/−2
- compiler/GHC/Driver/Phases.hs +24/−69
- compiler/GHC/Driver/Pipeline/Monad.hs +10/−3
- compiler/GHC/Driver/Plugins.hs +13/−7
- compiler/GHC/Driver/Session.hs +37/−44
- compiler/GHC/Driver/Types.hs +0/−3334
- compiler/GHC/Hs.hs +18/−2
- compiler/GHC/Hs/Binds.hs +21/−20
- compiler/GHC/Hs/Decls.hs +51/−40
- compiler/GHC/Hs/Doc.hs +0/−1
- compiler/GHC/Hs/Dump.hs +6/−4
- compiler/GHC/Hs/Expr.hs +33/−39
- compiler/GHC/Hs/Extension.hs +62/−57
- compiler/GHC/Hs/ImpExp.hs +8/−13
- compiler/GHC/Hs/Instances.hs +5/−0
- compiler/GHC/Hs/Lit.hs +12/−15
- compiler/GHC/Hs/Pat.hs +14/−17
- compiler/GHC/Hs/Type.hs +68/−55
- compiler/GHC/Hs/Utils.hs +24/−13
- compiler/GHC/Iface/Ext/Fields.hs +94/−0
- compiler/GHC/Iface/Recomp/Binary.hs +1/−2
- compiler/GHC/Iface/Syntax.hs +16/−14
- compiler/GHC/Iface/Type.hs +8/−8
- compiler/GHC/Parser/Annotation.hs +44/−4
- compiler/GHC/Parser/Errors.hs +420/−0
- compiler/GHC/Parser/Errors/Ppr.hs +613/−0
- compiler/GHC/Parser/Header.hs +35/−31
- compiler/GHC/Parser/PostProcess.hs +179/−439
- compiler/GHC/Parser/PostProcess/Haddock.hs +22/−27
- compiler/GHC/Parser/Types.hs +95/−0
- compiler/GHC/Platform.hs +24/−5
- compiler/GHC/Platform/Ways.hs +83/−21
- compiler/GHC/Runtime/Context.hs +389/−0
- compiler/GHC/Runtime/Eval/Types.hs +1/−1
- compiler/GHC/Runtime/Linker/Types.hs +57/−12
- compiler/GHC/Settings.hs +0/−6
- compiler/GHC/Settings/Constants.hs +4/−4
- compiler/GHC/Stg/Syntax.hs +9/−10
- compiler/GHC/Tc/Types.hs +43/−25
- compiler/GHC/Tc/Types/Evidence.hs +6/−4
- compiler/GHC/Tc/Utils/TcType.hs +35/−8
- compiler/GHC/Types/Basic.hs +167/−334
- compiler/GHC/Types/CompleteMatch.hs +17/−0
- compiler/GHC/Types/CostCentre.hs +3/−3
- compiler/GHC/Types/Demand.hs +23/−50
- compiler/GHC/Types/Error.hs +240/−0
- compiler/GHC/Types/FieldLabel.hs +4/−6
- compiler/GHC/Types/Fixity.hs +119/−0
- compiler/GHC/Types/Fixity/Env.hs +46/−0
- compiler/GHC/Types/ForeignCall.hs +23/−23
- compiler/GHC/Types/ForeignStubs.hs +25/−0
- compiler/GHC/Types/HpcInfo.hs +34/−0
- compiler/GHC/Types/Id.hs +8/−2
- compiler/GHC/Types/Id/Make.hs +4/−2
- compiler/GHC/Types/Literal.hs +6/−13
- compiler/GHC/Types/Meta.hs +53/−0
- compiler/GHC/Types/Name.hs +7/−8
- compiler/GHC/Types/Name/Occurrence.hs +26/−10
- compiler/GHC/Types/Name/Ppr.hs +166/−0
- compiler/GHC/Types/Name/Reader.hs +25/−11
- compiler/GHC/Types/RepType.hs +1/−0
- compiler/GHC/Types/SafeHaskell.hs +86/−0
- compiler/GHC/Types/SourceError.hs +64/−0
- compiler/GHC/Types/SourceFile.hs +94/−0
- compiler/GHC/Types/SourceText.hs +234/−0
- compiler/GHC/Types/SrcLoc.hs +2/−8
- compiler/GHC/Types/Target.hs +67/−0
- compiler/GHC/Types/TyThing.hs +316/−0
- compiler/GHC/Types/TyThing.hs-boot +8/−0
- compiler/GHC/Types/TypeEnv.hs +95/−0
- compiler/GHC/Unit.hs +0/−2
- compiler/GHC/Unit/External.hs +131/−0
- compiler/GHC/Unit/Finder/Types.hs +56/−0
- compiler/GHC/Unit/Home/ModInfo.hs +117/−0
- compiler/GHC/Unit/Info.hs +15/−14
- compiler/GHC/Unit/Module.hs +5/−8
- compiler/GHC/Unit/Module/Deps.hs +195/−0
- compiler/GHC/Unit/Module/Graph.hs +101/−0
- compiler/GHC/Unit/Module/Imported.hs +54/−0
- compiler/GHC/Unit/Module/ModDetails.hs +51/−0
- compiler/GHC/Unit/Module/ModGuts.hs +140/−0
- compiler/GHC/Unit/Module/ModIface.hs +535/−0
- compiler/GHC/Unit/Module/ModSummary.hs +190/−0
- compiler/GHC/Unit/Module/Status.hs +46/−0
- compiler/GHC/Unit/Module/Warnings.hs +146/−0
- compiler/GHC/Unit/State.hs +16/−15
- compiler/GHC/Unit/Types.hs +1/−1
- compiler/GHC/Utils/Binary.hs +0/−405
- compiler/GHC/Utils/Binary/Typeable.hs +215/−0
- compiler/GHC/Utils/Encoding.hs +0/−526
- compiler/GHC/Utils/Error.hs +93/−263
- compiler/GHC/Utils/Error.hs-boot +0/−19
- compiler/GHC/Utils/Exception.hs +1/−2
- compiler/GHC/Utils/GlobalVars.hs +1/−1
- compiler/GHC/Utils/Misc.hs +1/−1
- compiler/GHC/Utils/Outputable.hs +4/−10
- ghc-lib-parser.cabal +38/−3
- ghc-lib/stage0/compiler/build/GHC/Parser.hs +47/−76
- ghc-lib/stage0/compiler/build/GHC/Parser/Lexer.hs +155/−217
- ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl +6/−6
- ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +8/−6
- ghc-lib/stage0/compiler/build/primop-docs.hs-incl +94/−32
- ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl +6/−4
- ghc-lib/stage0/compiler/build/primop-list.hs-incl +8/−6
- ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +10/−8
- ghc-lib/stage0/compiler/build/primop-tag.hs-incl +1214/−1212
- ghc-lib/stage0/lib/ghcautoconf.h +1/−1
- ghc-lib/stage0/lib/ghcversion.h +2/−2
- ghc-lib/stage0/lib/settings +0/−2
- ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +4/−4
- libraries/ghc-boot/GHC/Data/ShortText.hs +112/−0
- libraries/ghc-boot/GHC/Unit/Database.hs +34/−32
- libraries/ghc-boot/GHC/Utils/Encoding.hs +529/−0
compiler/GHC/Builtin/Names.hs view
@@ -379,7 +379,6 @@ integerToDoubleName, integerEncodeFloatName, integerEncodeDoubleName,- integerDecodeDoubleName, integerGcdName, integerLcmName, integerAndName,@@ -397,7 +396,6 @@ naturalRemName, naturalQuotRemName, bignatFromWordListName,- -- Float/Double rationalToFloatName, rationalToDoubleName,@@ -610,8 +608,7 @@ gHC_RECORDS :: Module gHC_RECORDS = mkBaseModule (fsLit "GHC.Records") -mAIN, rOOT_MAIN :: Module-mAIN = mkMainModule_ mAIN_NAME+rOOT_MAIN :: Module rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation mkInteractiveModule :: Int -> Module@@ -1155,7 +1152,6 @@ , integerToDoubleName , integerEncodeFloatName , integerEncodeDoubleName- , integerDecodeDoubleName , integerGcdName , integerLcmName , integerAndName@@ -1223,7 +1219,6 @@ integerToDoubleName = bniVarQual "integerToDouble#" integerToDoubleIdKey integerEncodeFloatName = bniVarQual "integerEncodeFloat#" integerEncodeFloatIdKey integerEncodeDoubleName = bniVarQual "integerEncodeDouble#" integerEncodeDoubleIdKey-integerDecodeDoubleName = bniVarQual "integerDecodeDouble#" integerDecodeDoubleIdKey integerGcdName = bniVarQual "integerGcd" integerGcdIdKey integerLcmName = bniVarQual "integerLcm" integerLcmIdKey integerAndName = bniVarQual "integerAnd" integerAndIdKey@@ -1669,7 +1664,7 @@ constructorClassKey = mkPreludeClassUnique 40 selectorClassKey = mkPreludeClassUnique 41 --- KnownNat: see Note [KnowNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence+-- KnownNat: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence knownNatClassNameKey :: Unique knownNatClassNameKey = mkPreludeClassUnique 42 @@ -1877,7 +1872,7 @@ uWordTyConKey = mkPreludeTyConUnique 163 -- Type-level naturals-typeNatKindConNameKey, typeSymbolKindConNameKey,+typeSymbolKindConNameKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey, typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey@@ -1885,7 +1880,6 @@ , typeNatModTyFamNameKey , typeNatLogTyFamNameKey :: Unique-typeNatKindConNameKey = mkPreludeTyConUnique 164 typeSymbolKindConNameKey = mkPreludeTyConUnique 165 typeNatAddTyFamNameKey = mkPreludeTyConUnique 166 typeNatMulTyFamNameKey = mkPreludeTyConUnique 167@@ -2466,7 +2460,6 @@ , integerFromWordIdKey , integerFromWord64IdKey , integerFromInt64IdKey- , integerDecodeDoubleIdKey , naturalToWordIdKey , naturalAddIdKey , naturalSubIdKey@@ -2518,7 +2511,6 @@ integerFromWordIdKey = mkPreludeMiscIdUnique 638 integerFromWord64IdKey = mkPreludeMiscIdUnique 639 integerFromInt64IdKey = mkPreludeMiscIdUnique 640-integerDecodeDoubleIdKey = mkPreludeMiscIdUnique 641 naturalToWordIdKey = mkPreludeMiscIdUnique 650 naturalAddIdKey = mkPreludeMiscIdUnique 651
compiler/GHC/Builtin/PrimOps.hs view
@@ -39,13 +39,14 @@ import GHC.Core.TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) import GHC.Core.Type import GHC.Types.RepType ( tyConPrimRep1 )-import GHC.Types.Basic ( Arity, Fixity(..), FixityDirection(..), Boxity(..),- SourceText(..) )+import GHC.Types.Basic ( Arity, Boxity(..) )+import GHC.Types.Fixity ( Fixity(..), FixityDirection(..) ) import GHC.Types.SrcLoc ( wiredInSrcSpan ) import GHC.Types.ForeignCall ( CLabelString )+import GHC.Types.SourceText ( SourceText(..) ) import GHC.Types.Unique ( Unique) import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique )-import GHC.Unit ( Unit )+import GHC.Unit.Types ( Unit ) import GHC.Utils.Outputable import GHC.Data.FastString
compiler/GHC/Builtin/Types.hs view
@@ -78,6 +78,7 @@ unboxedUnitTy, unboxedUnitTyCon, unboxedUnitDataCon, unboxedTupleKind, unboxedSumKind,+ filterCTuple, -- ** Constraint tuples cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName,@@ -95,7 +96,7 @@ mkSumTy, sumTyCon, sumDataCon, -- * Kinds- typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,+ typeSymbolKindCon, typeSymbolKind, isLiftedTypeKindTyConName, liftedTypeKind, typeToTypeKind, constraintKind, liftedTypeKindTyCon, constraintKindTyCon, constraintKindTyConName,@@ -163,13 +164,15 @@ -- others: 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 GHC.Types.RepType import GHC.Core.DataCon-import {-# SOURCE #-} GHC.Core.ConLike+import GHC.Core.ConLike import GHC.Core.TyCon import GHC.Core.Class ( Class, mkClass ) import GHC.Types.Name.Reader@@ -255,7 +258,6 @@ , heqTyCon , eqTyCon , coercibleTyCon- , typeNatKindCon , typeSymbolKindCon , runtimeRepTyCon , vecCountTyCon@@ -476,8 +478,7 @@ -- at (promoted) use-sites of MkT. -- Kinds-typeNatKindConName, typeSymbolKindConName :: Name-typeNatKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Nat") typeNatKindConNameKey typeNatKindCon+typeSymbolKindConName :: Name typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon constraintKindTyConName :: Name@@ -678,14 +679,11 @@ ************************************************************************ -} -typeNatKindCon, typeSymbolKindCon :: TyCon--- data Nat+typeSymbolKindCon :: TyCon -- data Symbol-typeNatKindCon = pcTyCon typeNatKindConName Nothing [] [] typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] [] -typeNatKind, typeSymbolKind :: Kind-typeNatKind = mkTyConTy typeNatKindCon+typeSymbolKind :: Kind typeSymbolKind = mkTyConTy typeSymbolKindCon constraintKindTyCon :: TyCon@@ -730,7 +728,7 @@ - Wanted constraints: there is a built-in instance instance (c1,c2) => (c1,c2) See GHC.Tc.Instance.Class.matchCTuple- - Currently just go up to 62; beyond that+ - Currently just go up to 64; beyond that you have to use manual nesting - Their OccNames look like (%,,,%), so they can easily be distinguished from term tuples. But (following Haskell) we@@ -2029,3 +2027,11 @@ naturalNBDataCon :: DataCon naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon+++-- | Replaces constraint tuple names with corresponding boxed ones.+filterCTuple :: RdrName -> RdrName+filterCTuple (Exact n)+ | Just arity <- cTupleTyConNameArity_maybe n+ = Exact $ tupleTyConName BoxedTuple arity+filterCTuple rdr = rdr
compiler/GHC/Builtin/Types.hs-boot view
@@ -8,7 +8,7 @@ import {-# SOURCE #-} GHC.Types.Name (Name) listTyCon :: TyCon-typeNatKind, typeSymbolKind :: Type+typeSymbolKind :: Type mkBoxedTupleTy :: [Type] -> Type coercibleTyCon, heqTyCon :: TyCon
compiler/GHC/Builtin/Types/Prim.hs view
@@ -115,6 +115,7 @@ import GHC.Types.Var ( TyVar, mkTyVar ) import GHC.Types.Name+import {-# SOURCE #-} GHC.Types.TyThing import GHC.Core.TyCon import GHC.Types.SrcLoc import GHC.Types.Unique@@ -190,6 +191,7 @@ , word64PrimTyCon , tYPETyCon+ , funTyCon #include "primop-vector-tycons.hs-incl" ]@@ -198,14 +200,14 @@ mkPrimTc fs unique tycon = mkWiredInName gHC_PRIM (mkTcOccFS fs) unique- (ATyCon tycon) -- Relevant TyCon+ (mkATyCon tycon) -- Relevant TyCon UserSyntax mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name mkBuiltInPrimTc fs unique tycon = mkWiredInName gHC_PRIM (mkTcOccFS fs) unique- (ATyCon tycon) -- Relevant TyCon+ (mkATyCon tycon) -- Relevant TyCon BuiltInSyntax @@ -422,7 +424,7 @@ -- @ -- type Arr :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). -- TYPE rep1 -> TYPE rep2 -> Type--- type Arr = FUN+-- type Arr = FUN 'Many -- @ -- funTyCon :: TyCon@@ -546,7 +548,7 @@ mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name mkPrimTcName built_in_syntax occ key tycon- = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon tycon) built_in_syntax+ = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (mkATyCon tycon) built_in_syntax ----------------------------- -- | Given a RuntimeRep, applies TYPE to it.
compiler/GHC/ByteCode/Types.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-} -- -- (c) The University of Glasgow 2002-2006 --
compiler/GHC/Cmm/CLabel.hs view
@@ -132,7 +132,7 @@ import GHC.Types.Id.Info import GHC.Types.Basic import {-# SOURCE #-} GHC.Cmm.BlockId (BlockId, mkBlockId)-import GHC.Unit+import GHC.Unit.Types import GHC.Types.Name import GHC.Types.Unique import GHC.Builtin.PrimOps@@ -387,7 +387,7 @@ data ForeignLabelSource -- | Label is in a named package- = ForeignLabelInPackage Unit+ = ForeignLabelInPackage UnitId -- | Label is in some external, system package that doesn't also -- contain compiled Haskell code, and is not associated with any .hi files.@@ -1087,15 +1087,15 @@ case lbl of -- is the RTS in a DLL or not? RtsLabel _ ->- externalDynamicRefs && (this_pkg /= rtsUnit)+ externalDynamicRefs && (this_unit /= rtsUnitId) IdLabel n _ _ -> externalDynamicRefs && isDynLinkName platform this_mod n -- When compiling in the "dyn" way, each package is to be linked into -- its own shared library.- CmmLabel pkg _ _ _- | os == OSMinGW32 -> externalDynamicRefs && (toUnitId this_pkg /= pkg)+ CmmLabel lbl_unit _ _ _+ | os == OSMinGW32 -> externalDynamicRefs && (this_unit /= lbl_unit) | otherwise -> externalDynamicRefs LocalBlockLabel _ -> False@@ -1114,7 +1114,7 @@ -- When compiling in the "dyn" way, each package is to be -- linked into its own DLL. ForeignLabelInPackage pkgId ->- externalDynamicRefs && (this_pkg /= pkgId)+ externalDynamicRefs && (this_unit /= pkgId) else -- On Mac OS X and on ELF platforms, false positives are OK, -- so we claim that all foreign imports come from dynamic@@ -1136,7 +1136,7 @@ externalDynamicRefs = ncgExternalDynamicRefs config platform = ncgPlatform config os = platformOS platform- this_pkg = moduleUnit this_mod+ this_unit = toUnitId (moduleUnit this_mod) -----------------------------------------------------------------------------@@ -1569,12 +1569,12 @@ The emitted assembly is -#### INDIRECTEE+==== INDIRECTEE a1_rXq_closure: -- module local haskell value .quad GHC.Types.I#_con_info -- an Int .quad 42 -#### BEFORE+==== BEFORE .globl T15155.a_closure -- exported newtype wrapped value T15155.a_closure: .quad stg_IND_STATIC_info -- the closure info@@ -1582,7 +1582,7 @@ .quad 0 .quad 0 -#### AFTER+==== AFTER .globl T15155.a_closure -- exported newtype wrapped value .equiv a1_rXq_closure,T15155.a_closure -- both are shared
compiler/GHC/Cmm/Dataflow/Collections.hs view
@@ -1,8 +1,6 @@-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} module GHC.Cmm.Dataflow.Collections ( IsSet(..)
compiler/GHC/Cmm/Dataflow/Label.hs view
@@ -1,11 +1,8 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-+{-# LANGUAGE TypeFamilies #-} module GHC.Cmm.Dataflow.Label ( Label
compiler/GHC/Cmm/Node.hs view
@@ -1,13 +1,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
compiler/GHC/Cmm/Type.hs view
@@ -311,6 +311,8 @@ -- Hints are extra type information we attach to the arguments and -- results of a foreign call, where more type information is sometimes -- needed by the ABI to make the correct kind of call.+--+-- See Note [Signed vs unsigned] for one case where this is used. data ForeignHint = NoHint | AddrHint | SignedHint
compiler/GHC/Core.hs view
@@ -968,7 +968,7 @@ { breakpointId :: !Int , breakpointFVs :: [id] -- ^ the order of this list is important: -- it matches the order of the lists in the- -- appropriate entry in 'GHC.Driver.Types.ModBreaks'.+ -- appropriate entry in 'GHC.ByteCode.Types.ModBreaks'. -- -- Careful about substitution! See -- Note [substTickish] in "GHC.Core.Subst".
compiler/GHC/Core/Coercion.hs view
@@ -1,10 +1,12 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+ {- (c) The University of Glasgow 2006 -} -{-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts, BangPatterns,- ScopedTypeVariables #-}- -- | Module for (a) type kinds and (b) type coercions, -- as used in System FC. See 'GHC.Core.Expr' for -- more on System FC and how coercions fit into it.@@ -40,7 +42,9 @@ mkAxiomInstCo, mkProofIrrelCo, downgradeRole, mkAxiomRuleCo, mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,- mkKindCo, castCoercionKind, castCoercionKindI,+ mkKindCo,+ castCoercionKind, castCoercionKind1, castCoercionKind2,+ mkFamilyTyConAppCo, mkHeteroCoercionType, mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,@@ -134,6 +138,7 @@ import GHC.Core.TyCo.Tidy 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@@ -1509,25 +1514,66 @@ ; return (piResultTy <$> g_tys <*> w_tys, g') } -- | Creates a new coercion with both of its types casted by different casts--- @castCoercionKind g r t1 t2 h1 h2@, where @g :: t1 ~r t2@,+-- @castCoercionKind2 g r t1 t2 h1 h2@, where @g :: t1 ~r t2@, -- has type @(t1 |> h1) ~r (t2 |> h2)@. -- @h1@ and @h2@ must be nominal.-castCoercionKind :: Coercion -> Role -> Type -> Type+castCoercionKind2 :: Coercion -> Role -> Type -> Type -> CoercionN -> CoercionN -> Coercion-castCoercionKind g r t1 t2 h1 h2+castCoercionKind2 g r t1 t2 h1 h2 = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) +-- | @castCoercionKind1 g r t1 t2 h@ = @coercionKind g r t1 t2 h h@+-- That is, it's a specialised form of castCoercionKind, where the two+-- kind coercions are identical+-- @castCoercionKind1 g r t1 t2 h@, where @g :: t1 ~r t2@,+-- has type @(t1 |> h) ~r (t2 |> h)@.+-- @h@ must be nominal.+-- See Note [castCoercionKind1]+castCoercionKind1 :: Coercion -> Role -> Type -> Type+ -> CoercionN -> Coercion+castCoercionKind1 g r t1 t2 h+ = case g of+ Refl {} -> ASSERT( r == Nominal ) -- Refl is always Nominal+ mkNomReflCo (mkCastTy t2 h)+ GRefl _ _ mco -> case mco of+ MRefl -> mkReflCo r (mkCastTy t2 h)+ MCo kind_co -> GRefl r (mkCastTy t1 h) $+ MCo (mkSymCo h `mkTransCo` kind_co `mkTransCo` h)+ _ -> castCoercionKind2 g r t1 t2 h h+ -- | Creates a new coercion with both of its types casted by different casts -- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@, -- has type @(t1 |> h1) ~r (t2 |> h2)@. -- @h1@ and @h2@ must be nominal. -- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for)--- Use @castCoercionKind@ instead if @t1@, @t2@, and @r@ are known beforehand.-castCoercionKindI :: Coercion -> CoercionN -> CoercionN -> Coercion-castCoercionKindI g h1 h2- = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)- where (Pair t1 t2, r) = coercionKindRole g+-- Use @castCoercionKind2@ instead if @t1@, @t2@, and @r@ are known beforehand.+castCoercionKind :: Coercion -> CoercionN -> CoercionN -> Coercion+castCoercionKind g h1 h2+ = castCoercionKind2 g r t1 t2 h1 h2+ where+ (Pair t1 t2, r) = coercionKindRole g +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 = ASSERT2( 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@@ -1567,6 +1613,23 @@ (tc, _) = splitTyConApp (coercionLKind g) co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc) +{- Note [castCoercionKind1]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+castCoercionKind1 deals with the very important special case of castCoercionKind2+where the two kind coercions are identical. In that case we can exploit the+situation where the main coercion is reflexive, via the special cases for Refl+and GRefl.++This is important when flattening (ty |> co). We flatten ty, yielding+ fco :: ty ~ ty'+and now we want a coercion xco between+ xco :: (ty |> co) ~ (ty' |> co)+That's exactly what castCoercionKind1 does. And it's very very common for+fco to be Refl. In that case we do NOT want to get some terrible composition+of mkLeftCoherenceCo and mkRightCoherenceCo, which is what castCoercionKind2+has to do in its full generality. See #18413.+-}+ {- %************************************************************************ %* *@@ -1942,8 +2005,8 @@ else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t) go r ty@(LitTy {}) = ASSERT( r == Nominal ) mkNomReflCo ty- go r (CastTy ty co) = castCoercionKindI (go r ty) (substLeftCo lc co)- (substRightCo lc co)+ go r (CastTy ty co) = castCoercionKind (go r ty) (substLeftCo lc co)+ (substRightCo lc co) go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co) (substRightCo lc co) where kco = go Nominal (coercionType co)
compiler/GHC/Core/Coercion/Axiom.hs view
@@ -1,7 +1,12 @@--- (c) The University of Glasgow 2012+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures,- ScopedTypeVariables, StandaloneDeriving, RoleAnnotations #-}+-- (c) The University of Glasgow 2012 -- | Module for coercion axioms, used to represent type family instances -- and newtypes@@ -380,7 +385,7 @@ Note [Implicit axioms] ~~~~~~~~~~~~~~~~~~~~~~-See also Note [Implicit TyThings] in GHC.Driver.Types+See also Note [Implicit TyThings] in GHC.Types.TyThing * A CoAxiom arising from data/type family instances is not "implicit". That is, it has its own IfaceAxiom declaration in an interface file
− compiler/GHC/Core/ConLike.hs-boot
@@ -1,9 +0,0 @@-module GHC.Core.ConLike where-import {-# SOURCE #-} GHC.Core.DataCon (DataCon)-import {-# SOURCE #-} GHC.Core.PatSyn (PatSyn)-import GHC.Types.Name ( Name )--data ConLike = RealDataCon DataCon- | PatSynCon PatSyn--conLikeName :: ConLike -> Name
compiler/GHC/Core/DataCon.hs view
@@ -73,7 +73,9 @@ import GHC.Core.Unify import GHC.Core.TyCon import GHC.Core.Multiplicity+import {-# SOURCE #-} GHC.Types.TyThing import GHC.Types.FieldLabel+import GHC.Types.SourceText import GHC.Core.Class import GHC.Types.Name import GHC.Builtin.Names@@ -81,7 +83,8 @@ import GHC.Types.Var import GHC.Types.Basic import GHC.Data.FastString-import GHC.Unit+import GHC.Unit.Types+import GHC.Unit.Module.Name import GHC.Utils.Binary import GHC.Types.Unique.Set import GHC.Builtin.Uniques( mkAlphaTyVarUnique )@@ -580,6 +583,7 @@ purposes of TypeApplications, and as a consequence, they do not come equipped with visibilities (that is, they are TyVars/TyCoVars instead of TyCoVarBinders).+ * 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@@ -600,10 +604,10 @@ ordering, they in fact share the same type variables (with the same Uniques). We sometimes refer to this as "the dcUserTyVarBinders invariant". -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 data constructor (see-dataConWrapperType), and as a result, it's what matters from a TypeApplications-perspective.+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+data constructor wrapper (see dataConWrapperType), and as a result,+it's what matters from a TypeApplications perspective. Note [The dcEqSpec domain invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -672,7 +676,7 @@ -- emit a warning (in checkValidDataCon) and treat it like -- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ data HsSrcBang =- HsSrcBang SourceText -- Note [Pragma source text] in GHC.Types.Basic+ HsSrcBang SourceText -- Note [Pragma source text] in GHC.Types.SourceText SrcUnpackedness SrcStrictness deriving Data.Data@@ -1192,11 +1196,11 @@ -- the union of the 'dataConWorkId' and the 'dataConWrapId' dataConImplicitTyThings :: DataCon -> [TyThing] dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep })- = [AnId work] ++ wrap_ids+ = [mkAnId work] ++ wrap_ids where wrap_ids = case rep of NoDataConRep -> []- DCR { dcr_wrap_id = wrap } -> [AnId wrap]+ DCR { dcr_wrap_id = wrap } -> [mkAnId wrap] -- | The labels for the fields of this particular 'DataCon' dataConFieldLabels :: DataCon -> [FieldLabel]
compiler/GHC/Core/FamInstEnv.hs view
@@ -1,12 +1,14 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- (c) The University of Glasgow 2006 -- -- FamInstEnv: Type checked family instance declarations -{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections,- DeriveFunctor #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Core.FamInstEnv ( FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon,@@ -224,7 +226,7 @@ pprFamInst :: FamInst -> SDoc -- Prints the FamInst as a family instance declaration -- NB: This function, FamInstEnv.pprFamInst, is used only for internal,--- debug printing. See GHC.Core.Ppr.TyThing.pprFamInst for printing for the user+-- debug printing. See GHC.Types.TyThing.Ppr.pprFamInst for printing for the user pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs }) = hang (ppr_tc_sort <+> text "instance"@@ -1445,7 +1447,7 @@ = do { (nco, nty) <- go ty ; lc <- getLC ; let co' = substRightCo lc co- ; return (castCoercionKind nco Nominal ty nty co co'+ ; return (castCoercionKind2 nco Nominal ty nty co co' , mkCastTy nty co') } go (CoercionTy co) = do { lc <- getLC
compiler/GHC/Core/InstEnv.hs view
@@ -36,7 +36,8 @@ 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.Unit+import GHC.Unit.Module.Env+import GHC.Unit.Types import GHC.Core.Class import GHC.Types.Var import GHC.Types.Var.Set@@ -233,7 +234,7 @@ pprInstances ispecs = vcat (map pprInstance ispecs) instanceHead :: ClsInst -> ([TyVar], Class, [Type])--- Returns the head, using the fresh tyavs from the ClsInst+-- Returns the head, using the fresh tyvars from the ClsInst instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun }) = (tvs, cls, tys) where
compiler/GHC/Core/Lint.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998@@ -7,9 +12,6 @@ See Note [Core Lint guarantee]. -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns, ScopedTypeVariables, DeriveFunctor, MultiWayIf #-}- module GHC.Core.Lint ( lintCoreBindings, lintUnfolding, lintPassResult, lintInteractiveExpr, lintExpr,@@ -25,6 +27,10 @@ import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Env+ import GHC.Core import GHC.Core.FVs import GHC.Core.Utils@@ -45,7 +51,6 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.Ppr-import GHC.Utils.Error import GHC.Core.Coercion import GHC.Types.SrcLoc import GHC.Core.Type as Type@@ -71,10 +76,10 @@ import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Opt.Arity ( typeArity ) import GHC.Types.Demand ( splitStrictSig, isDeadEndDiv )+import GHC.Types.TypeEnv+import GHC.Unit.Module.ModGuts+import GHC.Runtime.Context -import GHC.Driver.Types hiding (Usage)-import GHC.Driver.Session-import GHC.Driver.Ppr import Control.Monad import GHC.Utils.Monad import Data.Foldable ( toList )@@ -178,7 +183,7 @@ 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-moduolo-le-subst. This is in the le_subst field of+ 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@@ -396,7 +401,6 @@ (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) | otherwise = return ()- where lint_banner :: String -> SDoc -> SDoc lint_banner string pass = text "*** Core Lint" <+> text string@@ -435,7 +439,7 @@ interactiveInScope :: HscEnv -> [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.Driver.Types).+-- 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@@ -919,7 +923,7 @@ ; (fun_ty2, ue2) <- lintCoreArg fun_pair1 arg_ty2 -- See Note [Linting of runRW#] ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv)- lintRunRWCont expr@(Lam _ _) = do+ lintRunRWCont expr@(Lam _ _) = lintJoinLams 1 (Just fun) expr lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other -- TODO: Look through ticks?@@ -1864,14 +1868,14 @@ ~~~~~~~~~~~~~~~~~~~~~~~ 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+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.)+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.
compiler/GHC/Core/Make.hs view
@@ -55,37 +55,39 @@ #include "GhclibHsVersions.h" import GHC.Prelude+import GHC.Platform import GHC.Types.Id import GHC.Types.Var ( EvVar, setTyVarUnique )+import GHC.Types.TyThing+import GHC.Types.Id.Info+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Types.Name hiding ( varName )+import GHC.Types.Literal+import GHC.Types.Unique.Supply+import GHC.Types.Basic import GHC.Core import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec )-import GHC.Types.Literal-import GHC.Driver.Types-import GHC.Platform--import GHC.Builtin.Types-import GHC.Builtin.Names--import GHC.Hs.Utils ( mkChunkified, chunkify ) import GHC.Core.Type 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-import GHC.Types.Id.Info-import GHC.Types.Demand-import GHC.Types.Cpr-import GHC.Types.Name hiding ( varName )+ import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Types.Unique.Supply-import GHC.Types.Basic import GHC.Utils.Misc import GHC.Utils.Panic-import Data.List +import GHC.Data.FastString++import Data.List import Data.Char ( ord ) infixl 4 `mkCoreApp`, `mkCoreApps`@@ -940,7 +942,7 @@ f x = (case x of (a,b) -> b) + 1::Int -The demand analyser figures ot that only the second component of x is+The demand analyser figures out that only the second component of x is used, and does a w/w split thus f x = case x of (a,b) -> $wf b
compiler/GHC/Core/Map.hs view
@@ -1,16 +1,15 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}- {-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-} module GHC.Core.Map ( -- * Maps over Core expressions
compiler/GHC/Core/Multiplicity.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-} {-| This module defines the semi-ring of multiplicities, and associated functions.
compiler/GHC/Core/Opt/Arity.hs view
@@ -52,7 +52,8 @@ import GHC.Core.Coercion as Type import GHC.Core.DataCon-import GHC.Core.TyCon ( initRecTc, checkRecTc, tyConArity )+import GHC.Core.TyCon ( tyConArity )+import GHC.Core.TyCon.RecWalk ( initRecTc, checkRecTc ) import GHC.Core.Predicate ( isDictTy ) import GHC.Core.Multiplicity import GHC.Types.Var.Set@@ -174,13 +175,10 @@ -- and gives them a suitable strictness signatures. It's used during -- float-out exprBotStrictness_maybe e- = case getBotArity (arityType env e) of+ = case getBotArity (arityType botStrictnessArityEnv e) of Nothing -> Nothing Just ar -> Just (ar, sig ar) where- env = AE { ae_ped_bot = True- , ae_cheap_fn = \ _ _ -> False- , ae_joins = emptyVarSet } sig ar = mkClosedStrictSig (replicate ar topDmd) botDiv {-@@ -352,14 +350,7 @@ case undefined of { (a,b) -> \y -> e } This showed up in #5557 - (2) Do NOT move a lambda outside a case if all the branches of- the case are known to return bottom.- case x of { (a,b) -> \y -> error "urk" }- This case is less important, but the idea is that if the fn is- going to diverge eventually anyway then getting the best arity- isn't an issue, so we might as well play safe-- (3) Do NOT move a lambda outside a case unless+ (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)@@ -551,34 +542,18 @@ vanillaArityType :: ArityType vanillaArityType = ATop [] -- Totally uninformative --- ^ The Arity returned is the number of value args the+-- | 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 env e- where- env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp- , ae_ped_bot = gopt Opt_PedanticBottoms dflags- , ae_joins = emptyVarSet }+exprEtaExpandArity dflags e = arityType (etaExpandArityEnv dflags) e getBotArity :: ArityType -> Maybe Arity -- Arity of a divergent function getBotArity (ABot n) = Just n getBotArity _ = Nothing -mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun-mk_cheap_fn dflags cheap_app- | not (gopt Opt_DictsCheap dflags)- = \e _ -> exprIsCheapX cheap_app e- | otherwise- = \e mb_ty -> exprIsCheapX cheap_app e- || case mb_ty of- Nothing -> False- Just ty -> isDictTy ty-- ---------------------- findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType -- This implements the fixpoint loop for arity analysis@@ -588,20 +563,16 @@ -- so it is safe to expand e ==> (\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 (get_arity init_cheap_app)- -- We always call exprEtaExpandArity once, but usually- -- that produces a result equal to old_arity, and then- -- we stop right away (since arities should not decrease)- -- Result: the common case is that there is just one iteration+ = go (step botArityType)+ -- We always do one step, but usually that produces a result equal to+ -- old_arity, and then we stop right away (since arities should not+ -- decrease)+ -- Result: the common case is that there is just one iteration where- init_cheap_app :: CheapAppFun- init_cheap_app fn n_val_args- | fn == bndr = True -- On the first pass, this binder gets infinite arity- | otherwise = isCheapApp fn n_val_args- go :: ArityType -> ArityType+ go cur_atype@(ATop oss)+ | length oss <= old_arity = cur_atype go cur_atype- | cur_arity <= old_arity = cur_atype | new_atype == cur_atype = cur_atype | otherwise = #if defined(DEBUG)@@ -611,20 +582,13 @@ #endif go new_atype where- new_atype = get_arity cheap_app-- cur_arity = arityTypeArity cur_atype- cheap_app :: CheapAppFun- cheap_app fn n_val_args- | fn == bndr = n_val_args < cur_arity- | otherwise = isCheapApp fn n_val_args+ new_atype = step cur_atype - get_arity :: CheapAppFun -> ArityType- get_arity cheap_app = arityType env rhs+ step :: ArityType -> ArityType+ step at = -- pprTrace "step" (ppr bndr <+> ppr at <+> ppr (arityType env rhs)) $+ arityType env rhs where- env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app- , ae_ped_bot = gopt Opt_PedanticBottoms dflags- , ae_joins = emptyVarSet }+ env = extendSigEnv (findRhsArityEnv dflags) bndr at {- Note [Arity analysis]@@ -642,18 +606,30 @@ fifteen years ago! It also shows up in the code for 'rnf' on lists in #4138. -The analysis is easy to achieve because exprEtaExpandArity takes an-argument- type CheapFun = CoreExpr -> Maybe Type -> Bool-used to decide if an expression is cheap enough to push inside a-lambda. And exprIsCheapX in turn takes an argument- type CheapAppFun = Id -> Int -> Bool-which tells when an application is cheap. This makes it easy to-write the analysis loop.+We do the neccessary, quite simple fixed-point iteration in 'findRhsArity',+which assumes for a single binding @botArityType@ on the first run and iterates+until it finds a stable arity type. Two wrinkles -The analysis is cheap-and-cheerful because it doesn't deal with-mutual recursion. But the self-recursive case is the important one.+* 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 [Eta expanding through dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the experimental -fdicts-cheap flag is on, we eta-expand through@@ -756,22 +732,115 @@ -} ----------------------------type CheapFun = CoreExpr -> Maybe Type -> Bool- -- How to decide if an expression is cheap- -- If the Maybe is Just, the type is the type- -- of the expression; Nothing means "don't know" +-- | 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.+ data ArityEnv- = AE { ae_cheap_fn :: CheapFun- , ae_ped_bot :: Bool -- True <=> be pedantic about bottoms- , ae_joins :: IdSet -- In-scope join points- -- See Note [Eta-expansion and join points]+ = AE+ { ae_mode :: !AnalysisMode+ -- ^ The analysis mode. See 'AnalysisMode'.+ , ae_joins :: !IdSet+ -- ^ In-scope join points. See Note [Eta-expansion and join points] } +-- | The @ArityEnv@ used by 'exprBotStrictness_maybe'. Pedantic about bottoms+-- and no application is ever considered cheap.+botStrictnessArityEnv :: ArityEnv+botStrictnessArityEnv = AE { ae_mode = BotStrictness, ae_joins = emptyVarSet }++-- | 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 }+ , ae_joins = emptyVarSet }+ extendJoinEnv :: ArityEnv -> [JoinId] -> ArityEnv extendJoinEnv env@(AE { ae_joins = joins }) join_ids = env { ae_joins = joins `extendVarSetList` join_ids } +extendSigEnv :: ArityEnv -> Id -> ArityType -> ArityEnv+extendSigEnv env@AE { ae_mode = am@FindRhsArity{am_sigs = sigs} } id ar_ty =+ env { ae_mode = am { am_sigs = extendVarEnv sigs id ar_ty } }+extendSigEnv env _ _ = 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 = am_dicts_cheap mode && fmap isDictTy mb_ty == Just True+ 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 ArityType.+ -- Roughly approximate what 'isCheapApp' is doing.+ Just (ABot _) -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils+ Just (ATop oss) -> n_val_args < length oss -- Essentially isWorkFreeApp+ ---------------- arityType :: ArityEnv -> CoreExpr -> ArityType @@ -792,6 +861,8 @@ arityType env (Var v) | v `elemVarSet` ae_joins env = botArityType -- See Note [Eta-expansion and join points]+ | Just at <- lookupSigEnv env v -- Local binding+ = at | otherwise = idArityType v @@ -804,7 +875,7 @@ arityType env (App fun (Type _)) = arityType env fun arityType env (App fun arg )- = arityApp (arityType env fun) (ae_cheap_fn env arg Nothing)+ = 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@@ -814,20 +885,20 @@ -- f x y = case x of { (a,b) -> e } -- The difference is observable using 'seq' ---arityType env (Case scrut _ _ alts)+arityType env (Case scrut bndr _ alts) | exprIsDeadEnd scrut || null alts = botArityType -- Do not eta expand -- See Note [Dealing with bottom (1)]- | otherwise- = case alts_type of- ABot n | n>0 -> ATop [] -- Don't eta expand- | otherwise -> botArityType -- if RHS is bottomming- -- See Note [Dealing with bottom (2)]+ | not (pedanticBottoms env) -- See Note [Dealing with bottom (2)]+ , myExprIsCheap env scrut (Just (idType bndr))+ = alts_type+ | exprOkForSpeculation scrut+ = alts_type - ATop as | not (ae_ped_bot env) -- See Note [Dealing with bottom (3)]- , ae_cheap_fn env scrut Nothing -> ATop as- | exprOkForSpeculation scrut -> ATop as- | otherwise -> ATop (takeWhile isOneShotInfo as)+ | otherwise -- In the remaining cases we may not push+ = case alts_type of -- evaluation of the scrutinee in+ ATop as -> ATop (takeWhile isOneShotInfo as)+ ABot _ -> ATop [] where alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts] @@ -853,13 +924,17 @@ | otherwise = pprPanic "arityType:joinrec" (ppr pairs) -arityType env (Let b e)- = floatIn (cheap_bind b) (arityType env e)+arityType env (Let (NonRec b r) e)+ = floatIn cheap_rhs (arityType env' e) where- cheap_bind (NonRec b e) = is_cheap (b,e)- cheap_bind (Rec prs) = all is_cheap prs- is_cheap (b,e) = ae_cheap_fn env e (Just (idType b))+ 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))+ arityType env (Tick t e) | not (tickishIsCode t) = arityType env e @@ -1742,4 +1817,3 @@ -- "OrCoVar" since this can be used to eta-expand -- coercion abstractions subst' = extendTCvInScope subst eta_id'-
compiler/GHC/Core/Opt/ConstantFold.hs view
@@ -1,8 +1,6 @@ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -\section[ConFold]{Constant Folder}- Conceptually, constant folding should be parameterized with the kind of target machine to get identical behaviour during compilation time and runtime. We cheat a little bit here...@@ -13,10 +11,18 @@ -} {-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards,- DeriveFunctor #-}-{-# LANGUAGE LambdaCase #-}+ DeriveFunctor, LambdaCase, TypeApplications, MultiWayIf #-}+ {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-} +#if __GLASGOW_HASKELL__ <= 808+-- GHC 8.10 deprecates this flag, but GHC 8.8 needs it+-- The default iteration limit is a bit too low for the definitions+-- in this module.+{-# OPTIONS_GHC -fmax-pmcheck-iterations=20000000 #-}+#endif++-- | Constant Folder module GHC.Core.Opt.ConstantFold ( primOpRules , builtinRules@@ -37,7 +43,7 @@ import GHC.Core.Make import GHC.Types.Id import GHC.Types.Literal-import GHC.Core.SimpleOpt ( exprIsLiteral_maybe )+import GHC.Core.SimpleOpt ( exprIsConApp_maybe, exprIsLiteral_maybe ) import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey ) import GHC.Builtin.Types import GHC.Builtin.Types.Prim@@ -48,7 +54,6 @@ import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId ) import GHC.Core.Utils ( eqExpr, cheapEqExpr, exprIsHNF, exprType , stripTicksTop, stripTicksTopT, mkTicks )-import GHC.Core.SimpleOpt ( exprIsConApp_maybe ) import GHC.Core.Multiplicity import GHC.Core.FVs import GHC.Core.Type@@ -101,12 +106,12 @@ -- Int operations IntAddOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) , identityPlatform zeroi- , numFoldingRules IntAddOp intPrimOps+ , addFoldingRules IntAddOp intOps ] IntSubOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) , rightIdentityPlatform zeroi , equalArgs >> retLit zeroi- , numFoldingRules IntSubOp intPrimOps+ , subFoldingRules IntSubOp intOps ] IntAddCOp -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+)) , identityCPlatform zeroi ]@@ -116,7 +121,7 @@ IntMulOp -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) , zeroElem zeroi , identityPlatform onei- , numFoldingRules IntMulOp intPrimOps+ , mulFoldingRules IntMulOp intOps ] IntQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) , leftZero zeroi@@ -153,12 +158,12 @@ -- Word operations WordAddOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) , identityPlatform zerow- , numFoldingRules WordAddOp wordPrimOps+ , addFoldingRules WordAddOp wordOps ] WordSubOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) , rightIdentityPlatform zerow , equalArgs >> retLit zerow- , numFoldingRules WordSubOp wordPrimOps+ , subFoldingRules WordSubOp wordOps ] WordAddCOp -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+)) , identityCPlatform zerow ]@@ -167,7 +172,7 @@ , equalArgs >> retLitNoC zerow ] WordMulOp -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) , identityPlatform onew- , numFoldingRules WordMulOp wordPrimOps+ , mulFoldingRules WordMulOp wordOps ] WordQuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) , rightIdentityPlatform onew ]@@ -244,32 +249,34 @@ DoubleToFloatOp -> mkPrimOpRule nm 1 [ liftLit doubleToFloatLit ] -- Float- FloatAddOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))- , identity zerof ]- FloatSubOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))- , rightIdentity zerof ]- FloatMulOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))- , identity onef- , strengthReduction twof FloatAddOp ]+ FloatAddOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))+ , identity zerof ]+ FloatSubOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))+ , rightIdentity zerof ]+ FloatMulOp -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))+ , identity onef+ , strengthReduction twof FloatAddOp ] -- zeroElem zerof doesn't hold because of NaN- FloatDivOp -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))- , rightIdentity onef ]- FloatNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp- , inversePrimOp FloatNegOp ]+ FloatDivOp -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))+ , rightIdentity onef ]+ FloatNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp+ , inversePrimOp FloatNegOp ]+ FloatDecode_IntOp -> mkPrimOpRule nm 1 [ unaryLit floatDecodeOp ] -- Double- DoubleAddOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))- , identity zerod ]- DoubleSubOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))- , rightIdentity zerod ]- DoubleMulOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))- , identity oned- , strengthReduction twod DoubleAddOp ]+ DoubleAddOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))+ , identity zerod ]+ DoubleSubOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))+ , rightIdentity zerod ]+ DoubleMulOp -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))+ , identity oned+ , strengthReduction twod DoubleAddOp ] -- zeroElem zerod doesn't hold because of NaN- DoubleDivOp -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))- , rightIdentity oned ]- DoubleNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp- , inversePrimOp DoubleNegOp ]+ DoubleDivOp -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))+ , rightIdentity oned ]+ DoubleNegOp -> mkPrimOpRule nm 1 [ unaryLit negOp+ , inversePrimOp DoubleNegOp ]+ DoubleDecode_Int64Op -> mkPrimOpRule nm 1 [ unaryLit doubleDecodeOp ] -- Relational operators @@ -439,7 +446,7 @@ intOpC2 :: (Integral a, Integral b) => (a -> b -> Integer) -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr-intOpC2 op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) = do+intOpC2 op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) = intCResult (roPlatform env) (fromInteger i1 `op` fromInteger i2) intOpC2 _ _ _ _ = Nothing @@ -515,6 +522,15 @@ floatOp2 _ _ _ _ = Nothing --------------------------+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) ]+floatDecodeOp _ _+ = Nothing++-------------------------- doubleOp2 :: (Rational -> Rational -> Rational) -> RuleOpts -> Literal -> Literal -> Maybe (Expr CoreBndr)@@ -523,6 +539,22 @@ doubleOp2 _ _ _ _ = Nothing --------------------------+doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr+doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e)))+ = Just $ mkCoreUbxTup [iNT64Ty, intPrimTy]+ [ Lit (mkLitINT64 (roPlatform env) (toInteger m))+ , mkIntVal platform (toInteger e) ]+ where+ platform = roPlatform env+ (iNT64Ty, mkLitINT64)+ | platformWordSizeInBits platform < 64+ = (int64PrimTy, mkLitInt64Wrap)+ | otherwise+ = (intPrimTy , mkLitIntWrap)+doubleDecodeOp _ _+ = Nothing++-------------------------- {- Note [The litEq rule: converting equality to case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This stuff turns@@ -1336,7 +1368,6 @@ , rule_encodeFloat "integerEncodeFloat" integerEncodeFloatName mkFloatLitFloat , rule_convert "integerToFloat" integerToFloatName (\_ -> mkFloatLitFloat) , rule_encodeFloat "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble- , rule_decodeDouble "integerDecodeDouble" integerDecodeDoubleName , rule_convert "integerToDouble" integerToDoubleName (\_ -> mkDoubleLitDouble) , rule_binopi "integerGcd" integerGcdName gcd , rule_binopi "integerLcm" integerLcmName lcm@@ -1411,9 +1442,6 @@ rule_encodeFloat str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_Int_encodeFloat op }- rule_decodeDouble str name- = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,- ru_try = match_decodeDouble } rule_passthrough str name toIntegerName = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_passthrough toIntegerName }@@ -1747,22 +1775,6 @@ = Just (mkLit (fromRational (x % y))) match_rationalTo _ _ _ _ _ = Nothing -match_decodeDouble :: RuleFun-match_decodeDouble env id_unf fn [xl]- | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl- = case splitFunTy_maybe (idType fn) of- Just (_, _, res)- | Just [_lev1, _lev2, _integerTy, intHashTy] <- tyConAppArgs_maybe res- -> case decodeFloat (fromRational x :: Double) of- (y, z) ->- Just $ mkCoreUbxTup [integerTy, intHashTy]- [Lit (mkLitInteger y),- Lit (mkLitInt (roPlatform env) (toInteger z))]- _ ->- pprPanic "match_decodeDouble: Id has the wrong type"- (ppr fn <+> dcolon <+> ppr (idType fn))-match_decodeDouble _ _ _ _ = Nothing- match_passthrough :: Name -> RuleFun match_passthrough n _ _ _ [App (Var x) y] | idName x == n@@ -1872,181 +1884,348 @@ -- -------------------------------------------------------- --- | Rules to perform constant folding into nested expressions+-- Rules to perform constant folding into nested expressions -- --See Note [Constant folding through nested expressions]-numFoldingRules :: PrimOp -> (Platform -> PrimOps) -> RuleM CoreExpr-numFoldingRules op dict = do- env <- getEnv- if not (roNumConstantFolding env)- then mzero- else do- [e1,e2] <- getArgs- platform <- getPlatform- let PrimOps{..} = dict platform- case BinOpApp e1 op e2 of- -- R1) +/- simplification- x :++: (y :++: v) -> return $ mkL (x+y) `add` v- x :++: (L y :-: v) -> return $ mkL (x+y) `sub` v- x :++: (v :-: L y) -> return $ mkL (x-y) `add` v- L x :-: (y :++: v) -> return $ mkL (x-y) `sub` v- L x :-: (L y :-: v) -> return $ mkL (x-y) `add` v- L x :-: (v :-: L y) -> return $ mkL (x+y) `sub` v - (y :++: v) :-: L x -> return $ mkL (y-x) `add` v- (L y :-: v) :-: L x -> return $ mkL (y-x) `sub` v- (v :-: L y) :-: L x -> return $ mkL (0-y-x) `add` v+addFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr+addFoldingRules op num_ops = do+ ASSERT(op == numAdd num_ops) return ()+ env <- getEnv+ guard (roNumConstantFolding env)+ [arg1,arg2] <- getArgs+ platform <- getPlatform+ liftMaybe+ -- commutativity for + is handled here+ (addFoldingRules' platform arg1 arg2 num_ops+ <|> addFoldingRules' platform arg2 arg1 num_ops) - (x :++: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (w `add` v)- (w :-: L x) :+: (L y :-: v) -> return $ mkL (y-x) `add` (w `sub` v)- (w :-: L x) :+: (v :-: L y) -> return $ mkL (0-x-y) `add` (w `add` v)- (L x :-: w) :+: (L y :-: v) -> return $ mkL (x+y) `sub` (w `add` v)- (L x :-: w) :+: (v :-: L y) -> return $ mkL (x-y) `add` (v `sub` w)- (w :-: L x) :+: (y :++: v) -> return $ mkL (y-x) `add` (w `add` v)- (L x :-: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (v `sub` w)- (y :++: v) :+: (w :-: L x) -> return $ mkL (y-x) `add` (w `add` v)- (y :++: v) :+: (L x :-: w) -> return $ mkL (x+y) `add` (v `sub` w)+subFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr+subFoldingRules op num_ops = do+ ASSERT(op == numSub num_ops) return ()+ env <- getEnv+ guard (roNumConstantFolding env)+ [arg1,arg2] <- getArgs+ platform <- getPlatform+ liftMaybe (subFoldingRules' platform arg1 arg2 num_ops) - (v :-: L y) :-: (w :-: L x) -> return $ mkL (x-y) `add` (v `sub` w)- (v :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `add` (v `add` w)- (L y :-: v) :-: (w :-: L x) -> return $ mkL (x+y) `sub` (v `add` w)- (L y :-: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (w `sub` v)- (x :++: w) :-: (y :++: v) -> return $ mkL (x-y) `add` (w `sub` v)- (w :-: L x) :-: (y :++: v) -> return $ mkL (0-y-x) `add` (w `sub` v)- (L x :-: w) :-: (y :++: v) -> return $ mkL (x-y) `sub` (v `add` w)- (y :++: v) :-: (w :-: L x) -> return $ mkL (y+x) `add` (v `sub` w)- (y :++: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (v `add` w)+mulFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr+mulFoldingRules op num_ops = do+ ASSERT(op == numMul num_ops) return ()+ env <- getEnv+ guard (roNumConstantFolding env)+ [arg1,arg2] <- getArgs+ platform <- getPlatform+ liftMaybe+ -- commutativity for * is handled here+ (mulFoldingRules' platform arg1 arg2 num_ops+ <|> mulFoldingRules' platform arg2 arg1 num_ops) - -- R2) * simplification- x :**: (y :**: v) -> return $ mkL (x*y) `mul` v- (x :**: w) :*: (y :**: v) -> return $ mkL (x*y) `mul` (w `mul` v) - -- R3) * distribution over +/-- x :**: (y :++: v) -> return $ mkL (x*y) `add` (mkL x `mul` v)- x :**: (L y :-: v) -> return $ mkL (x*y) `sub` (mkL x `mul` v)- x :**: (v :-: L y) -> return $ (mkL x `mul` v) `sub` mkL (x*y)+addFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+addFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of+ -- R1) +/- simplification - -- R4) Simple factorization- v :+: w- | w `cheapEqExpr` v -> return $ mkL 2 `mul` v- w :+: (y :**: v)- | w `cheapEqExpr` v -> return $ mkL (1+y) `mul` v- w :-: (y :**: v)- | w `cheapEqExpr` v -> return $ mkL (1-y) `mul` v- (y :**: v) :+: w- | w `cheapEqExpr` v -> return $ mkL (y+1) `mul` v- (y :**: v) :-: w- | w `cheapEqExpr` v -> return $ mkL (y-1) `mul` v- (x :**: w) :+: (y :**: v)- | w `cheapEqExpr` v -> return $ mkL (x+y) `mul` v- (x :**: w) :-: (y :**: v)- | w `cheapEqExpr` v -> return $ mkL (x-y) `mul` v+ -- l1 + (l2 + x) ==> (l1+l2) + x+ (L l1, is_lit_add num_ops -> Just (l2,x))+ -> Just (mkL (l1+l2) `add` x) - -- R5) +/- propagation- w :+: (y :++: v) -> return $ mkL y `add` (w `add` v)- (y :++: v) :+: w -> return $ mkL y `add` (w `add` v)- w :-: (y :++: v) -> return $ (w `sub` v) `sub` mkL y- (y :++: v) :-: w -> return $ mkL y `add` (v `sub` w)- w :-: (L y :-: v) -> return $ (w `add` v) `sub` mkL y- (L y :-: v) :-: w -> return $ mkL y `sub` (w `add` v)- w :+: (L y :-: v) -> return $ mkL y `add` (w `sub` v)- w :+: (v :-: L y) -> return $ (w `add` v) `sub` mkL y- (L y :-: v) :+: w -> return $ mkL y `add` (w `sub` v)- (v :-: L y) :+: w -> return $ (w `add` v) `sub` mkL y+ -- l1 + (l2 - x) ==> (l1+l2) - x+ (L l1, is_sub num_ops -> Just (L l2,x))+ -> Just (mkL (l1+l2) `sub` x) - _ -> mzero+ -- l1 + (x - l2) ==> (l1-l2) + x+ (L l1, is_sub num_ops -> Just (x,L l2))+ -> Just (mkL (l1-l2) `add` x) + -- (l1 + x) + (l2 + y) ==> (l1+l2) + (x+y)+ (is_lit_add num_ops -> Just (l1,x), is_lit_add num_ops -> Just (l2,y))+ -> Just (mkL (l1+l2) `add` (x `add` y)) + -- (l1 + x) + (l2 - y) ==> (l1+l2) + (x-y)+ (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (L l2,y))+ -> Just (mkL (l1+l2) `add` (x `sub` y)) --- | Match the application of a binary primop-pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr-pattern BinOpApp x op y = OpVal op `App` x `App` y+ -- (l1 + x) + (y - l2) ==> (l1-l2) + (x+y)+ (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (y,L l2))+ -> Just (mkL (l1-l2) `add` (x `add` y)) --- | Match a primop-pattern OpVal :: PrimOp -> Arg CoreBndr-pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where- OpVal op = Var (mkPrimOpId op)+ -- (l1 - x) + (l2 - y) ==> (l1+l2) - (x+y)+ (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (L l2,y))+ -> Just (mkL (l1+l2) `sub` (x `add` y)) + -- (l1 - x) + (y - l2) ==> (l1-l2) + (y-x)+ (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (y,L l2))+ -> Just (mkL (l1-l2) `add` (y `sub` x)) + -- (x - l1) + (y - l2) ==> (0-l1-l2) + (x+y)+ (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (y,L l2))+ -> Just (mkL (0-l1-l2) `add` (x `add` y)) --- | Match a literal-pattern L :: Integer -> Arg CoreBndr-pattern L l <- Lit (isLitValue_maybe -> Just l)+ -- R4) Simple factorization --- | Match an addition-pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr-pattern x :+: y <- BinOpApp x (isAddOp -> True) y+ -- x + x ==> 2 * x+ _ | Just l1 <- is_expr_mul num_ops arg1 arg2+ -> Just (mkL (l1+1) `mul` arg1) --- | Match an addition with a literal (handle commutativity)-pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr-pattern l :++: x <- (isAdd -> Just (l,x))+ -- (l1 * x) + x ==> (l1+1) * x+ _ | Just l1 <- is_expr_mul num_ops arg2 arg1+ -> Just (mkL (l1+1) `mul` arg2) -isAdd :: CoreExpr -> Maybe (Integer,CoreExpr)-isAdd e = case e of- L l :+: x -> Just (l,x)- x :+: L l -> Just (l,x)- _ -> Nothing+ -- (l1 * x) + (l2 * x) ==> (l1+l2) * x+ (is_lit_mul num_ops -> Just (l1,x), is_expr_mul num_ops x -> Just l2)+ -> Just (mkL (l1+l2) `mul` x) --- | Match a multiplication-pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr-pattern x :*: y <- BinOpApp x (isMulOp -> True) y+ -- R5) +/- propagation: these transformations push literals outwards+ -- with the hope that other rules can then be applied. --- | Match a multiplication with a literal (handle commutativity)-pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr-pattern l :**: x <- (isMul -> Just (l,x))+ -- In the following rules, x can't be a literal otherwise another+ -- rule would have combined it with the other literal in arg2. So we+ -- don't have to check this to avoid loops here. -isMul :: CoreExpr -> Maybe (Integer,CoreExpr)-isMul e = case e of- L l :*: x -> Just (l,x)- x :*: L l -> Just (l,x)- _ -> Nothing+ -- x + (l1 + y) ==> l1 + (x + y)+ (_, is_lit_add num_ops -> Just (l1,y))+ -> Just (mkL l1 `add` (arg1 `add` y)) + -- x + (l1 - y) ==> l1 + (x - y)+ (_, is_sub num_ops -> Just (L l1,y))+ -> Just (mkL l1 `add` (arg1 `sub` y)) --- | Match a subtraction-pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr-pattern x :-: y <- BinOpApp x (isSubOp -> True) y+ -- x + (y - l1) ==> (x + y) - l1+ (_, is_sub num_ops -> Just (y,L l1))+ -> Just ((arg1 `add` y) `sub` mkL l1) -isSubOp :: PrimOp -> Bool-isSubOp IntSubOp = True-isSubOp WordSubOp = True-isSubOp _ = False+ _ -> Nothing -isAddOp :: PrimOp -> Bool-isAddOp IntAddOp = True-isAddOp WordAddOp = True-isAddOp _ = False+ where+ mkL = Lit . mkNumLiteral platform num_ops+ add x y = BinOpApp x (numAdd num_ops) y+ sub x y = BinOpApp x (numSub num_ops) y+ mul x y = BinOpApp x (numMul num_ops) y -isMulOp :: PrimOp -> Bool-isMulOp IntMulOp = True-isMulOp WordMulOp = True-isMulOp _ = False+subFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+subFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of+ -- R1) +/- simplification + -- l1 - (l2 + x) ==> (l1-l2) - x+ (L l1, is_lit_add num_ops -> Just (l2,x))+ -> Just (mkL (l1-l2) `sub` x)++ -- l1 - (l2 - x) ==> (l1-l2) + x+ (L l1, is_sub num_ops -> Just (L l2,x))+ -> Just (mkL (l1-l2) `add` x)++ -- l1 - (x - l2) ==> (l1+l2) - x+ (L l1, is_sub num_ops -> Just (x, L l2))+ -> Just (mkL (l1+l2) `sub` x)++ -- (l1 + x) - l2 ==> (l1-l2) + x+ (is_lit_add num_ops -> Just (l1,x), L l2)+ -> Just (mkL (l1-l2) `add` x)++ -- (l1 - x) - l2 ==> (l1-l2) - x+ (is_sub num_ops -> Just (L l1,x), L l2)+ -> Just (mkL (l1-l2) `sub` x)++ -- (x - l1) - l2 ==> x - (l1+l2)+ (is_sub num_ops -> Just (x,L l1), L l2)+ -> Just (x `sub` mkL (l1+l2))+++ -- (l1 + x) - (l2 + y) ==> (l1-l2) + (x-y)+ (is_lit_add num_ops -> Just (l1,x), is_lit_add num_ops -> Just (l2,y))+ -> Just (mkL (l1-l2) `add` (x `sub` y))++ -- (l1 + x) - (l2 - y) ==> (l1-l2) + (x+y)+ (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (L l2,y))+ -> Just (mkL (l1-l2) `add` (x `add` y))++ -- (l1 + x) - (y - l2) ==> (l1+l2) + (x-y)+ (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (y,L l2))+ -> Just (mkL (l1+l2) `add` (x `sub` y))++ -- (l1 - x) - (l2 + y) ==> (l1-l2) - (x+y)+ (is_sub num_ops -> Just (L l1,x), is_lit_add num_ops -> Just (l2,y))+ -> Just (mkL (l1-l2) `sub` (x `add` y))++ -- (x - l1) - (l2 + y) ==> (0-l1-l2) + (x-y)+ (is_sub num_ops -> Just (x,L l1), is_lit_add num_ops -> Just (l2,y))+ -> Just (mkL (0-l1-l2) `add` (x `sub` y))++ -- (l1 - x) - (l2 - y) ==> (l1-l2) + (y-x)+ (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (L l2,y))+ -> Just (mkL (l1-l2) `add` (y `sub` x))++ -- (l1 - x) - (y - l2) ==> (l1+l2) - (x+y)+ (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (y,L l2))+ -> Just (mkL (l1+l2) `sub` (x `add` y))++ -- (x - l1) - (l2 - y) ==> (0-l1-l2) + (x+y)+ (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (L l2,y))+ -> Just (mkL (0-l1-l2) `add` (x `add` y))++ -- (x - l1) - (y - l2) ==> (l2-l1) + (x-y)+ (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (y,L l2))+ -> Just (mkL (l2-l1) `add` (x `sub` y))++ -- R4) Simple factorization++ -- x - (l1 * x) ==> (1-l1) * x+ _ | Just l1 <- is_expr_mul num_ops arg1 arg2+ -> Just (mkL (1-l1) `mul` arg1)++ -- (l1 * x) - x ==> (l1-1) * x+ _ | Just l1 <- is_expr_mul num_ops arg2 arg1+ -> Just (mkL (l1-1) `mul` arg2)++ -- (l1 * x) - (l2 * x) ==> (l1-l2) * x+ (is_lit_mul num_ops -> Just (l1,x), is_expr_mul num_ops x -> Just l2)+ -> Just (mkL (l1-l2) `mul` x)++ -- R5) +/- propagation: these transformations push literals outwards+ -- with the hope that other rules can then be applied.++ -- In the following rules, x can't be a literal otherwise another+ -- rule would have combined it with the other literal in arg2. So we+ -- don't have to check this to avoid loops here.++ -- x - (l1 + y) ==> (x - y) - l1+ (_, is_lit_add num_ops -> Just (l1,y))+ -> Just ((arg1 `sub` y) `sub` mkL l1)++ -- (l1 + x) - y ==> l1 + (x - y)+ (is_lit_add num_ops -> Just (l1,x), _)+ -> Just (mkL l1 `add` (x `sub` arg2))++ -- x - (l1 - y) ==> (x + y) - l1+ (_, is_sub num_ops -> Just (L l1,y))+ -> Just ((arg1 `add` y) `sub` mkL l1)++ -- x - (y - l1) ==> l1 + (x - y)+ (_, is_sub num_ops -> Just (y,L l1))+ -> Just (mkL l1 `add` (arg1 `sub` y))++ -- (l1 - x) - y ==> l1 - (x + y)+ (is_sub num_ops -> Just (L l1,x), _)+ -> Just (mkL l1 `sub` (x `add` arg2))++ -- (x - l1) - y ==> (x - y) - l1+ (is_sub num_ops -> Just (x,L l1), _)+ -> Just ((x `sub` arg2) `sub` mkL l1)++ _ -> Nothing+ where+ mkL = Lit . mkNumLiteral platform num_ops+ add x y = BinOpApp x (numAdd num_ops) y+ sub x y = BinOpApp x (numSub num_ops) y+ mul x y = BinOpApp x (numMul num_ops) y++mulFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+mulFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of+ -- l1 * (l2 * x) ==> (l1*l2) * x+ (L l1, is_lit_mul num_ops -> Just (l2,x))+ -> Just (mkL (l1*l2) `mul` x)++ -- l1 * (l2 + x) ==> (l1*l2) + (l1 * x)+ (L l1, is_lit_add num_ops -> Just (l2,x))+ -> Just (mkL (l1*l2) `add` (arg1 `mul` x))++ -- l1 * (l2 - x) ==> (l1*l2) - (l1 * x)+ (L l1, is_sub num_ops -> Just (L l2,x))+ -> Just (mkL (l1*l2) `sub` (arg1 `mul` x))++ -- l1 * (x - l2) ==> (l1 * x) - (l1*l2)+ (L l1, is_sub num_ops -> Just (x, L l2))+ -> Just ((arg1 `mul` x) `sub` mkL (l1*l2))++ -- (l1 * x) * (l2 * y) ==> (l1*l2) * (x * y)+ (is_lit_mul num_ops -> Just (l1,x), is_lit_mul num_ops -> Just (l2,y))+ -> Just (mkL (l1*l2) `mul` (x `mul` y))++ _ -> Nothing+ where+ mkL = Lit . mkNumLiteral platform num_ops+ add x y = BinOpApp x (numAdd num_ops) y+ sub x y = BinOpApp x (numSub num_ops) y+ mul x y = BinOpApp x (numMul num_ops) y++is_op :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)+is_op op e = case e of+ BinOpApp x op' y | op == op' -> Just (x,y)+ _ -> Nothing++is_add, is_sub, is_mul :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)+is_add num_ops = is_op (numAdd num_ops)+is_sub num_ops = is_op (numSub num_ops)+is_mul num_ops = is_op (numMul num_ops)++-- match addition with a literal (handles commutativity)+is_lit_add :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)+is_lit_add num_ops e = case is_add num_ops e of+ Just (L l, x ) -> Just (l,x)+ Just (x , L l) -> Just (l,x)+ _ -> Nothing++-- match multiplication with a literal (handles commutativity)+is_lit_mul :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)+is_lit_mul num_ops e = case is_mul num_ops e of+ Just (L l, x ) -> Just (l,x)+ Just (x , L l) -> Just (l,x)+ _ -> Nothing++-- match given "x": return 1+-- match "lit * x": return lit value (handles commutativity)+is_expr_mul :: NumOps -> Expr CoreBndr -> Expr CoreBndr -> Maybe Integer+is_expr_mul num_ops x e = if+ | x `cheapEqExpr` e+ -> Just 1+ | Just (k,x') <- is_lit_mul num_ops e+ , x `cheapEqExpr` x'+ -> return k+ | otherwise+ -> Nothing+++-- | Match the application of a binary primop+pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr+pattern BinOpApp x op y = OpVal op `App` x `App` y++-- | Match a primop+pattern OpVal:: PrimOp -> Arg CoreBndr+pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where+ OpVal op = Var (mkPrimOpId op)++-- | Match a literal+pattern L :: Integer -> Arg CoreBndr+pattern L i <- Lit (LitNumber _ i)+ -- | Explicit "type-class"-like dictionary for numeric primops------ Depends on Platform because creating a literal value depends on Platform-data PrimOps = PrimOps- { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers- , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers- , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers- , mkL :: Integer -> CoreExpr -- ^ Create a literal value+data NumOps = NumOps+ { numAdd :: !PrimOp -- ^ Add two numbers+ , numSub :: !PrimOp -- ^ Sub two numbers+ , numMul :: !PrimOp -- ^ Multiply two numbers+ , numLitType :: !LitNumType -- ^ Literal type } -intPrimOps :: Platform -> PrimOps-intPrimOps platform = PrimOps- { add = \x y -> BinOpApp x IntAddOp y- , sub = \x y -> BinOpApp x IntSubOp y- , mul = \x y -> BinOpApp x IntMulOp y- , mkL = intResult' platform- }+-- | Create a numeric literal+mkNumLiteral :: Platform -> NumOps -> Integer -> Literal+mkNumLiteral platform ops i = mkLitNumberWrap platform (numLitType ops) i -wordPrimOps :: Platform -> PrimOps-wordPrimOps platform = PrimOps- { add = \x y -> BinOpApp x WordAddOp y- , sub = \x y -> BinOpApp x WordSubOp y- , mul = \x y -> BinOpApp x WordMulOp y- , mkL = wordResult' platform+intOps :: NumOps+intOps = NumOps+ { numAdd = IntAddOp+ , numSub = IntSubOp+ , numMul = IntMulOp+ , numLitType = LitNumInt } +wordOps :: NumOps+wordOps = NumOps+ { numAdd = WordAddOp+ , numSub = WordSubOp+ , numMul = WordMulOp+ , numLitType = LitNumWord+ } -------------------------------------------------------- -- Constant folding through case-expressions@@ -2076,14 +2255,14 @@ caseRules platform (App (App (Var f) v) (Lit l)) -- v `op` x# | Just op <- isPrimOpId_maybe f- , Just x <- isLitValue_maybe l+ , LitNumber _ x <- l , Just adjust_lit <- adjustDyadicRight op x = Just (v, tx_lit_con platform adjust_lit , \v -> (App (App (Var f) (Var v)) (Lit l))) caseRules platform (App (App (Var f) (Lit l)) v) -- x# `op` v | Just op <- isPrimOpId_maybe f- , Just x <- isLitValue_maybe l+ , LitNumber _ x <- l , Just adjust_lit <- adjustDyadicLeft x op = Just (v, tx_lit_con platform adjust_lit , \v -> (App (App (Var f) (Lit l)) (Var v)))
compiler/GHC/Core/Opt/Monad.hs view
@@ -50,27 +50,33 @@ import GHC.Prelude hiding ( read ) +import GHC.Driver.Session+import GHC.Driver.Env+ import GHC.Core import GHC.Core.Unfold-import GHC.Driver.Types-import GHC.Unit.Module-import GHC.Driver.Session+ import GHC.Types.Basic ( CompilerPhase(..) ) import GHC.Types.Annotations--import GHC.Data.IOEnv hiding ( liftIO, failM, failWithM )-import qualified GHC.Data.IOEnv as IOEnv import GHC.Types.Var-import GHC.Utils.Outputable as Outputable-import GHC.Data.FastString-import GHC.Utils.Error( Severity(..), DumpFormat (..), dumpOptionsFromFlag ) import GHC.Types.Unique (uniqFromMask) import GHC.Types.Unique.Supply-import GHC.Utils.Monad import GHC.Types.Name.Env import GHC.Types.SrcLoc++import GHC.Utils.Outputable as Outputable+import GHC.Utils.Error ( Severity(..), DumpFormat (..), dumpAction, dumpOptionsFromFlag )+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.Unit.Module+import GHC.Unit.Module.ModGuts+import GHC.Unit.External+ import Data.Bifunctor ( bimap )-import GHC.Utils.Error (dumpAction) import Data.List (intersperse, groupBy, sortBy) import Data.Ord import Data.Dynamic
compiler/GHC/Core/Opt/OccurAnal.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -11,9 +17,6 @@ core expression with (hopefully) improved usage information. -} -{-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) where #include "GhclibHsVersions.h"@@ -1690,14 +1693,16 @@ occAnalUnfolding env is_rec mb_join_arity unf = case unf of unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })- | isStableSource src -> (usage, unf')- | otherwise -> (emptyDetails, unf)- where -- For non-Stable unfoldings we leave them undisturbed, but+ | isStableSource src -> (markAllMany usage, unf')+ -- markAllMany: see Note [Occurrences in stable unfoldings]+ | otherwise -> (emptyDetails, unf)+ -- For non-Stable unfoldings we leave them undisturbed, but -- don't count their usage because the simplifier will discard them. -- We leave them undisturbed because nodeScore uses their size info -- to guide its decisions. It's ok to leave un-substituted -- expressions in the tree because all the variables that were in -- scope remain in scope; there is no cloning etc.+ where (usage, rhs') = occAnalRhs env is_rec mb_join_arity rhs unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]@@ -1755,6 +1760,28 @@ the FloatIn pass knows to float into join point RHSs; and the simplifier does not float things out of join point RHSs. But it's a simple, cheap thing to do. See #14137.++Note [Occurrences in stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ f p = BIG+ {-# INLINE g #-}+ g y = not (f y)+where this is the /only/ occurrence of 'f'. So 'g' will get a stable+unfolding. Now suppose that g's RHS gets optimised (perhaps by a rule+or inlining f) so that it doesn't mention 'f' any more. Now the last+remaining call to f is in g's Stable unfolding. But, even though there+is only one syntactic occurrence of f, we do /not/ want to do+preinlineUnconditionally here!++The INLINE pragma says "inline exactly this RHS"; perhaps the+programmer wants to expose that 'not', say. If we inline f that will make+the Stable unfoldign big, and that wasn't what the programmer wanted.++Another way to think about it: if we inlined g as-is into multiple+call sites, now there's be multiple calls to f.++Bottom line: treat all occurrences in a stable unfolding as "Many". Note [Unfoldings and rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~
− compiler/GHC/Core/PatSyn.hs-boot
@@ -1,13 +0,0 @@-module GHC.Core.PatSyn where--import GHC.Types.Basic (Arity)-import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type)-import GHC.Types.Var (TyVar)-import GHC.Types.Name (Name)--data PatSyn--patSynArity :: PatSyn -> Arity-patSynInstArgTys :: PatSyn -> [Type] -> [Type]-patSynExTyVars :: PatSyn -> [TyVar]-patSynName :: PatSyn -> Name
compiler/GHC/Core/Ppr.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+ {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1996-1998@@ -5,10 +8,6 @@ Printing of Core syntax -}--{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE LambdaCase #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.Core.Ppr ( pprCoreExpr, pprParendExpr,
compiler/GHC/Core/Predicate.hs view
@@ -34,6 +34,7 @@ import GHC.Core.Type import GHC.Core.Class import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk import GHC.Types.Var import GHC.Core.Coercion import GHC.Core.Multiplicity ( scaledThing )
compiler/GHC/Core/SimpleOpt.hs view
@@ -1279,13 +1279,24 @@ -> Just l Var v | Just rhs <- expandUnfolding_maybe (id_unf v)- , Just (_env,_fb,dc,_tys,[arg]) <- exprIsConApp_maybe env rhs+ , Just b <- matchBignum env rhs+ -> Just b+ e+ | Just b <- matchBignum env e+ -> Just b++ | otherwise+ -> Nothing+ where+ matchBignum env e+ | Just (_env,_fb,dc,_tys,[arg]) <- exprIsConApp_maybe env e , Just (LitNumber _ i) <- exprIsLiteral_maybe env arg- -> if+ = if | dc == naturalNSDataCon -> Just (mkLitNatural i) | dc == integerISDataCon -> Just (mkLitInteger i) | otherwise -> Nothing- _ -> Nothing+ | otherwise+ = Nothing {- Note [exprIsLambda_maybe]
compiler/GHC/Core/TyCo/Ppr.hs view
@@ -22,9 +22,6 @@ pprCo, pprParendCo, debugPprType,-- -- * Pretty-printing 'TyThing's- pprTyThingCategory, pprShortTyThing, ) where import GHC.Prelude@@ -79,7 +76,7 @@ -------------------------------------------------------- -- When pretty-printing types, we convert to IfaceType, -- and pretty-print that.--- See Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing+-- See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr -------------------------------------------------------- pprType, pprParendType, pprTidiedType :: Type -> SDoc
compiler/GHC/Core/TyCo/Rep.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}++{-# OPTIONS_HADDOCK not-home #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1998@@ -18,11 +23,7 @@ -} -- We expose the relevant stuff from this module via the Type module-{-# OPTIONS_HADDOCK not-home #-}-{-# LANGUAGE CPP, MultiWayIf, PatternSynonyms, BangPatterns, DeriveDataTypeable #-}- module GHC.Core.TyCo.Rep (- TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, -- * Types Type(..),@@ -81,13 +82,10 @@ -- Transitively pulls in a LOT of stuff, better to break the loop -import {-# SOURCE #-} GHC.Core.ConLike ( ConLike(..), conLikeName )- -- friends: import GHC.Iface.Type import GHC.Types.Var import GHC.Types.Var.Set-import GHC.Types.Name hiding ( varName ) import GHC.Core.TyCon import GHC.Core.Coercion.Axiom @@ -105,66 +103,6 @@ import qualified Data.Data as Data hiding ( TyCon ) import Data.IORef ( IORef ) -- for CoercionHole -{--%************************************************************************-%* *- TyThing-%* *-%************************************************************************--Despite the fact that DataCon has to be imported via a hi-boot route,-this module seems the right place for TyThing, because it's needed for-funTyCon and all the types in GHC.Builtin.Types.Prim.--It is also SOURCE-imported into "GHC.Types.Name"---Note [ATyCon for classes]-~~~~~~~~~~~~~~~~~~~~~~~~~-Both classes and type constructors are represented in the type environment-as ATyCon. You can tell the difference, and get to the class, with- isClassTyCon :: TyCon -> Bool- tyConClass_maybe :: TyCon -> Maybe Class-The Class and its associated TyCon have the same Name.--}---- | A global typecheckable-thing, essentially anything that has a name.--- Not to be confused with a 'TcTyThing', which is also a typecheckable--- thing but in the *local* context. See "GHC.Tc.Utils.Env" for how to retrieve--- a 'TyThing' given a 'Name'.-data TyThing- = AnId Id- | AConLike ConLike- | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes]- | ACoAxiom (CoAxiom Branched)--instance Outputable TyThing where- ppr = pprShortTyThing--instance NamedThing TyThing where -- Can't put this with the type- getName (AnId id) = getName id -- decl, because the DataCon instance- getName (ATyCon tc) = getName tc -- isn't visible there- getName (ACoAxiom cc) = getName cc- getName (AConLike cl) = conLikeName cl--pprShortTyThing :: TyThing -> SDoc--- c.f. GHC.Core.Ppr.TyThing.pprTyThing, which prints all the details-pprShortTyThing thing- = pprTyThingCategory thing <+> quotes (ppr (getName thing))--pprTyThingCategory :: TyThing -> SDoc-pprTyThingCategory = text . capitalise . tyThingCategory--tyThingCategory :: TyThing -> String-tyThingCategory (ATyCon tc)- | isClassTyCon tc = "class"- | otherwise = "type constructor"-tyThingCategory (ACoAxiom _) = "coercion axiom"-tyThingCategory (AnId _) = "identifier"-tyThingCategory (AConLike (RealDataCon _)) = "data constructor"-tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym"-- {- ********************************************************************** * * Type@@ -547,6 +485,12 @@ This principle also tells us that eqType must relate only types with the same kinds. +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).@@ -1132,19 +1076,11 @@ -- These ones mirror the shape of types = -- Refl :: _ -> N+ -- A special case reflexivity for a very common case: Nominal reflexivity+ -- If you need Representational, use (GRefl Representational ty MRefl)+ -- not (SubCo (Refl ty)) Refl Type -- See Note [Refl invariant]- -- Invariant: applications of (Refl T) to a bunch of identity coercions- -- always show up as Refl.- -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). - -- Applications of (Refl T) to some coercions, at least one of- -- which is NOT the identity, show up as TyConAppCo.- -- (They may not be fully saturated however.)- -- ConAppCo coercions (like all coercions other than Refl)- -- are NEVER the identity.-- -- Use (GRefl Representational ty MRefl), not (SubCo (Refl ty))- -- GRefl :: "e" -> _ -> Maybe N -> e -- See Note [Generalized reflexive coercion] | GRefl Role Type MCoercionN -- See Note [Refl invariant]@@ -1252,26 +1188,30 @@ ppr MRefl = text "MRefl" ppr (MCo co) = text "MCo" <+> ppr co -{--Note [Refl invariant]-~~~~~~~~~~~~~~~~~~~~~-Invariant 1:+{- Note [Refl invariant]+~~~~~~~~~~~~~~~~~~~~~~~~+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)). -Coercions have the following invariant- Refl (similar for GRefl r ty MRefl) is always lifted as far as possible.+ You might think that a consequences is:+ Every identity coercion has Refl at the root -You might think that a consequences is:- Every identity coercions has Refl at the root+ But that's not quite true because of coercion variables. Consider+ g where g :: Int~Int+ Left h where h :: Maybe Int ~ Maybe Int+ etc. So the consequence is only true of coercions that+ have no coercion variables. -But that's not quite true because of coercion variables. Consider- g where g :: Int~Int- Left h where h :: Maybe Int ~ Maybe Int-etc. So the consequence is only true of coercions that-have no coercion variables.+Invariant 2: TyConAppCo+ An application of (Refl T) to some coercions, at least one of which is+ NOT the identity, is normalised to TyConAppCo. (They may not be+ fully saturated however.) TyConAppCo coercions (like all coercions+ other than Refl) are NEVER the identity. Note [Generalized reflexive coercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- GRefl is a generalized reflexive coercion (see #15192). It wraps a kind coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing rules for GRefl:@@ -2032,7 +1972,7 @@ -- | A shorthand for data with an attached 'Mult' element (the multiplicity). data Scaled a = Scaled Mult a deriving (Data.Data)- -- You might think that this would be a natural candiate for+ -- You might think that this would be a natural candidate for -- Functor, Traversable but Krzysztof says (!3674) "it was too easy -- to accidentally lift functions (substitutions, zonking etc.) from -- Type -> Type to Scaled Type -> Scaled Type, ignoring
compiler/GHC/Core/TyCo/Rep.hs-boot view
@@ -5,7 +5,6 @@ import {-# SOURCE #-} GHC.Types.Var( Var, ArgFlag, AnonArgFlag ) data Type-data TyThing data Coercion data UnivCoProvenance data TyLit
compiler/GHC/Core/TyCo/Subst.hs view
@@ -436,8 +436,8 @@ zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv zipTyEnv tyvars tys | debugIsOn- , not (all isTyVar tyvars)- = pprPanic "zipTyEnv" (ppr tyvars <+> ppr tys)+ , not (all isTyVar tyvars && (tyvars `equalLength` tys))+ = pprPanic "zipTyEnv" (ppr tyvars $$ ppr tys) | otherwise = ASSERT( all (not . isCoercionTy) tys ) zipToUFM tyvars tys
compiler/GHC/Core/TyCon.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,9 +10,6 @@ The @TyCon@ datatype -} -{-# LANGUAGE CPP, FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}- module GHC.Core.TyCon( -- * Main TyCon data types TyCon,@@ -126,10 +127,6 @@ primRepsCompatible, primRepCompatible, - -- * Recursion breaking- RecTcChecker, initRecTc, defaultRecTcMaxBound,- setRecTcMaxBound, checkRecTc- ) where #include "GhclibHsVersions.h"@@ -227,8 +224,8 @@ * Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon -* The user does not see any "equivalent types" as he did with type- synonym families. He just sees constructors with types+* 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 @@ -2709,83 +2706,6 @@ 0 -> return NotInjective _ -> do { xs <- get bh ; return (Injective xs) } }--{--************************************************************************-* *- Walking over recursive TyCons-* *-************************************************************************--Note [Expanding newtypes and products]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When expanding a type to expose a data-type constructor, we need to be-careful about newtypes, lest we fall into an infinite loop. Here are-the key examples:-- newtype Id x = MkId x- newtype Fix f = MkFix (f (Fix f))- newtype T = MkT (T -> T)-- Type Expansion- --------------------------- T T -> T- Fix Maybe Maybe (Fix Maybe)- Id (Id Int) Int- Fix Id NO NO NO--Notice that- * We can expand T, even though it's recursive.- * We can expand Id (Id Int), even though the Id shows up- twice at the outer level, because Id is non-recursive--So, when expanding, we keep track of when we've seen a recursive-newtype at outermost level; and bail out if we see it again.--We sometimes want to do the same for product types, so that the-strictness analyser doesn't unbox infinitely deeply.--More precisely, we keep a *count* of how many times we've seen it.-This is to account for- data instance T (a,b) = MkT (T a) (T b)-Then (#10482) if we have a type like- T (Int,(Int,(Int,(Int,Int))))-we can still unbox deeply enough during strictness analysis.-We have to treat T as potentially recursive, but it's still-good to be able to unwrap multiple layers.--The function that manages all this is checkRecTc.--}--data RecTcChecker = RC !Int (NameEnv Int)- -- The upper bound, and the number of times- -- we have encountered each TyCon---- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'.-initRecTc :: RecTcChecker-initRecTc = RC defaultRecTcMaxBound emptyNameEnv---- | The default upper bound (100) for the number of times a 'RecTcChecker' is--- allowed to encounter each 'TyCon'.-defaultRecTcMaxBound :: Int-defaultRecTcMaxBound = 100--- Should we have a flag for this?---- | Change the upper bound for the number of times a 'RecTcChecker' is allowed--- to encounter each 'TyCon'.-setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker-setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts--checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker--- Nothing => Recursion detected--- Just rec_tcs => Keep going-checkRecTc (RC bound rec_nts) tc- = case lookupNameEnv rec_nts tc_name of- Just n | n >= bound -> Nothing- | otherwise -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1)))- Nothing -> Just (RC bound (extendNameEnv rec_nts tc_name 1))- where- tc_name = tyConName tc -- | Returns whether or not this 'TyCon' is definite, or a hole -- that may be filled in at some later point. See Note [Skolem abstract data]
+ compiler/GHC/Core/TyCon/Env.hs view
@@ -0,0 +1,138 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TyConEnv]{@TyConEnv@: tyCon environments}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+++module GHC.Core.TyCon.Env (+ -- * TyCon environment (map)+ TyConEnv,++ -- ** Manipulating these environments+ mkTyConEnv, mkTyConEnvWith,+ emptyTyConEnv, isEmptyTyConEnv,+ unitTyConEnv, nameEnvElts,+ extendTyConEnv_C, extendTyConEnv_Acc, extendTyConEnv,+ extendTyConEnvList, extendTyConEnvList_C,+ filterTyConEnv, anyTyConEnv,+ plusTyConEnv, plusTyConEnv_C, plusTyConEnv_CD, plusTyConEnv_CD2, alterTyConEnv,+ lookupTyConEnv, lookupTyConEnv_NF, delFromTyConEnv, delListFromTyConEnv,+ elemTyConEnv, mapTyConEnv, disjointTyConEnv,++ DTyConEnv,++ emptyDTyConEnv,+ lookupDTyConEnv,+ delFromDTyConEnv, filterDTyConEnv,+ mapDTyConEnv,+ adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv,+ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import GHC.Core.TyCon (TyCon)++import GHC.Data.Maybe++{-+************************************************************************+* *+\subsection{TyCon environment}+* *+************************************************************************+-}++-- | TyCon Environment+type TyConEnv a = UniqFM TyCon a -- Domain is TyCon++emptyTyConEnv :: TyConEnv a+isEmptyTyConEnv :: TyConEnv a -> Bool+mkTyConEnv :: [(TyCon,a)] -> TyConEnv a+mkTyConEnvWith :: (a -> TyCon) -> [a] -> TyConEnv a+nameEnvElts :: TyConEnv a -> [a]+alterTyConEnv :: (Maybe a-> Maybe a) -> TyConEnv a -> TyCon -> TyConEnv a+extendTyConEnv_C :: (a->a->a) -> TyConEnv a -> TyCon -> a -> TyConEnv a+extendTyConEnv_Acc :: (a->b->b) -> (a->b) -> TyConEnv b -> TyCon -> a -> TyConEnv b+extendTyConEnv :: TyConEnv a -> TyCon -> a -> TyConEnv a+plusTyConEnv :: TyConEnv a -> TyConEnv a -> TyConEnv a+plusTyConEnv_C :: (a->a->a) -> TyConEnv a -> TyConEnv a -> TyConEnv a+plusTyConEnv_CD :: (a->a->a) -> TyConEnv a -> a -> TyConEnv a -> a -> TyConEnv a+plusTyConEnv_CD2 :: (Maybe a->Maybe a->a) -> TyConEnv a -> TyConEnv a -> TyConEnv a+extendTyConEnvList :: TyConEnv a -> [(TyCon,a)] -> TyConEnv a+extendTyConEnvList_C :: (a->a->a) -> TyConEnv a -> [(TyCon,a)] -> TyConEnv a+delFromTyConEnv :: TyConEnv a -> TyCon -> TyConEnv a+delListFromTyConEnv :: TyConEnv a -> [TyCon] -> TyConEnv a+elemTyConEnv :: TyCon -> TyConEnv a -> Bool+unitTyConEnv :: TyCon -> a -> TyConEnv a+lookupTyConEnv :: TyConEnv a -> TyCon -> Maybe a+lookupTyConEnv_NF :: TyConEnv a -> TyCon -> a+filterTyConEnv :: (elt -> Bool) -> TyConEnv elt -> TyConEnv elt+anyTyConEnv :: (elt -> Bool) -> TyConEnv elt -> Bool+mapTyConEnv :: (elt1 -> elt2) -> TyConEnv elt1 -> TyConEnv elt2+disjointTyConEnv :: TyConEnv a -> TyConEnv a -> Bool++nameEnvElts x = eltsUFM x+emptyTyConEnv = emptyUFM+isEmptyTyConEnv = isNullUFM+unitTyConEnv x y = unitUFM x y+extendTyConEnv x y z = addToUFM x y z+extendTyConEnvList x l = addListToUFM x l+lookupTyConEnv x y = lookupUFM x y+alterTyConEnv = alterUFM+mkTyConEnv l = listToUFM l+mkTyConEnvWith f = mkTyConEnv . map (\a -> (f a, a))+elemTyConEnv x y = elemUFM x y+plusTyConEnv x y = plusUFM x y+plusTyConEnv_C f x y = plusUFM_C f x y+plusTyConEnv_CD f x d y b = plusUFM_CD f x d y b+plusTyConEnv_CD2 f x y = plusUFM_CD2 f x y+extendTyConEnv_C f x y z = addToUFM_C f x y z+mapTyConEnv f x = mapUFM f x+extendTyConEnv_Acc x y z a b = addToUFM_Acc x y z a b+extendTyConEnvList_C x y z = addListToUFM_C x y z+delFromTyConEnv x y = delFromUFM x y+delListFromTyConEnv x y = delListFromUFM x y+filterTyConEnv x y = filterUFM x y+anyTyConEnv f x = foldUFM ((||) . f) False x+disjointTyConEnv x y = disjointUFM x y++lookupTyConEnv_NF env n = expectJust "lookupTyConEnv_NF" (lookupTyConEnv env n)++-- | Deterministic TyCon Environment+--+-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why+-- we need DTyConEnv.+type DTyConEnv a = UniqDFM TyCon a++emptyDTyConEnv :: DTyConEnv a+emptyDTyConEnv = emptyUDFM++lookupDTyConEnv :: DTyConEnv a -> TyCon -> Maybe a+lookupDTyConEnv = lookupUDFM++delFromDTyConEnv :: DTyConEnv a -> TyCon -> DTyConEnv a+delFromDTyConEnv = delFromUDFM++filterDTyConEnv :: (a -> Bool) -> DTyConEnv a -> DTyConEnv a+filterDTyConEnv = filterUDFM++mapDTyConEnv :: (a -> b) -> DTyConEnv a -> DTyConEnv b+mapDTyConEnv = mapUDFM++adjustDTyConEnv :: (a -> a) -> DTyConEnv a -> TyCon -> DTyConEnv a+adjustDTyConEnv = adjustUDFM++alterDTyConEnv :: (Maybe a -> Maybe a) -> DTyConEnv a -> TyCon -> DTyConEnv a+alterDTyConEnv = alterUDFM++extendDTyConEnv :: DTyConEnv a -> TyCon -> a -> DTyConEnv a+extendDTyConEnv = addToUDFM
+ compiler/GHC/Core/TyCon/RecWalk.hs view
@@ -0,0 +1,99 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++Check for recursive type constructors.++-}++{-# LANGUAGE CPP #-}++module GHC.Core.TyCon.RecWalk (++ -- * Recursion breaking+ RecTcChecker, initRecTc, defaultRecTcMaxBound,+ setRecTcMaxBound, checkRecTc++ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Core.TyCon+import GHC.Core.TyCon.Env++{-+************************************************************************+* *+ Walking over recursive TyCons+* *+************************************************************************++Note [Expanding newtypes and products]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When expanding a type to expose a data-type constructor, we need to be+careful about newtypes, lest we fall into an infinite loop. Here are+the key examples:++ newtype Id x = MkId x+ newtype Fix f = MkFix (f (Fix f))+ newtype T = MkT (T -> T)++ Type Expansion+ --------------------------+ T T -> T+ Fix Maybe Maybe (Fix Maybe)+ Id (Id Int) Int+ Fix Id NO NO NO++Notice that+ * We can expand T, even though it's recursive.+ * We can expand Id (Id Int), even though the Id shows up+ twice at the outer level, because Id is non-recursive++So, when expanding, we keep track of when we've seen a recursive+newtype at outermost level; and bail out if we see it again.++We sometimes want to do the same for product types, so that the+strictness analyser doesn't unbox infinitely deeply.++More precisely, we keep a *count* of how many times we've seen it.+This is to account for+ data instance T (a,b) = MkT (T a) (T b)+Then (#10482) if we have a type like+ T (Int,(Int,(Int,(Int,Int))))+we can still unbox deeply enough during strictness analysis.+We have to treat T as potentially recursive, but it's still+good to be able to unwrap multiple layers.++The function that manages all this is checkRecTc.+-}++data RecTcChecker = RC !Int (TyConEnv Int)+ -- The upper bound, and the number of times+ -- we have encountered each TyCon++-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'.+initRecTc :: RecTcChecker+initRecTc = RC defaultRecTcMaxBound emptyTyConEnv++-- | The default upper bound (100) for the number of times a 'RecTcChecker' is+-- allowed to encounter each 'TyCon'.+defaultRecTcMaxBound :: Int+defaultRecTcMaxBound = 100+-- Should we have a flag for this?++-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed+-- to encounter each 'TyCon'.+setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker+setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts++checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker+-- Nothing => Recursion detected+-- Just rec_tcs => Keep going+checkRecTc (RC bound rec_nts) tc+ = case lookupTyConEnv rec_nts tc of+ Just n | n >= bound -> Nothing+ | otherwise -> Just (RC bound (extendTyConEnv rec_nts tc (n+1)))+ Nothing -> Just (RC bound (extendTyConEnv rec_nts tc 1))
compiler/GHC/Core/Type.hs view
@@ -15,7 +15,7 @@ -- $type_classification -- $representation_types- TyThing(..), Type, ArgFlag(..), AnonArgFlag(..),+ Type, ArgFlag(..), AnonArgFlag(..), Specificity(..), KindOrType, PredType, ThetaType, Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder,@@ -81,7 +81,6 @@ filterOutInvisibleTypes, filterOutInferredTypes, partitionInvisibleTypes, partitionInvisibles, tyConArgFlags, appTyArgFlags,- synTyConResKind, -- ** Analyzing types TyCoMapper(..), mapTyCo, mapTyCoX,@@ -254,7 +253,7 @@ import GHC.Core.TyCon import GHC.Builtin.Types.Prim import {-# SOURCE #-} GHC.Builtin.Types- ( listTyCon, typeNatKind+ ( naturalTy, listTyCon , typeSymbolKind, liftedTypeKind , constraintKind , unrestrictedFunTyCon@@ -1120,14 +1119,14 @@ See #11714. -} -splitFunTy :: Type -> (Type, Type, Type)--- ^ Attempts to extract the argument and result types from a type, and--- panics if that is not possible. See also 'splitFunTy_maybe'+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 (Type, Type, Type)--- ^ Attempts to extract the argument and result types from a type+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@@ -2237,7 +2236,7 @@ {- 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,@@ -2600,7 +2599,7 @@ -------------------------- typeLiteralKind :: TyLit -> Kind-typeLiteralKind (NumTyLit {}) = typeNatKind+typeLiteralKind (NumTyLit {}) = naturalTy typeLiteralKind (StrTyLit {}) = typeSymbolKind -- | Returns True if a type is levity polymorphic. Should be the same@@ -2891,13 +2890,6 @@ go_tc tc = unitUniqSet tc go_ax ax = go_tc $ coAxiomTyCon ax --- | Find the result 'Kind' of a type synonym,--- after applying it to its 'arity' number of type variables--- Actually this function works fine on data types too,--- but they'd always return '*', so we never need to ask-synTyConResKind :: TyCon -> Kind-synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon))- -- | Retrieve the free variables in this type, splitting them based -- on whether they are used visibly or invisibly. Invisible ones come -- first.@@ -2934,7 +2926,7 @@ ************************************************************************ 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:@@ -2952,6 +2944,18 @@ 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
compiler/GHC/Core/Unfold.hs view
@@ -713,8 +713,7 @@ discount: (10 * (10 + n_val_args)), and said it was an "unambiguous win", but its terribly dangerous because a function with many many case branches, each finishing with a constructor, can have an-arbitrarily large discount. This led to terrible code bloat: see-#6099.+arbitrarily large discount. This led to terrible code bloat: see #6099. Note [Unboxed tuple size and result discount] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Unify.hs view
@@ -1454,7 +1454,7 @@ = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co) then Nothing -- occurs check failed else Just $ extendVarEnv subst tv1' $- castCoercionKindI co (mkSymCo lkco) (mkSymCo rkco)+ castCoercionKind co (mkSymCo lkco) (mkSymCo rkco) | otherwise = Nothing
compiler/GHC/Core/UsageEnv.hs view
@@ -1,7 +1,18 @@-{-# LANGUAGE ViewPatterns #-}-module GHC.Core.UsageEnv (UsageEnv, addUsage, scaleUsage, zeroUE,- lookupUE, scaleUE, deleteUE, addUE, Usage(..), unitUE,- bottomUE, supUE, supUEs) where+module GHC.Core.UsageEnv+ ( Usage(..)+ , UsageEnv+ , addUE+ , addUsage+ , bottomUE+ , deleteUE+ , lookupUE+ , scaleUE+ , scaleUsage+ , supUE+ , supUEs+ , unitUE+ , zeroUE+ ) where import Data.Foldable import GHC.Prelude
compiler/GHC/Core/Utils.hs view
@@ -74,7 +74,7 @@ import GHC.Driver.Ppr import GHC.Core-import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofName )+import GHC.Builtin.Names (absentErrorIdKey, makeStaticName, unsafeEqualityProofName) import GHC.Core.Ppr import GHC.Core.FVs( exprFreeVars ) import GHC.Types.Var@@ -87,7 +87,6 @@ import GHC.Builtin.PrimOps import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Builtin.Names( absentErrorIdKey ) import GHC.Core.Type as Type import GHC.Core.Predicate import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder )@@ -97,7 +96,6 @@ import GHC.Types.Unique import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Builtin.Types.Prim import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.List.SetOps( minusList )@@ -139,7 +137,7 @@ = case collectArgs e of (fun, args) -> applyTypeToArgs e (exprType fun) args -exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy+exprType other = pprPanic "exprType" (pprCoreExpr other) coreAltType :: CoreAlt -> Type -- ^ Returns the type of the alternatives right hand side@@ -604,7 +602,7 @@ ************************************************************************ * *- Operations oer case alternatives+ Operations over case alternatives * * ************************************************************************ @@ -1512,7 +1510,7 @@ Suppose the user wrote this {-# RULE forall x. foo (negate x) = h x #-} f x = ....(foo (negate x))....-He'd expect the rule to fire. But since negate is overloaded, we might+They'd expect the rule to fire. But since negate is overloaded, we might get this: f = \d -> let n = negate d in \x -> ...foo (n x)... So we treat the application of a function (negate in this case) to a@@ -2622,4 +2620,3 @@ = idName v == unsafeEqualityProofName | otherwise = False-
compiler/GHC/Data/BooleanFormula.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,- DeriveTraversable #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-} -------------------------------------------------------------------------------- -- | Boolean formulas without quantifiers and without negation.
compiler/GHC/Data/FastString.hs view
@@ -1,8 +1,12 @@ -- (c) The University of Glasgow, 1997-2006 -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples,- GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+ {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected@@ -501,7 +505,7 @@ mkFastStringWith (mkNewFastStringShortByteString sbs) sbs newSBSFromPtr :: Ptr a -> Int -> IO ShortByteString-newSBSFromPtr (Ptr src#) (I# len#) = do+newSBSFromPtr (Ptr src#) (I# len#) = IO $ \s -> case newByteArray# len# s of { (# s, dst# #) -> case copyAddrToByteArray# src# dst# 0# len# s of { s ->
compiler/GHC/Data/StringBuffer.hs view
@@ -6,7 +6,11 @@ Buffers for scanning string input stored in external arrays. -} -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+ {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected@@ -124,8 +128,8 @@ hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur)- = do withForeignPtr (plusForeignPtr buf cur) $ \ptr ->- hPutBuf hdl ptr len+ = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->+ hPutBuf hdl ptr len -- | Skip the byte-order mark if there is one (see #1744 and #6016), -- and return the new position of the handle in bytes.@@ -198,8 +202,8 @@ nextChar :: StringBuffer -> (Char,StringBuffer) nextChar (StringBuffer buf len (I# cur#)) = -- Getting our fingers dirty a little here, but this is performance-critical- inlinePerformIO $ do- withForeignPtr buf $ \(Ptr a#) -> do+ inlinePerformIO $+ withForeignPtr buf $ \(Ptr a#) -> case utf8DecodeCharAddr# (a# `plusAddr#` cur#) 0# of (# c#, nBytes# #) -> let cur' = I# (cur# +# nBytes#) in@@ -215,7 +219,7 @@ prevChar :: StringBuffer -> Char -> Char prevChar (StringBuffer _ _ 0) deflt = deflt prevChar (StringBuffer buf _ cur) _ =- inlinePerformIO $ do+ inlinePerformIO $ withForeignPtr buf $ \p -> do p' <- utf8PrevChar (p `plusPtr` cur) return (fst (utf8DecodeChar p'))
compiler/GHC/Data/TrieMap.hs view
@@ -1,14 +1,13 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -}--{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} module GHC.Data.TrieMap( -- * Maps over 'Maybe' values MaybeMap,
compiler/GHC/Driver/Backpack/Syntax.hs view
@@ -18,11 +18,16 @@ import GHC.Prelude -import GHC.Driver.Phases import GHC.Hs+ import GHC.Types.SrcLoc+import GHC.Types.SourceFile++import GHC.Unit.Module.Name+import GHC.Unit.Types+import GHC.Unit.Info+ import GHC.Utils.Outputable-import GHC.Unit {- ************************************************************************
compiler/GHC/Driver/Config.hs view
@@ -32,7 +32,6 @@ mkParserOpts <$> warningFlags <*> extensionFlags- <*> homeUnitId_ <*> safeImportsOn <*> gopt Opt_Haddock <*> gopt Opt_KeepRawTokenStream
+ compiler/GHC/Driver/Env.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}++module GHC.Driver.Env+ ( Hsc(..)+ , HscEnv (..)+ , runHsc+ , mkInteractiveHscEnv+ , runInteractiveHsc+ , hscEPS+ , hptCompleteSigs+ , hptInstances+ , hptAnns+ , hptAllThings+ , hptSomeThingsBelowUs+ , hptRules+ , prepareAnnotations+ , lookupType+ , lookupIfaceByModule+ )+where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Driver.Ppr+import GHC.Driver.Session+import GHC.Unit.Finder.Types++import GHC.Runtime.Context+import GHC.Runtime.Interpreter.Types (Interp)+import GHC.Runtime.Linker.Types ( DynLinker )++import GHC.Unit+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.Deps+import GHC.Unit.Home.ModInfo+import GHC.Unit.External++import GHC.Core ( CoreRule )+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv ( ClsInst )++import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )+import GHC.Types.CompleteMatch+import GHC.Types.Name+import GHC.Types.Name.Cache+import GHC.Types.Name.Env+import GHC.Types.Target+import GHC.Types.TypeEnv+import GHC.Types.TyThing++import GHC.Builtin.Names ( gHC_PRIM )++import GHC.Data.Maybe+import GHC.Data.Bag++import GHC.Unit.Module.Graph++import GHC.Utils.Outputable+import GHC.Utils.Monad+import GHC.Utils.Error+import GHC.Utils.Panic+import GHC.Utils.Misc++import Control.Monad ( guard, ap )+import Data.IORef++-- | The Hsc monad: Passing an environment and warning state+newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))+ deriving (Functor)++instance Applicative Hsc where+ pure a = Hsc $ \_ w -> return (a, w)+ (<*>) = ap++instance Monad Hsc where+ Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w+ case k a of+ Hsc k' -> k' e w1++instance MonadIO Hsc where+ liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)++instance HasDynFlags Hsc where+ getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)++runHsc :: HscEnv -> Hsc a -> IO a+runHsc hsc_env (Hsc hsc) = do+ (a, w) <- hsc hsc_env emptyBag+ printOrThrowWarnings (hsc_dflags hsc_env) w+ return a++mkInteractiveHscEnv :: HscEnv -> HscEnv+mkInteractiveHscEnv hsc_env = hsc_env{ hsc_dflags = interactive_dflags }+ where+ interactive_dflags = ic_dflags (hsc_IC hsc_env)++runInteractiveHsc :: HscEnv -> Hsc a -> IO a+-- A variant of runHsc that switches in the DynFlags from the+-- InteractiveContext before running the Hsc computation.+runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)++-- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable.+-- An HscEnv is used to compile a single module from plain Haskell source+-- code (after preprocessing) to either C, assembly or C--. It's also used+-- to store the dynamic linker state to allow for multiple linkers in the+-- same address space.+-- Things like the module graph don't change during a single compilation.+--+-- Historical note: \"hsc\" used to be the name of the compiler binary,+-- when there was a separate driver and compiler. To compile a single+-- module, the driver would invoke hsc on the source code... so nowadays+-- we think of hsc as the layer of the compiler that deals with compiling+-- a single module.+data HscEnv+ = HscEnv {+ hsc_dflags :: DynFlags,+ -- ^ The dynamic flag settings++ hsc_targets :: [Target],+ -- ^ The targets (or roots) of the current session++ hsc_mod_graph :: ModuleGraph,+ -- ^ The module graph of the current session++ hsc_IC :: InteractiveContext,+ -- ^ The context for evaluating interactive statements++ hsc_HPT :: HomePackageTable,+ -- ^ The home package table describes already-compiled+ -- home-package modules, /excluding/ the module we+ -- are compiling right now.+ -- (In one-shot mode the current module is the only+ -- home-package module, so hsc_HPT is empty. All other+ -- modules count as \"external-package\" modules.+ -- However, even in GHCi mode, hi-boot interfaces are+ -- demand-loaded into the external-package table.)+ --+ -- 'hsc_HPT' is not mutable because we only demand-load+ -- external packages; the home package is eagerly+ -- loaded, module by module, by the compilation manager.+ --+ -- The HPT may contain modules compiled earlier by @--make@+ -- but not actually below the current module in the dependency+ -- graph.+ --+ -- (This changes a previous invariant: changed Jan 05.)++ hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState),+ -- ^ Information about the currently loaded external packages.+ -- This is mutable because packages will be demand-loaded during+ -- a compilation run as required.++ hsc_NC :: {-# UNPACK #-} !(IORef NameCache),+ -- ^ As with 'hsc_EPS', this is side-effected by compiling to+ -- reflect sucking in interface files. They cache the state of+ -- external interface files, in effect.++ hsc_FC :: {-# UNPACK #-} !(IORef FinderCache),+ -- ^ The cached result of performing finding in the file system++ hsc_type_env_var :: Maybe (Module, IORef TypeEnv)+ -- ^ Used for one-shot compilation only, to initialise+ -- the 'IfGblEnv'. See 'GHC.Tc.Utils.tcg_type_env_var' for+ -- 'GHC.Tc.Utils.TcGblEnv'. See also Note [hsc_type_env_var hack]++ , hsc_interp :: Maybe Interp+ -- ^ target code interpreter (if any) to use for TH and GHCi.+ -- See Note [Target code interpreter]++ , hsc_dynLinker :: DynLinker+ -- ^ dynamic linker.++ , hsc_home_unit :: !HomeUnit+ -- ^ Home-unit++ }++{-++Note [Target code interpreter]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Template Haskell and GHCi use an interpreter to execute code that is built for+the compiler target platform (= code host platform) on the compiler host+platform (= code build platform).++The internal interpreter can be used when both platforms are the same and when+the built code is compatible with the compiler itself (same way, etc.). This+interpreter is not always available: for instance stage1 compiler doesn't have+it because there might be an ABI mismatch between the code objects (built by+stage1 compiler) and the stage1 compiler itself (built by stage0 compiler).++In most cases, an external interpreter can be used instead: it runs in a+separate process and it communicates with the compiler via a two-way message+passing channel. The process is lazily spawned to avoid overhead when it is not+used.++The target code interpreter to use can be selected per session via the+`hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in+which case Template Haskell and GHCi will fail to run. The interpreter to use is+configured via command-line flags (in `GHC.setSessionDynFlags`).+++-}++-- Note [hsc_type_env_var hack]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- hsc_type_env_var is used to initialize tcg_type_env_var, and+-- eventually it is the mutable variable that is queried from+-- if_rec_types to get a TypeEnv. So, clearly, it's something+-- related to knot-tying (see Note [Tying the knot]).+-- hsc_type_env_var is used in two places: initTcRn (where+-- it initializes tcg_type_env_var) and initIfaceCheck+-- (where it initializes if_rec_types).+--+-- But why do we need a way to feed a mutable variable in? Why+-- can't we just initialize tcg_type_env_var when we start+-- typechecking? The problem is we need to knot-tie the+-- EPS, and we may start adding things to the EPS before type+-- checking starts.+--+-- Here is a concrete example. Suppose we are running+-- "ghc -c A.hs", and we have this file system state:+--+-- A.hs-boot A.hi-boot **up to date**+-- B.hs B.hi **up to date**+-- A.hs A.hi **stale**+--+-- The first thing we do is run checkOldIface on A.hi.+-- checkOldIface will call loadInterface on B.hi so it can+-- get its hands on the fingerprints, to find out if A.hi+-- needs recompilation. But loadInterface also populates+-- the EPS! And so if compilation turns out to be necessary,+-- as it is in this case, the thunks we put into the EPS for+-- B.hi need to have the correct if_rec_types mutable variable+-- to query.+--+-- If the mutable variable is only allocated WHEN we start+-- typechecking, then that's too late: we can't get the+-- information to the thunks. So we need to pre-commit+-- to a type variable in 'hscIncrementalCompile' BEFORE we+-- check the old interface.+--+-- This is all a massive hack because arguably checkOldIface+-- should not populate the EPS. But that's a refactor for+-- another day.++-- | Retrieve the ExternalPackageState cache.+hscEPS :: HscEnv -> IO ExternalPackageState+hscEPS hsc_env = readIORef (hsc_EPS hsc_env)++hptCompleteSigs :: HscEnv -> [CompleteMatch]+hptCompleteSigs = hptAllThings (md_complete_matches . hm_details)++-- | Find all the instance declarations (of classes and families) from+-- the Home Package Table filtered by the provided predicate function.+-- Used in @tcRnImports@, to select the instances that are in the+-- transitive closure of imports from the currently compiled module.+hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])+hptInstances hsc_env want_this_module+ = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do+ guard (want_this_module (moduleName (mi_module (hm_iface mod_info))))+ let details = hm_details mod_info+ return (md_insts details, md_fam_insts details)+ in (concat insts, concat famInsts)++-- | Get rules from modules "below" this one (in the dependency sense)+hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]+hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False+++-- | Get annotations from modules "below" this one (in the dependency sense)+hptAnns :: HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]+hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps+hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env++hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]+hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env))++-- | Get things from modules "below" this one (in the dependency sense)+-- C.f Inst.hptInstances+hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]+hptSomeThingsBelowUs extract include_hi_boot hsc_env deps+ | isOneShot (ghcMode (hsc_dflags hsc_env)) = []++ | otherwise+ = let hpt = hsc_HPT hsc_env+ in+ [ thing+ | -- Find each non-hi-boot module below me+ GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- deps+ , include_hi_boot || (is_boot == NotBoot)++ -- unsavoury: when compiling the base package with --make, we+ -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't+ -- be in the HPT, because we never compile it; it's in the EPT+ -- instead. ToDo: clean up, and remove this slightly bogus filter:+ , mod /= moduleName gHC_PRIM++ -- Look it up in the HPT+ , let things = case lookupHpt hpt mod of+ Just info -> extract info+ Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg []+ msg = vcat [text "missing module" <+> ppr mod,+ text "Probable cause: out-of-date interface files"]+ -- This really shouldn't happen, but see #962++ -- And get its dfuns+ , thing <- things ]+++-- | Deal with gathering annotations in from all possible places+-- and combining them into a single 'AnnEnv'+prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv+prepareAnnotations hsc_env mb_guts = do+ eps <- hscEPS hsc_env+ let -- Extract annotations from the module being compiled if supplied one+ mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts+ -- Extract dependencies of the module if we are supplied one,+ -- otherwise load annotations from all home package table+ -- entries regardless of dependency ordering.+ home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts+ other_pkg_anns = eps_ann_env eps+ ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns,+ Just home_pkg_anns,+ Just other_pkg_anns]+ return ann_env++-- | Find the 'TyThing' for the given 'Name' by using all the resources+-- at our disposal: the compiled modules in the 'HomePackageTable' and the+-- compiled modules in other packages that live in 'PackageTypeEnv'. Note+-- that this does NOT look up the 'TyThing' in the module being compiled: you+-- have to do that yourself, if desired+lookupType :: HscEnv -> Name -> IO (Maybe TyThing)+lookupType hsc_env name = do+ eps <- liftIO $ readIORef (hsc_EPS hsc_env)+ let pte = eps_PTE eps+ hpt = hsc_HPT hsc_env++ mod = ASSERT2( isExternalName name, ppr name )+ if isHoleName name+ then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name))+ else nameModule name++ !ty = if isOneShot (ghcMode (hsc_dflags hsc_env))+ -- in one-shot, we don't use the HPT+ then lookupNameEnv pte name+ else case lookupHptByModule hpt mod of+ Just hm -> lookupNameEnv (md_types (hm_details hm)) name+ Nothing -> lookupNameEnv pte name+ pure ty++-- | Find the 'ModIface' for a 'Module', searching in both the loaded home+-- and external package module information+lookupIfaceByModule+ :: HomePackageTable+ -> PackageIfaceTable+ -> Module+ -> Maybe ModIface+lookupIfaceByModule hpt pit mod+ = case lookupHptByModule hpt mod of+ Just hm -> Just (hm_iface hm)+ Nothing -> lookupModuleEnv pit mod+ -- If the module does come from the home package, why do we look in the PIT as well?+ -- (a) In OneShot mode, even home-package modules accumulate in the PIT+ -- (b) Even in Batch (--make) mode, there is *one* case where a home-package+ -- module is in the PIT, namely GHC.Prim when compiling the base package.+ -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package+ -- of its own, but it doesn't seem worth the bother.+
compiler/GHC/Driver/Flags.hs view
@@ -158,6 +158,8 @@ | Opt_Specialise | Opt_SpecialiseAggressively | Opt_CrossModuleSpecialise+ | Opt_InlineGenerics+ | Opt_InlineGenericsAggressively | Opt_StaticArgumentTransformation | Opt_CSE | Opt_StgCSE@@ -499,6 +501,8 @@ | Opt_WarnCompatUnqualifiedImports -- Since 8.10 | Opt_WarnDerivingDefaults | Opt_WarnInvalidHaddock -- Since 8.12+ | Opt_WarnOperatorWhitespaceExtConflict -- Since 9.2+ | Opt_WarnOperatorWhitespace -- Since 9.2 deriving (Eq, Show, Enum) -- | Used when outputting warnings: if a reason is given, it is
compiler/GHC/Driver/Hooks.hs view
@@ -31,34 +31,46 @@ import GHC.Prelude +import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Pipeline.Monad-import GHC.Driver.Types+ import GHC.Hs.Decls import GHC.Hs.Binds import GHC.Hs.Expr-import GHC.Tc.Types-import GHC.Data.Bag+import GHC.Hs.Extension+ import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Id-import GHC.Core-import GHCi.RemoteTypes import GHC.Types.SrcLoc-import GHC.Core.Type-import System.Process import GHC.Types.Basic+import GHC.Types.CostCentre+import GHC.Types.Meta+import GHC.Types.HpcInfo+ import GHC.Unit.Module+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Home.ModInfo++import GHC.Core import GHC.Core.TyCon-import GHC.Types.CostCentre+import GHC.Core.Type++import GHC.Tc.Types import GHC.Stg.Syntax-import GHC.Data.Stream-import GHC.Cmm-import GHC.Hs.Extension import GHC.StgToCmm.Types (ModuleLFInfos)+import GHC.Cmm +import GHCi.RemoteTypes++import GHC.Data.Stream+import GHC.Data.Bag+ import Data.Maybe import qualified Data.Kind+import System.Process {- ************************************************************************
compiler/GHC/Driver/Monad.hs view
@@ -25,11 +25,14 @@ import GHC.Prelude -import GHC.Utils.Monad-import GHC.Driver.Types import GHC.Driver.Session+import GHC.Driver.Env++import GHC.Utils.Monad import GHC.Utils.Exception import GHC.Utils.Error++import GHC.Types.SourceError import Control.Monad import Control.Monad.Catch as MC
compiler/GHC/Driver/Phases.hs view
@@ -9,7 +9,6 @@ ----------------------------------------------------------------------------- module GHC.Driver.Phases (- HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, Phase(..), happensBefore, eqPhase, anyHsc, isStopLn, startPhase,@@ -34,20 +33,27 @@ isCishFilename, isDynLibFilename, isHaskellUserSrcFilename,- isSourceFilename+ isSourceFilename,++ phaseForeignLanguage ) where #include "GhclibHsVersions.h" import GHC.Prelude +import GHC.Platform++import GHC.ForeignSrcLang++import GHC.Types.SourceFile+ import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Platform-import System.FilePath-import GHC.Utils.Binary import GHC.Utils.Misc +import System.FilePath+ ----------------------------------------------------------------------------- -- Phases @@ -63,70 +69,6 @@ linker | other | - | a.out -} --- Note [HscSource types]--- ~~~~~~~~~~~~~~~~~~~~~~--- There are three types of source file for Haskell code:------ * HsSrcFile is an ordinary hs file which contains code,------ * HsBootFile is an hs-boot file, which is used to break--- recursive module imports (there will always be an--- HsSrcFile associated with it), and------ * HsigFile is an hsig file, which contains only type--- signatures and is used to specify signatures for--- modules.------ Syntactically, hs-boot files and hsig files are quite similar: they--- only include type signatures and must be associated with an--- actual HsSrcFile. isHsBootOrSig allows us to abstract over code--- which is indifferent to which. However, there are some important--- differences, mostly owing to the fact that hsigs are proper--- modules (you `import Sig` directly) whereas HsBootFiles are--- temporary placeholders (you `import {-# SOURCE #-} Mod).--- When we finish compiling the true implementation of an hs-boot,--- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the--- other hand, is never replaced (in particular, we *cannot* use the--- HomeModInfo of the original HsSrcFile backing the signature, since it--- will export too many symbols.)------ Additionally, while HsSrcFile is the only Haskell file--- which has *code*, we do generate .o files for HsigFile, because--- this is how the recompilation checker figures out if a file--- needs to be recompiled. These are fake object files which--- should NOT be linked against.--data HscSource- = HsSrcFile | HsBootFile | HsigFile- deriving( Eq, Ord, Show )- -- Ord needed for the finite maps we build in CompManager--instance Binary HscSource where- put_ bh HsSrcFile = putByte bh 0- put_ bh HsBootFile = putByte bh 1- put_ bh HsigFile = putByte bh 2- get bh = do- h <- getByte bh- case h of- 0 -> return HsSrcFile- 1 -> return HsBootFile- _ -> return HsigFile--hscSourceString :: HscSource -> String-hscSourceString HsSrcFile = ""-hscSourceString HsBootFile = "[boot]"-hscSourceString HsigFile = "[sig]"---- See Note [isHsBootOrSig]-isHsBootOrSig :: HscSource -> Bool-isHsBootOrSig HsBootFile = True-isHsBootOrSig HsigFile = True-isHsBootOrSig _ = False--isHsigFile :: HscSource -> Bool-isHsigFile HsigFile = True-isHsigFile _ = False- data Phase = Unlit HscSource | Cpp HscSource@@ -368,3 +310,16 @@ isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f)++-- | Foreign language of the phase if the phase deals with a foreign code+phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang+phaseForeignLanguage phase = case phase of+ Cc -> Just LangC+ Ccxx -> Just LangCxx+ Cobjc -> Just LangObjc+ Cobjcxx -> Just LangObjcxx+ HCc -> Just LangC+ As _ -> Just LangAsm+ MergeForeign -> Just RawObject+ _ -> Nothing+
compiler/GHC/Driver/Pipeline/Monad.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE NamedFieldPuns #-} -- | The CompPipeline monad and associated ops -- -- Defined in separate module so that it can safely be imported from Hooks@@ -15,11 +14,19 @@ import GHC.Utils.Monad import GHC.Utils.Outputable+ import GHC.Driver.Session import GHC.Driver.Phases-import GHC.Driver.Types-import GHC.Unit.Module+import GHC.Driver.Env+ import GHC.SysTools.FileCleanup (TempFileLifetime)++import GHC.Types.SourceFile++import GHC.Unit.Module+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Status import Control.Monad
compiler/GHC/Driver/Plugins.hs view
@@ -49,19 +49,25 @@ import GHC.Prelude -import GHC.Core.Opt.Monad ( CoreToDo, CoreM )-import qualified GHC.Tc.Types-import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports )-import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR )-import GHC.Hs+import GHC.Driver.Env import GHC.Driver.Session-import GHC.Driver.Types import GHC.Driver.Monad import GHC.Driver.Phases+ import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary++import qualified GHC.Tc.Types+import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports )+import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR )++import GHC.Core.Opt.Monad ( CoreToDo, CoreM )+import GHC.Hs import GHC.Utils.Fingerprint-import Data.List (sort) import GHC.Utils.Outputable (Outputable(..), text, (<+>))++import Data.List (sort) --Qualified import so we can define a Semigroup instance -- but it doesn't clash with Outputable.<>
compiler/GHC/Driver/Session.hs view
@@ -42,7 +42,7 @@ dynamicTooMkDynamicDynFlags, dynamicOutputFile, sccProfilingEnabled,- DynFlags(..),+ DynFlags(..), mainModIs, FlagSpec(..), HasDynFlags(..), ContainsDynFlags(..), RtsOptsEnabled(..),@@ -70,7 +70,6 @@ putLogMsg, -- ** Safe Haskell- SafeHaskellMode(..), safeHaskellOn, safeHaskellModeEnabled, safeImportsOn, safeLanguageOn, safeInferOn, packageTrustOn,@@ -132,8 +131,6 @@ sGhcWithSMP, sGhcRTSWays, sLibFFI,- sGhcThreaded,- sGhcDebugged, sGhcRtsWithLibdw, GhcNameVersion(..), FileSettings(..),@@ -241,7 +238,7 @@ import GHC.Unit.Module import {-# SOURCE #-} GHC.Driver.Plugins import {-# SOURCE #-} GHC.Driver.Hooks-import GHC.Builtin.Names ( mAIN )+import GHC.Builtin.Names ( mAIN_NAME ) import {-# SOURCE #-} GHC.Unit.State (UnitState, emptyUnitState, UnitDatabase) import GHC.Driver.Phases ( Phase(..), phaseInputExt ) import GHC.Driver.Flags@@ -260,6 +257,7 @@ import GHC.Utils.Monad import qualified GHC.Utils.Ppr as Pretty import GHC.Types.SrcLoc+import GHC.Types.SafeHaskell import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) import GHC.Data.FastString import GHC.Utils.Fingerprint@@ -267,9 +265,9 @@ import GHC.Settings import GHC.CmmToAsm.CFG.Weight +import GHC.Types.Error import {-# SOURCE #-} GHC.Utils.Error- ( Severity(..), MsgDoc, mkLocMessageAnn- , getCaretDiagnostic, DumpAction, TraceAction+ ( DumpAction, TraceAction , defaultDumpAction, defaultTraceAction ) import GHC.Utils.Json import GHC.SysTools.Terminal ( stderrSupportsAnsiColors )@@ -407,27 +405,6 @@ flattenIncludes :: IncludeSpecs -> [String] flattenIncludes specs = includePathsQuote specs ++ includePathsGlobal specs --- | The various Safe Haskell modes-data SafeHaskellMode- = Sf_None -- ^ inferred unsafe- | Sf_Unsafe -- ^ declared and checked- | Sf_Trustworthy -- ^ declared and checked- | Sf_Safe -- ^ declared and checked- | Sf_SafeInferred -- ^ inferred as safe- | Sf_Ignore -- ^ @-fno-safe-haskell@ state- deriving (Eq)--instance Show SafeHaskellMode where- show Sf_None = "None"- show Sf_Unsafe = "Unsafe"- show Sf_Trustworthy = "Trustworthy"- show Sf_Safe = "Safe"- show Sf_SafeInferred = "Safe-Inferred"- show Sf_Ignore = "Ignore"--instance Outputable SafeHaskellMode where- ppr = text . show- -- | Contains not only a collection of 'GeneralFlag's but also a plethora of -- information relating to the compilation of a single file or GHC session data DynFlags = DynFlags {@@ -515,7 +492,7 @@ historySize :: Int, -- ^ Simplification history size importPaths :: [FilePath],- mainModIs :: Module,+ mainModuleNameIs :: ModuleName, mainFunIs :: Maybe String, reductionDepth :: IntWithInf, -- ^ Typechecker maximum stack depth solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver@@ -940,13 +917,13 @@ -- | The 'GhcMode' tells us whether we're doing multi-module -- compilation (controlled via the "GHC" API) or one-shot -- (single-module) compilation. This makes a difference primarily to--- the "GHC.Driver.Finder": in one-shot mode we look for interface files for+-- the "GHC.Unit.Finder": in one-shot mode we look for interface files for -- imported modules, but in multi-module mode we look for source files -- in order to check whether they need to be recompiled. data GhcMode = CompManager -- ^ @\-\-make@, GHCi, etc. | OneShot -- ^ @ghc -c Foo.hs@- | MkDepend -- ^ @ghc -M@, see "GHC.Driver.Finder" for why we need this+ | MkDepend -- ^ @ghc -M@, see "GHC.Unit.Finder" for why we need this deriving Eq instance Outputable GhcMode where@@ -1189,7 +1166,7 @@ ghcHeapSize = Nothing, importPaths = ["."],- mainModIs = mAIN,+ mainModuleNameIs = mAIN_NAME, mainFunIs = Nothing, reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS,@@ -1375,7 +1352,7 @@ -- jsonLogAction :: LogAction jsonLogAction dflags reason severity srcSpan msg- = do+ = defaultLogActionHPutStrDoc dflags stdout (withPprStyle (PprCode CStyle) (doc $$ text "")) where@@ -1666,6 +1643,9 @@ extensionFlags = flattenExtensionFlags lang (extensions dflags) } +mainModIs :: DynFlags -> Module+mainModIs dflags = mkHomeModule (mkHomeUnitFromFlags dflags) (mainModuleNameIs dflags)+ -- | Set the Haskell language standard to use setLanguage :: Language -> DynP () setLanguage l = upd (`lang_set` Just l)@@ -2180,7 +2160,7 @@ ------- ways --------------------------------------------------------------- , make_ord_flag defGhcFlag "prof" (NoArg (addWay WayProf))- , make_ord_flag defGhcFlag "eventlog" (NoArg (addWay WayEventLog))+ , make_ord_flag defGhcFlag "eventlog" (NoArg (addWay WayTracing)) , make_ord_flag defGhcFlag "debug" (NoArg (addWay WayDebug)) , make_ord_flag defGhcFlag "threaded" (NoArg (addWay WayThreaded)) @@ -2215,6 +2195,8 @@ $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo = (f,[]) } , make_ord_flag defFlag "pgmlc" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc = (f,[]) }+ , make_ord_flag defFlag "pgmlm"+ $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm = (f,[]) } , make_ord_flag defFlag "pgmi" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i = f } , make_ord_flag defFlag "pgmL"@@ -2230,6 +2212,8 @@ -- (see #15319) toolSettings_ccSupportsNoPie = False }+ , make_ord_flag defFlag "pgmc-supports-no-pie"+ $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True } , make_ord_flag defFlag "pgms" (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8")) , make_ord_flag defFlag "pgma"@@ -2253,6 +2237,8 @@ -- need to appear before -optl/-opta to be parsed as LLVM flags.+ , make_ord_flag defFlag "optlm"+ $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lm = f : toolSettings_opt_lm s } , make_ord_flag defFlag "optlo" $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo = f : toolSettings_opt_lo s } , make_ord_flag defFlag "optlc"@@ -2878,7 +2864,7 @@ , make_dep_flag defFlag "funfolding-keeness-factor" (floatSuffix (\_ d -> d))- "-funfolding-keeness-factor is no longer respected as of GHC 8.12"+ "-funfolding-keeness-factor is no longer respected as of GHC 9.0" , make_ord_flag defFlag "fmax-worker-args" (intSuffix (\n d -> d {maxWorkerArgs = n}))@@ -2969,8 +2955,8 @@ ------ position independent flags ---------------------------------- , make_ord_flag defGhcFlag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) , make_ord_flag defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC))- , make_ord_flag defGhcFlag "fPIE" (NoArg (setGeneralFlag Opt_PIC))- , make_ord_flag defGhcFlag "fno-PIE" (NoArg (unSetGeneralFlag Opt_PIC))+ , make_ord_flag defGhcFlag "fPIE" (NoArg (setGeneralFlag Opt_PIE))+ , make_ord_flag defGhcFlag "fno-PIE" (NoArg (unSetGeneralFlag Opt_PIE)) ------ Debugging flags ---------------------------------------------- , make_ord_flag defGhcFlag "g" (OptIntSuffix setDebugLevel)@@ -3045,7 +3031,7 @@ (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead" , make_dep_flag defFlag "no-user-package-conf" (NoArg removeUserPkgDb) "Use -no-user-package-db instead"- , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> do+ , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> upd (setUnitId name)) , make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId) , make_ord_flag defFlag "package" (HasArg exposePackage)@@ -3322,7 +3308,9 @@ Opt_WarnPrepositiveQualifiedModule, flagSpec "unused-packages" Opt_WarnUnusedPackages, flagSpec "compat-unqualified-imports" Opt_WarnCompatUnqualifiedImports,- flagSpec "invalid-haddock" Opt_WarnInvalidHaddock+ flagSpec "invalid-haddock" Opt_WarnInvalidHaddock,+ flagSpec "operator-whitespace-ext-conflict" Opt_WarnOperatorWhitespaceExtConflict,+ flagSpec "operator-whitespace" Opt_WarnOperatorWhitespace ] -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@@@ -3460,6 +3448,8 @@ flagSpec "specialize-aggressively" Opt_SpecialiseAggressively, flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise, flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise,+ flagSpec "inline-generics" Opt_InlineGenerics,+ flagSpec "inline-generics-aggressively" Opt_InlineGenericsAggressively, flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation, flagSpec "strictness" Opt_Strictness, flagSpec "use-rpaths" Opt_RPath,@@ -3973,6 +3963,7 @@ , ([1,2], Opt_Specialise) , ([1,2], Opt_CrossModuleSpecialise)+ , ([1,2], Opt_InlineGenerics) , ([1,2], Opt_Strictness) , ([1,2], Opt_UnboxSmallStrictFields) , ([1,2], Opt_CprAnal)@@ -4074,7 +4065,10 @@ Opt_WarnSimplifiableClassConstraints, Opt_WarnStarBinder, Opt_WarnInaccessibleCode,- Opt_WarnSpaceAfterBang+ Opt_WarnSpaceAfterBang,+ Opt_WarnNonCanonicalMonadInstances,+ Opt_WarnNonCanonicalMonoidInstances,+ Opt_WarnOperatorWhitespaceExtConflict ] -- | Things you get with -W@@ -4506,10 +4500,10 @@ | not (null main_fn) && isLower (head main_fn) -- The arg looked like "Foo.Bar.baz" = upd $ \d -> d { mainFunIs = Just main_fn,- mainModIs = mkModule mainUnit (mkModuleName main_mod) }+ mainModuleNameIs = mkModuleName main_mod } | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar"- = upd $ \d -> d { mainModIs = mkModule mainUnit (mkModuleName arg) }+ = upd $ \d -> d { mainModuleNameIs = mkModuleName arg } | otherwise -- The arg looked like "baz" = upd $ \d -> d { mainFunIs = Just arg }@@ -4908,7 +4902,7 @@ isSse2Enabled :: Platform -> Bool isSse2Enabled platform = case platformArch platform of- -- We Assume SSE1 and SSE2 operations are available on both+ -- We assume SSE1 and SSE2 operations are available on both -- x86 and x86_64. Historically we didn't default to SSE2 and -- SSE1 on x86, which results in defacto nondeterminism for how -- rounding behaves in the associated x87 floating point instructions@@ -5066,4 +5060,3 @@ -- | Initialize the pretty-printing options using the default user style initDefaultSDocContext :: DynFlags -> SDocContext initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle-
− compiler/GHC/Driver/Types.hs
@@ -1,3334 +0,0 @@-{--(c) The University of Glasgow, 2006--\section[GHC.Driver.Types]{Types for the per-module compiler}--}--{-# LANGUAGE CPP, ScopedTypeVariables #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DataKinds #-}---- | Types for the per-module compiler-module GHC.Driver.Types (- -- * compilation state- HscEnv(..), hscEPS,- FinderCache, FindResult(..), InstalledFindResult(..),- Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId,- HscStatus(..),-- -- * ModuleGraph- ModuleGraph, emptyMG, mkModuleGraph, extendMG, mapMG,- mgModSummaries, mgElemModule, mgLookupModule,- needsTemplateHaskellOrQQ, mgBootModules,-- -- * Hsc monad- Hsc(..), runHsc, mkInteractiveHscEnv, runInteractiveHsc,-- -- * Information about modules- ModDetails(..), emptyModDetails,- ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,- ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..),- ForeignSrcLang(..),- phaseForeignLanguage,-- ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, ms_home_imps,- home_imps, ms_home_allimps, ms_home_srcimps, showModMsg, isBootSummary,- msHsFilePath, msHiFilePath, msObjFilePath,- SourceModified(..), isTemplateHaskellOrQQNonBoot,-- -- * Information about the module being compiled- -- (re-exported from GHC.Driver.Phases)- HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString,--- -- * State relating to modules in this package- HomePackageTable, HomeModInfo(..), emptyHomePackageTable,- lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt,- addToHpt, addListToHpt, lookupHptDirectly, listToHpt,- hptCompleteSigs,- hptInstances, hptRules, pprHPT,-- -- * State relating to known packages- ExternalPackageState(..), EpsStats(..), addEpsInStats,- PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,- lookupIfaceByModule, emptyPartialModIface, emptyFullModIface, lookupHptByModule,-- PackageInstEnv, PackageFamInstEnv, PackageRuleBase,- PackageCompleteMatches,-- mkSOName, mkHsSOName, soExt,-- -- * Metaprogramming- MetaRequest(..),- MetaResult, -- data constructors not exported to ensure correct response type- metaRequestE, metaRequestP, metaRequestT, metaRequestD, metaRequestAW,- MetaHook,-- -- * Annotations- prepareAnnotations,-- -- * Interactive context- InteractiveContext(..), emptyInteractiveContext,- icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv,- extendInteractiveContext, extendInteractiveContextWithIds,- substInteractiveContext,- setInteractivePrintName, icInteractiveModule,- InteractiveImport(..),- mkPrintUnqualified, pprModulePrefix,- mkQualPackage, mkQualModule, pkgQual,-- -- * Interfaces- ModIface, PartialModIface, ModIface_(..), ModIfaceBackend(..),- mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,- emptyIfaceWarnCache, mi_boot, mi_fix,- mi_semantic_module,- mi_free_holes,- renameFreeHoles,-- -- * Fixity- FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,-- -- * TyThings and type environments- TyThing(..), tyThingAvailInfo,- tyThingTyCon, tyThingDataCon, tyThingConLike,- tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyCoVars,- implicitTyThings, implicitTyConThings, implicitClassThings,- isImplicitTyThing,-- TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,- typeEnvFromEntities, mkTypeEnvWithImplicits,- extendTypeEnv, extendTypeEnvList,- extendTypeEnvWithIds, plusTypeEnv,- lookupTypeEnv,- typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns,- typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,-- -- * MonadThings- MonadThings(..),-- -- * Information on imports and exports- WhetherHasOrphans, IsBootInterface(..), Usage(..),- Dependencies(..), noDependencies,- updNameCache,- IfaceExport,-- -- * Warnings- Warnings(..), WarningTxt(..), plusWarns,-- -- * Linker stuff- Linkable(..), isObjectLinkable, linkableObjs,- Unlinked(..), CompiledByteCode,- isObject, nameOfObject, isInterpretable, byteCodeOfObject,-- -- * Program coverage- HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage,-- -- * Breakpoints- ModBreaks (..), emptyModBreaks,-- -- * Safe Haskell information- IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,- trustInfoToNum, numToTrustInfo, IsSafeImport,-- -- * result of the parser- HsParsedModule(..),-- -- * Compilation errors and warnings- SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,- throwOneError, throwErrors, handleSourceError,- handleFlagWarnings, printOrThrowWarnings,-- -- * COMPLETE signature- ConLikeSet, CompleteMatch, CompleteMatches,-- -- * Exstensible Iface fields- ExtensibleFields(..), FieldName,- emptyExtensibleFields,- readField, readIfaceField, readIfaceFieldWith,- writeField, writeIfaceField, writeIfaceFieldWith,- deleteField, deleteIfaceField,- ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Driver.Ppr-import GHC.Driver.CmdLine-import GHC.Driver.Session--import GHC.ByteCode.Types-import GHC.Runtime.Eval.Types ( Resume )-import GHC.Runtime.Interpreter.Types (Interp)-import GHC.ForeignSrcLang--import GHC.Types.Unique.FM-import GHC.Hs-import GHC.Types.Name.Reader-import GHC.Types.Avail-import GHC.Unit-import GHC.Unit.State-import GHC.Core.InstEnv ( InstEnv, ClsInst, identicalClsInstHead )-import GHC.Core.FamInstEnv-import GHC.Core ( CoreProgram, RuleBase, CoreRule )-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Var.Set-import GHC.Types.Var-import GHC.Types.Id-import GHC.Types.Id.Info ( IdDetails(..), RecSelParent(..))-import GHC.Core.Type--import GHC.Parser.Annotation ( ApiAnns )-import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )-import GHC.Core.Class-import GHC.Core.TyCon-import GHC.Core.Coercion.Axiom-import GHC.Core.ConLike-import GHC.Core.DataCon-import GHC.Core.PatSyn-import GHC.Builtin.Names ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule )-import GHC.Builtin.Types-import GHC.Driver.Backend-import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) )-import GHC.Driver.Phases- ( Phase, HscSource(..), hscSourceString- , isHsBootOrSig, isHsigFile )-import qualified GHC.Driver.Phases as Phase-import GHC.Types.Basic-import GHC.Iface.Syntax-import GHC.Data.Maybe-import GHC.Utils.Outputable-import GHC.Types.SrcLoc-import GHC.Types.Unique-import GHC.Types.Unique.DFM-import GHC.Data.FastString-import GHC.Data.StringBuffer ( StringBuffer )-import GHC.Utils.Fingerprint-import GHC.Utils.Monad-import GHC.Data.Bag-import GHC.Utils.Binary-import GHC.Utils.Error-import GHC.Utils.Panic-import GHC.Types.Name.Cache-import GHC.Platform-import GHC.Utils.Misc-import GHC.Types.Unique.DSet-import GHC.Serialized ( Serialized )-import qualified GHC.LanguageExtensions as LangExt--import Foreign-import Control.Monad ( guard, liftM, ap, forM, forM_, replicateM )-import Data.IORef-import Data.Map ( Map )-import qualified Data.Map as Map-import Data.Time-import GHC.Utils.Exception-import System.FilePath-import Control.DeepSeq-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Class-import Control.Monad.Catch as MC (MonadCatch, catch)---- -------------------------------------------------------------------------------- Compilation state--- --------------------------------------------------------------------------------- | Status of a compilation to hard-code-data HscStatus- -- | Nothing to do.- = HscNotGeneratingCode ModIface ModDetails- -- | Nothing to do because code already exists.- | HscUpToDate ModIface ModDetails- -- | Update boot file result.- | HscUpdateBoot ModIface ModDetails- -- | Generate signature file (backpack)- | HscUpdateSig ModIface ModDetails- -- | Recompile this module.- | HscRecomp- { hscs_guts :: CgGuts- -- ^ Information for the code generator.- , hscs_mod_location :: !ModLocation- -- ^ Module info- , hscs_mod_details :: !ModDetails- , hscs_partial_iface :: !PartialModIface- -- ^ Partial interface- , hscs_old_iface_hash :: !(Maybe Fingerprint)- -- ^ Old interface hash for this compilation, if an old interface file- -- exists. Pass to `hscMaybeWriteIface` when writing the interface to- -- avoid updating the existing interface when the interface isn't- -- changed.- , hscs_iface_dflags :: !DynFlags- -- ^ Generate final iface using this DynFlags.- -- FIXME (osa): I don't understand why this is necessary, but I spent- -- almost two days trying to figure this out and I couldn't .. perhaps- -- someone who understands this code better will remove this later.- }--- Should HscStatus contain the HomeModInfo?--- All places where we return a status we also return a HomeModInfo.---- -------------------------------------------------------------------------------- The Hsc monad: Passing an environment and warning state--newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))- deriving (Functor)--instance Applicative Hsc where- pure a = Hsc $ \_ w -> return (a, w)- (<*>) = ap--instance Monad Hsc where- Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w- case k a of- Hsc k' -> k' e w1--instance MonadIO Hsc where- liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)--instance HasDynFlags Hsc where- getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)--runHsc :: HscEnv -> Hsc a -> IO a-runHsc hsc_env (Hsc hsc) = do- (a, w) <- hsc hsc_env emptyBag- printOrThrowWarnings (hsc_dflags hsc_env) w- return a--mkInteractiveHscEnv :: HscEnv -> HscEnv-mkInteractiveHscEnv hsc_env = hsc_env{ hsc_dflags = interactive_dflags }- where- interactive_dflags = ic_dflags (hsc_IC hsc_env)--runInteractiveHsc :: HscEnv -> Hsc a -> IO a--- A variant of runHsc that switches in the DynFlags from the--- InteractiveContext before running the Hsc computation.-runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)---- -------------------------------------------------------------------------------- Source Errors---- When the compiler (GHC.Driver.Main) discovers errors, it throws an--- exception in the IO monad.--mkSrcErr :: ErrorMessages -> SourceError-mkSrcErr = SourceError--srcErrorMessages :: SourceError -> ErrorMessages-srcErrorMessages (SourceError msgs) = msgs--mkApiErr :: DynFlags -> SDoc -> GhcApiError-mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)--throwErrors :: MonadIO io => ErrorMessages -> io a-throwErrors = liftIO . throwIO . mkSrcErr--throwOneError :: MonadIO io => ErrMsg -> io a-throwOneError = throwErrors . unitBag---- | A source error is an error that is caused by one or more errors in the--- source code. A 'SourceError' is thrown by many functions in the--- compilation pipeline. Inside GHC these errors are merely printed via--- 'log_action', but API clients may treat them differently, for example,--- insert them into a list box. If you want the default behaviour, use the--- idiom:------ > handleSourceError printExceptionAndWarnings $ do--- > ... api calls that may fail ...------ The 'SourceError's error messages can be accessed via 'srcErrorMessages'.--- This list may be empty if the compiler failed due to @-Werror@--- ('Opt_WarnIsError').------ See 'printExceptionAndWarnings' for more information on what to take care--- of when writing a custom error handler.-newtype SourceError = SourceError ErrorMessages--instance Show SourceError where- show (SourceError msgs) = unlines . map show . bagToList $ msgs--instance Exception SourceError---- | Perform the given action and call the exception handler if the action--- throws a 'SourceError'. See 'SourceError' for more information.-handleSourceError :: (MonadCatch m) =>- (SourceError -> m a) -- ^ exception handler- -> m a -- ^ action to perform- -> m a-handleSourceError handler act =- MC.catch act (\(e :: SourceError) -> handler e)---- | An error thrown if the GHC API is used in an incorrect fashion.-newtype GhcApiError = GhcApiError String--instance Show GhcApiError where- show (GhcApiError msg) = msg--instance Exception GhcApiError---- | Given a bag of warnings, turn them into an exception if--- -Werror is enabled, or print them out otherwise.-printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()-printOrThrowWarnings dflags warns = do- let (make_error, warns') =- mapAccumBagL- (\make_err warn ->- case isWarnMsgFatal dflags warn of- Nothing ->- (make_err, warn)- Just err_reason ->- (True, warn{ errMsgSeverity = SevError- , errMsgReason = ErrReason err_reason- }))- False warns- if make_error- then throwIO (mkSrcErr warns')- else printBagOfErrors dflags warns--handleFlagWarnings :: DynFlags -> [Warn] -> IO ()-handleFlagWarnings dflags warns = do- let warns' = filter (shouldPrintWarning dflags . warnReason) warns-- -- It would be nicer if warns :: [Located MsgDoc], but that- -- has circular import problems.- bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)- | Warn _ (L loc warn) <- warns' ]-- printOrThrowWarnings dflags bag---- Given a warn reason, check to see if it's associated -W opt is enabled-shouldPrintWarning :: DynFlags -> GHC.Driver.CmdLine.WarnReason -> Bool-shouldPrintWarning dflags ReasonDeprecatedFlag- = wopt Opt_WarnDeprecatedFlags dflags-shouldPrintWarning dflags ReasonUnrecognisedFlag- = wopt Opt_WarnUnrecognisedWarningFlags dflags-shouldPrintWarning _ _- = True--{--************************************************************************-* *-\subsection{HscEnv}-* *-************************************************************************--}---- | HscEnv is like 'Session', except that some of the fields are immutable.--- An HscEnv is used to compile a single module from plain Haskell source--- code (after preprocessing) to either C, assembly or C--. It's also used--- to store the dynamic linker state to allow for multiple linkers in the--- same address space.--- Things like the module graph don't change during a single compilation.------ Historical note: \"hsc\" used to be the name of the compiler binary,--- when there was a separate driver and compiler. To compile a single--- module, the driver would invoke hsc on the source code... so nowadays--- we think of hsc as the layer of the compiler that deals with compiling--- a single module.-data HscEnv- = HscEnv {- hsc_dflags :: DynFlags,- -- ^ The dynamic flag settings-- hsc_targets :: [Target],- -- ^ The targets (or roots) of the current session-- hsc_mod_graph :: ModuleGraph,- -- ^ The module graph of the current session-- hsc_IC :: InteractiveContext,- -- ^ The context for evaluating interactive statements-- hsc_HPT :: HomePackageTable,- -- ^ The home package table describes already-compiled- -- home-package modules, /excluding/ the module we- -- are compiling right now.- -- (In one-shot mode the current module is the only- -- home-package module, so hsc_HPT is empty. All other- -- modules count as \"external-package\" modules.- -- However, even in GHCi mode, hi-boot interfaces are- -- demand-loaded into the external-package table.)- --- -- 'hsc_HPT' is not mutable because we only demand-load- -- external packages; the home package is eagerly- -- loaded, module by module, by the compilation manager.- --- -- The HPT may contain modules compiled earlier by @--make@- -- but not actually below the current module in the dependency- -- graph.- --- -- (This changes a previous invariant: changed Jan 05.)-- hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState),- -- ^ Information about the currently loaded external packages.- -- This is mutable because packages will be demand-loaded during- -- a compilation run as required.-- hsc_NC :: {-# UNPACK #-} !(IORef NameCache),- -- ^ As with 'hsc_EPS', this is side-effected by compiling to- -- reflect sucking in interface files. They cache the state of- -- external interface files, in effect.-- hsc_FC :: {-# UNPACK #-} !(IORef FinderCache),- -- ^ The cached result of performing finding in the file system-- hsc_type_env_var :: Maybe (Module, IORef TypeEnv)- -- ^ Used for one-shot compilation only, to initialise- -- the 'IfGblEnv'. See 'GHC.Tc.Utils.tcg_type_env_var' for- -- 'GHC.Tc.Utils.TcGblEnv'. See also Note [hsc_type_env_var hack]-- , hsc_interp :: Maybe Interp- -- ^ target code interpreter (if any) to use for TH and GHCi.- -- See Note [Target code interpreter]-- , hsc_dynLinker :: DynLinker- -- ^ dynamic linker.-- }--{---Note [Target code interpreter]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Template Haskell and GHCi use an interpreter to execute code that is built for-the compiler target platform (= code host platform) on the compiler host-platform (= code build platform).--The internal interpreter can be used when both platforms are the same and when-the built code is compatible with the compiler itself (same way, etc.). This-interpreter is not always available: for instance stage1 compiler doesn't have-it because there might be an ABI mismatch between the code objects (built by-stage1 compiler) and the stage1 compiler itself (built by stage0 compiler).--In most cases, an external interpreter can be used instead: it runs in a-separate process and it communicates with the compiler via a two-way message-passing channel. The process is lazily spawned to avoid overhead when it is not-used.--The target code interpreter to use can be selected per session via the-`hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in-which case Template Haskell and GHCi will fail to run. The interpreter to use is-configured via command-line flags (in `GHC.setSessionDynFlags`).----}---- Note [hsc_type_env_var hack]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- hsc_type_env_var is used to initialize tcg_type_env_var, and--- eventually it is the mutable variable that is queried from--- if_rec_types to get a TypeEnv. So, clearly, it's something--- related to knot-tying (see Note [Tying the knot]).--- hsc_type_env_var is used in two places: initTcRn (where--- it initializes tcg_type_env_var) and initIfaceCheck--- (where it initializes if_rec_types).------ But why do we need a way to feed a mutable variable in? Why--- can't we just initialize tcg_type_env_var when we start--- typechecking? The problem is we need to knot-tie the--- EPS, and we may start adding things to the EPS before type--- checking starts.------ Here is a concrete example. Suppose we are running--- "ghc -c A.hs", and we have this file system state:------ A.hs-boot A.hi-boot **up to date**--- B.hs B.hi **up to date**--- A.hs A.hi **stale**------ The first thing we do is run checkOldIface on A.hi.--- checkOldIface will call loadInterface on B.hi so it can--- get its hands on the fingerprints, to find out if A.hi--- needs recompilation. But loadInterface also populates--- the EPS! And so if compilation turns out to be necessary,--- as it is in this case, the thunks we put into the EPS for--- B.hi need to have the correct if_rec_types mutable variable--- to query.------ If the mutable variable is only allocated WHEN we start--- typechecking, then that's too late: we can't get the--- information to the thunks. So we need to pre-commit--- to a type variable in 'hscIncrementalCompile' BEFORE we--- check the old interface.------ This is all a massive hack because arguably checkOldIface--- should not populate the EPS. But that's a refactor for--- another day.---- | Retrieve the ExternalPackageState cache.-hscEPS :: HscEnv -> IO ExternalPackageState-hscEPS hsc_env = readIORef (hsc_EPS hsc_env)---- | A compilation target.------ A target may be supplied with the actual text of the--- module. If so, use this instead of the file contents (this--- is for use in an IDE where the file hasn't been saved by--- the user yet).-data Target- = Target {- targetId :: TargetId, -- ^ module or filename- targetAllowObjCode :: Bool, -- ^ object code allowed?- targetContents :: Maybe (InputFileBuffer, UTCTime)- -- ^ Optional in-memory buffer containing the source code GHC should- -- use for this target instead of reading it from disk.- --- -- Since GHC version 8.10 modules which require preprocessors such as- -- Literate Haskell or CPP to run are also supported.- --- -- If a corresponding source file does not exist on disk this will- -- result in a 'SourceError' exception if @targetId = TargetModule _@- -- is used. However together with @targetId = TargetFile _@ GHC will- -- not complain about the file missing.- }--data TargetId- = TargetModule ModuleName- -- ^ A module name: search for the file- | TargetFile FilePath (Maybe Phase)- -- ^ A filename: preprocess & parse it to find the module name.- -- If specified, the Phase indicates how to compile this file- -- (which phase to start from). Nothing indicates the starting phase- -- should be determined from the suffix of the filename.- deriving Eq--type InputFileBuffer = StringBuffer--pprTarget :: Target -> SDoc-pprTarget (Target id obj _) =- (if obj then char '*' else empty) <> pprTargetId id--instance Outputable Target where- ppr = pprTarget--pprTargetId :: TargetId -> SDoc-pprTargetId (TargetModule m) = ppr m-pprTargetId (TargetFile f _) = text f--instance Outputable TargetId where- ppr = pprTargetId--{--************************************************************************-* *-\subsection{Package and Module Tables}-* *-************************************************************************--}---- | Helps us find information about modules in the home package-type HomePackageTable = DModuleNameEnv HomeModInfo- -- Domain = modules in the home package that have been fully compiled- -- "home" unit id cached here for convenience---- | Helps us find information about modules in the imported packages-type PackageIfaceTable = ModuleEnv ModIface- -- Domain = modules in the imported packages---- | Constructs an empty HomePackageTable-emptyHomePackageTable :: HomePackageTable-emptyHomePackageTable = emptyUDFM---- | Constructs an empty PackageIfaceTable-emptyPackageIfaceTable :: PackageIfaceTable-emptyPackageIfaceTable = emptyModuleEnv--pprHPT :: HomePackageTable -> SDoc--- A bit arbitrary for now-pprHPT hpt = pprUDFM hpt $ \hms ->- vcat [ hang (ppr (mi_module (hm_iface hm)))- 2 (ppr (md_types (hm_details hm)))- | hm <- hms ]--lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo-lookupHpt = lookupUDFM--lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo-lookupHptDirectly = lookupUDFM_Directly--eltsHpt :: HomePackageTable -> [HomeModInfo]-eltsHpt = eltsUDFM--filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable-filterHpt = filterUDFM--allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool-allHpt = allUDFM--mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable-mapHpt = mapUDFM--delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable-delFromHpt = delFromUDFM--addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable-addToHpt = addToUDFM--addListToHpt- :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable-addListToHpt = addListToUDFM--listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable-listToHpt = listToUDFM--lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo--- The HPT is indexed by ModuleName, not Module,--- we must check for a hit on the right Module-lookupHptByModule hpt mod- = case lookupHpt hpt (moduleName mod) of- Just hm | mi_module (hm_iface hm) == mod -> Just hm- _otherwise -> Nothing---- | Information about modules in the package being compiled-data HomeModInfo- = HomeModInfo {- hm_iface :: !ModIface,- -- ^ The basic loaded interface file: every loaded module has one of- -- these, even if it is imported from another package- hm_details :: !ModDetails,- -- ^ Extra information that has been created from the 'ModIface' for- -- the module, typically during typechecking- hm_linkable :: !(Maybe Linkable)- -- ^ The actual artifact we would like to link to access things in- -- this module.- --- -- 'hm_linkable' might be Nothing:- --- -- 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).- }---- | Find the 'ModIface' for a 'Module', searching in both the loaded home--- and external package module information-lookupIfaceByModule- :: HomePackageTable- -> PackageIfaceTable- -> Module- -> Maybe ModIface-lookupIfaceByModule hpt pit mod- = case lookupHptByModule hpt mod of- Just hm -> Just (hm_iface hm)- Nothing -> lookupModuleEnv pit mod---- If the module does come from the home package, why do we look in the PIT as well?--- (a) In OneShot mode, even home-package modules accumulate in the PIT--- (b) Even in Batch (--make) mode, there is *one* case where a home-package--- module is in the PIT, namely GHC.Prim when compiling the base package.--- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package--- of its own, but it doesn't seem worth the bother.--hptCompleteSigs :: HscEnv -> [CompleteMatch]-hptCompleteSigs = hptAllThings (md_complete_matches . hm_details)---- | Find all the instance declarations (of classes and families) from--- the Home Package Table filtered by the provided predicate function.--- Used in @tcRnImports@, to select the instances that are in the--- transitive closure of imports from the currently compiled module.-hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])-hptInstances hsc_env want_this_module- = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do- guard (want_this_module (moduleName (mi_module (hm_iface mod_info))))- let details = hm_details mod_info- return (md_insts details, md_fam_insts details)- in (concat insts, concat famInsts)---- | Get rules from modules "below" this one (in the dependency sense)-hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]-hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False----- | Get annotations from modules "below" this one (in the dependency sense)-hptAnns :: HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]-hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps-hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env--hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]-hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env))---- | Get things from modules "below" this one (in the dependency sense)--- C.f Inst.hptInstances-hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]-hptSomeThingsBelowUs extract include_hi_boot hsc_env deps- | isOneShot (ghcMode (hsc_dflags hsc_env)) = []-- | otherwise- = let hpt = hsc_HPT hsc_env- in- [ thing- | -- Find each non-hi-boot module below me- GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- deps- , include_hi_boot || (is_boot == NotBoot)-- -- unsavoury: when compiling the base package with --make, we- -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't- -- be in the HPT, because we never compile it; it's in the EPT- -- instead. ToDo: clean up, and remove this slightly bogus filter:- , mod /= moduleName gHC_PRIM-- -- Look it up in the HPT- , let things = case lookupHpt hpt mod of- Just info -> extract info- Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg []- msg = vcat [text "missing module" <+> ppr mod,- text "Probable cause: out-of-date interface files"]- -- This really shouldn't happen, but see #962-- -- And get its dfuns- , thing <- things ]---{--************************************************************************-* *-\subsection{Metaprogramming}-* *-************************************************************************--}---- | The supported metaprogramming result types-data MetaRequest- = MetaE (LHsExpr GhcPs -> MetaResult)- | MetaP (LPat GhcPs -> MetaResult)- | MetaT (LHsType GhcPs -> MetaResult)- | MetaD ([LHsDecl GhcPs] -> MetaResult)- | MetaAW (Serialized -> MetaResult)---- | data constructors not exported to ensure correct result type-data MetaResult- = MetaResE { unMetaResE :: LHsExpr GhcPs }- | MetaResP { unMetaResP :: LPat GhcPs }- | MetaResT { unMetaResT :: LHsType GhcPs }- | MetaResD { unMetaResD :: [LHsDecl GhcPs] }- | MetaResAW { unMetaResAW :: Serialized }--type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult--metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs)-metaRequestE h = fmap unMetaResE . h (MetaE MetaResE)--metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs)-metaRequestP h = fmap unMetaResP . h (MetaP MetaResP)--metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs)-metaRequestT h = fmap unMetaResT . h (MetaT MetaResT)--metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs]-metaRequestD h = fmap unMetaResD . h (MetaD MetaResD)--metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized-metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW)--{--************************************************************************-* *-\subsection{Dealing with Annotations}-* *-************************************************************************--}---- | Deal with gathering annotations in from all possible places--- and combining them into a single 'AnnEnv'-prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv-prepareAnnotations hsc_env mb_guts = do- eps <- hscEPS hsc_env- let -- Extract annotations from the module being compiled if supplied one- mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts- -- Extract dependencies of the module if we are supplied one,- -- otherwise load annotations from all home package table- -- entries regardless of dependency ordering.- home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts- other_pkg_anns = eps_ann_env eps- ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns,- Just home_pkg_anns,- Just other_pkg_anns]- return ann_env--{--************************************************************************-* *-\subsection{The Finder cache}-* *-************************************************************************--}---- | The 'FinderCache' maps modules to the result of--- searching for that module. It records the results of searching for--- modules along the search path. On @:load@, we flush the entire--- contents of this cache.----type FinderCache = InstalledModuleEnv InstalledFindResult--data InstalledFindResult- = InstalledFound ModLocation InstalledModule- | InstalledNoPackage UnitId- | InstalledNotFound [FilePath] (Maybe UnitId)---- | The result of searching for an imported module.------ NB: FindResult manages both user source-import lookups--- (which can result in 'Module') as well as direct imports--- for interfaces (which always result in 'InstalledModule').-data FindResult- = Found ModLocation Module- -- ^ The module was found- | NoPackage Unit- -- ^ The requested unit was not found- | FoundMultiple [(Module, ModuleOrigin)]- -- ^ _Error_: both in multiple packages-- -- | Not found- | NotFound- { fr_paths :: [FilePath] -- ^ Places where I looked-- , fr_pkg :: Maybe Unit -- ^ Just p => module is in this unit's- -- manifest, but couldn't find the- -- .hi file-- , fr_mods_hidden :: [Unit] -- ^ Module is in these units,- -- but the *module* is hidden-- , fr_pkgs_hidden :: [Unit] -- ^ Module is in these units,- -- but the *unit* is hidden-- -- | Module is in these units, but it is unusable- , fr_unusables :: [(Unit, UnusableUnitReason)]-- , fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules- }--{--************************************************************************-* *-\subsection{Symbol tables and Module details}-* *-************************************************************************--}--{- Note [Interface file stages]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Interface files have two possible stages.--* A partial stage built from the result of the core pipeline.-* A fully instantiated form. Which also includes fingerprints and- potentially information provided by backends.--We can build a full interface file two ways:-* Directly from a partial one:- Then we omit backend information and mostly compute fingerprints.-* From a partial one + information produced by a backend.- Then we store the provided information and fingerprint both.--}--type PartialModIface = ModIface_ 'ModIfaceCore-type ModIface = ModIface_ 'ModIfaceFinal---- | Extends a PartialModIface with information which is either:--- * Computed after codegen--- * Or computed just before writing the iface to disk. (Hashes)--- In order to fully instantiate it.-data ModIfaceBackend = ModIfaceBackend- { mi_iface_hash :: !Fingerprint- -- ^ Hash of the whole interface- , mi_mod_hash :: !Fingerprint- -- ^ Hash of the ABI only- , mi_flag_hash :: !Fingerprint- -- ^ Hash of the important flags used when compiling the module, excluding- -- optimisation flags- , mi_opt_hash :: !Fingerprint- -- ^ Hash of optimisation flags- , mi_hpc_hash :: !Fingerprint- -- ^ Hash of hpc flags- , mi_plugin_hash :: !Fingerprint- -- ^ Hash of plugins- , mi_orphan :: !WhetherHasOrphans- -- ^ Whether this module has orphans- , mi_finsts :: !WhetherHasFamInst- -- ^ Whether this module has family instances. See Note [The type family- -- instance consistency story].- , mi_exp_hash :: !Fingerprint- -- ^ Hash of export list- , mi_orphan_hash :: !Fingerprint- -- ^ Hash for orphan rules, class and family instances combined-- -- Cached environments for easy lookup. These are computed (lazily) from- -- other fields and are not put into the interface file.- -- Not really produced by the backend but there is no need to create them- -- any earlier.- , mi_warn_fn :: !(OccName -> Maybe WarningTxt)- -- ^ Cached lookup for 'mi_warns'- , mi_fix_fn :: !(OccName -> Maybe Fixity)- -- ^ Cached lookup for 'mi_fixities'- , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint))- -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that- -- the thing isn't in decls. It's useful to know that when seeing if we are- -- up to date wrt. the old interface. The 'OccName' is the parent of the- -- name, if it has one.- }--data ModIfacePhase- = ModIfaceCore- -- ^ Partial interface built based on output of core pipeline.- | ModIfaceFinal---- | Selects a IfaceDecl representation.--- For fully instantiated interfaces we also maintain--- a fingerprint, which is used for recompilation checks.-type family IfaceDeclExts (phase :: ModIfacePhase) where- IfaceDeclExts 'ModIfaceCore = IfaceDecl- IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl)--type family IfaceBackendExts (phase :: ModIfacePhase) where- IfaceBackendExts 'ModIfaceCore = ()- IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend------ | A 'ModIface' plus a 'ModDetails' summarises everything we know--- about a compiled module. The 'ModIface' is the stuff *before* linking,--- and can be written out to an interface file. The 'ModDetails is after--- linking and can be completely recovered from just the 'ModIface'.------ When we read an interface file, we also construct a 'ModIface' from it,--- except that we explicitly make the 'mi_decls' and a few other fields empty;--- as when reading we consolidate the declarations etc. into a number of indexed--- maps and environments in the 'ExternalPackageState'.-data ModIface_ (phase :: ModIfacePhase)- = ModIface {- mi_module :: !Module, -- ^ Name of the module we are for- mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod?-- mi_hsc_src :: !HscSource, -- ^ Boot? Signature?-- mi_deps :: Dependencies,- -- ^ The dependencies of the module. This is- -- consulted for directly-imported modules, but not- -- for anything else (hence lazy)-- mi_usages :: [Usage],- -- ^ Usages; kept sorted so that it's easy to decide- -- whether to write a new iface file (changing usages- -- doesn't affect the hash of this module)- -- NOT STRICT! we read this field lazily from the interface file- -- It is *only* consulted by the recompilation checker-- mi_exports :: ![IfaceExport],- -- ^ Exports- -- Kept sorted by (mod,occ), to make version comparisons easier- -- Records the modules that are the declaration points for things- -- exported by this module, and the 'OccName's of those things--- mi_used_th :: !Bool,- -- ^ Module required TH splices when it was compiled.- -- This disables recompilation avoidance (see #481).-- mi_fixities :: [(OccName,Fixity)],- -- ^ Fixities- -- NOT STRICT! we read this field lazily from the interface file-- mi_warns :: Warnings,- -- ^ Warnings- -- NOT STRICT! we read this field lazily from the interface file-- mi_anns :: [IfaceAnnotation],- -- ^ Annotations- -- NOT STRICT! we read this field lazily from the interface file--- mi_decls :: [IfaceDeclExts phase],- -- ^ Type, class and variable declarations- -- The hash of an Id changes if its fixity or deprecations change- -- (as well as its type of course)- -- Ditto data constructors, class operations, except that- -- the hash of the parent class/tycon changes-- mi_globals :: !(Maybe GlobalRdrEnv),- -- ^ Binds all the things defined at the top level in- -- the /original source/ code for this module. which- -- is NOT the same as mi_exports, nor mi_decls (which- -- may contains declarations for things not actually- -- defined by the user). Used for GHCi and for inspecting- -- the contents of modules via the GHC API only.- --- -- (We need the source file to figure out the- -- top-level environment, if we didn't compile this module- -- from source then this field contains @Nothing@).- --- -- Strictly speaking this field should live in the- -- 'HomeModInfo', but that leads to more plumbing.-- -- Instance declarations and rules- mi_insts :: [IfaceClsInst], -- ^ Sorted class instance- mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances- mi_rules :: [IfaceRule], -- ^ Sorted rules-- mi_hpc :: !AnyHpcUsage,- -- ^ True if this program uses Hpc at any point in the program.-- mi_trust :: !IfaceTrustInfo,- -- ^ Safe Haskell Trust information for this module.-- mi_trust_pkg :: !Bool,- -- ^ Do we require the package this module resides in be trusted- -- to trust this module? This is used for the situation where a- -- module is Safe (so doesn't require the package be trusted- -- itself) but imports some trustworthy modules from its own- -- package (which does require its own package be trusted).- -- See Note [Trust Own Package] in GHC.Rename.Names- mi_complete_matches :: [IfaceCompleteMatch],-- mi_doc_hdr :: Maybe HsDocString,- -- ^ Module header.-- mi_decl_docs :: DeclDocMap,- -- ^ Docs on declarations.-- mi_arg_docs :: ArgDocMap,- -- ^ Docs on arguments.-- mi_final_exts :: !(IfaceBackendExts phase),- -- ^ Either `()` or `ModIfaceBackend` for- -- a fully instantiated interface.-- mi_ext_fields :: ExtensibleFields- -- ^ Additional optional fields, where the Map key represents- -- the field name, resulting in a (size, serialized data) pair.- -- Because the data is intended to be serialized through the- -- internal `Binary` class (increasing compatibility with types- -- using `Name` and `FastString`, such as HIE), this format is- -- chosen over `ByteString`s.- }---- | Old-style accessor for whether or not the ModIface came from an hs-boot--- file.-mi_boot :: ModIface -> IsBootInterface-mi_boot iface = if mi_hsc_src iface == HsBootFile- then IsBoot- else NotBoot---- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be--- found, 'defaultFixity' is returned instead.-mi_fix :: ModIface -> OccName -> Fixity-mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity---- | The semantic module for this interface; e.g., if it's a interface--- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module'--- will be @<A>@.-mi_semantic_module :: ModIface_ a -> Module-mi_semantic_module iface = case mi_sig_of iface of- Nothing -> mi_module iface- Just mod -> mod---- | The "precise" free holes, e.g., the signatures that this--- 'ModIface' depends on.-mi_free_holes :: ModIface -> UniqDSet ModuleName-mi_free_holes iface =- case getModuleInstantiation (mi_module iface) of- (_, Just indef)- -- A mini-hack: we rely on the fact that 'renameFreeHoles'- -- drops things that aren't holes.- -> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef))- _ -> emptyUniqDSet- where- cands = map gwib_mod $ dep_mods $ mi_deps iface---- | Given a set of free holes, and a unit identifier, rename--- the free holes according to the instantiation of the unit--- identifier. For example, if we have A and B free, and--- our unit identity is @p[A=<C>,B=impl:B]@, the renamed free--- holes are just C.-renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName-renameFreeHoles fhs insts =- unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs))- where- hmap = listToUFM insts- lookup_impl mod_name- | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod- -- It wasn't actually a hole- | otherwise = emptyUniqDSet--instance Binary ModIface where- put_ bh (ModIface {- mi_module = mod,- mi_sig_of = sig_of,- mi_hsc_src = hsc_src,- mi_deps = deps,- mi_usages = usages,- mi_exports = exports,- mi_used_th = used_th,- mi_fixities = fixities,- mi_warns = warns,- mi_anns = anns,- mi_decls = decls,- mi_insts = insts,- mi_fam_insts = fam_insts,- mi_rules = rules,- mi_hpc = hpc_info,- mi_trust = trust,- mi_trust_pkg = trust_pkg,- mi_complete_matches = complete_matches,- mi_doc_hdr = doc_hdr,- mi_decl_docs = decl_docs,- mi_arg_docs = arg_docs,- mi_ext_fields = _ext_fields, -- Don't `put_` this in the instance so we- -- can deal with it's pointer in the header- -- when we write the actual file- mi_final_exts = ModIfaceBackend {- mi_iface_hash = iface_hash,- mi_mod_hash = mod_hash,- mi_flag_hash = flag_hash,- mi_opt_hash = opt_hash,- mi_hpc_hash = hpc_hash,- mi_plugin_hash = plugin_hash,- mi_orphan = orphan,- mi_finsts = hasFamInsts,- mi_exp_hash = exp_hash,- mi_orphan_hash = orphan_hash- }}) = do- put_ bh mod- put_ bh sig_of- put_ bh hsc_src- put_ bh iface_hash- put_ bh mod_hash- put_ bh flag_hash- put_ bh opt_hash- put_ bh hpc_hash- put_ bh plugin_hash- put_ bh orphan- put_ bh hasFamInsts- lazyPut bh deps- lazyPut bh usages- put_ bh exports- put_ bh exp_hash- put_ bh used_th- put_ bh fixities- lazyPut bh warns- lazyPut bh anns- put_ bh decls- put_ bh insts- put_ bh fam_insts- lazyPut bh rules- put_ bh orphan_hash- put_ bh hpc_info- put_ bh trust- put_ bh trust_pkg- put_ bh complete_matches- lazyPut bh doc_hdr- lazyPut bh decl_docs- lazyPut bh arg_docs-- get bh = do- mod <- get bh- sig_of <- get bh- hsc_src <- get bh- iface_hash <- get bh- mod_hash <- get bh- flag_hash <- get bh- opt_hash <- get bh- hpc_hash <- get bh- plugin_hash <- get bh- orphan <- get bh- hasFamInsts <- get bh- deps <- lazyGet bh- usages <- {-# SCC "bin_usages" #-} lazyGet bh- exports <- {-# SCC "bin_exports" #-} get bh- exp_hash <- get bh- used_th <- get bh- fixities <- {-# SCC "bin_fixities" #-} get bh- warns <- {-# SCC "bin_warns" #-} lazyGet bh- anns <- {-# SCC "bin_anns" #-} lazyGet bh- decls <- {-# SCC "bin_tycldecls" #-} get bh- insts <- {-# SCC "bin_insts" #-} get bh- fam_insts <- {-# SCC "bin_fam_insts" #-} get bh- rules <- {-# SCC "bin_rules" #-} lazyGet bh- orphan_hash <- get bh- hpc_info <- get bh- trust <- get bh- trust_pkg <- get bh- complete_matches <- get bh- doc_hdr <- lazyGet bh- decl_docs <- lazyGet bh- arg_docs <- lazyGet bh- return (ModIface {- mi_module = mod,- mi_sig_of = sig_of,- mi_hsc_src = hsc_src,- mi_deps = deps,- mi_usages = usages,- mi_exports = exports,- mi_used_th = used_th,- mi_anns = anns,- mi_fixities = fixities,- mi_warns = warns,- mi_decls = decls,- mi_globals = Nothing,- mi_insts = insts,- mi_fam_insts = fam_insts,- mi_rules = rules,- mi_hpc = hpc_info,- mi_trust = trust,- mi_trust_pkg = trust_pkg,- -- And build the cached values- mi_complete_matches = complete_matches,- mi_doc_hdr = doc_hdr,- mi_decl_docs = decl_docs,- mi_arg_docs = arg_docs,- mi_ext_fields = emptyExtensibleFields, -- placeholder because this is dealt- -- with specially when the file is read- mi_final_exts = ModIfaceBackend {- mi_iface_hash = iface_hash,- mi_mod_hash = mod_hash,- mi_flag_hash = flag_hash,- mi_opt_hash = opt_hash,- mi_hpc_hash = hpc_hash,- mi_plugin_hash = plugin_hash,- mi_orphan = orphan,- mi_finsts = hasFamInsts,- mi_exp_hash = exp_hash,- mi_orphan_hash = orphan_hash,- mi_warn_fn = mkIfaceWarnCache warns,- mi_fix_fn = mkIfaceFixCache fixities,- mi_hash_fn = mkIfaceHashCache decls- }})---- | The original names declared of a certain module that are exported-type IfaceExport = AvailInfo--emptyPartialModIface :: Module -> PartialModIface-emptyPartialModIface mod- = ModIface { mi_module = mod,- mi_sig_of = Nothing,- mi_hsc_src = HsSrcFile,- mi_deps = noDependencies,- mi_usages = [],- mi_exports = [],- mi_used_th = False,- mi_fixities = [],- mi_warns = NoWarnings,- mi_anns = [],- mi_insts = [],- mi_fam_insts = [],- mi_rules = [],- mi_decls = [],- mi_globals = Nothing,- mi_hpc = False,- mi_trust = noIfaceTrustInfo,- mi_trust_pkg = False,- mi_complete_matches = [],- mi_doc_hdr = Nothing,- mi_decl_docs = emptyDeclDocMap,- mi_arg_docs = emptyArgDocMap,- mi_final_exts = (),- mi_ext_fields = emptyExtensibleFields- }--emptyFullModIface :: Module -> ModIface-emptyFullModIface mod =- (emptyPartialModIface mod)- { mi_decls = []- , mi_final_exts = ModIfaceBackend- { mi_iface_hash = fingerprint0,- mi_mod_hash = fingerprint0,- mi_flag_hash = fingerprint0,- mi_opt_hash = fingerprint0,- mi_hpc_hash = fingerprint0,- mi_plugin_hash = fingerprint0,- mi_orphan = False,- mi_finsts = False,- mi_exp_hash = fingerprint0,- mi_orphan_hash = fingerprint0,- mi_warn_fn = emptyIfaceWarnCache,- mi_fix_fn = emptyIfaceFixCache,- mi_hash_fn = emptyIfaceHashCache } }---- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'-mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]- -> (OccName -> Maybe (OccName, Fingerprint))-mkIfaceHashCache pairs- = \occ -> lookupOccEnv env occ- where- env = foldl' add_decl emptyOccEnv pairs- add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d)- where- add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash)--emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)-emptyIfaceHashCache _occ = Nothing----- | The 'ModDetails' is essentially a cache for information in the 'ModIface'--- for home modules only. Information relating to packages will be loaded into--- global environments in 'ExternalPackageState'.-data ModDetails- = ModDetails {- -- The next two fields are created by the typechecker- md_exports :: [AvailInfo],- md_types :: !TypeEnv, -- ^ Local type environment for this particular module- -- Includes Ids, TyCons, PatSyns- md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module- md_fam_insts :: ![FamInst],- md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules- md_anns :: ![Annotation], -- ^ Annotations present in this module: currently- -- they only annotate things also declared in this module- md_complete_matches :: [CompleteMatch]- -- ^ Complete match pragmas for this module- }---- | Constructs an empty ModDetails-emptyModDetails :: ModDetails-emptyModDetails- = ModDetails { md_types = emptyTypeEnv,- md_exports = [],- md_insts = [],- md_rules = [],- md_fam_insts = [],- md_anns = [],- md_complete_matches = [] }---- | Records the modules directly imported by a module for extracting e.g.--- usage information, and also to give better error message-type ImportedMods = ModuleEnv [ImportedBy]---- | If a module was "imported" by the user, we associate it with--- more detailed usage information 'ImportedModsVal'; a module--- imported by the system only gets used for usage information.-data ImportedBy- = ImportedByUser ImportedModsVal- | ImportedBySystem--importedByUser :: [ImportedBy] -> [ImportedModsVal]-importedByUser (ImportedByUser imv : bys) = imv : importedByUser bys-importedByUser (ImportedBySystem : bys) = importedByUser bys-importedByUser [] = []--data ImportedModsVal- = ImportedModsVal {- imv_name :: ModuleName, -- ^ The name the module is imported with- imv_span :: SrcSpan, -- ^ the source span of the whole import- imv_is_safe :: IsSafeImport, -- ^ whether this is a safe import- imv_is_hiding :: Bool, -- ^ whether this is an "hiding" import- imv_all_exports :: !GlobalRdrEnv, -- ^ all the things the module could provide- -- NB. BangPattern here: otherwise this leaks. (#15111)- imv_qualified :: Bool -- ^ whether this is a qualified import- }---- | A ModGuts is carried through the compiler, accumulating stuff as it goes--- There is only one ModGuts at any time, the one for the module--- being compiled right now. Once it is compiled, a 'ModIface' and--- 'ModDetails' are extracted and the ModGuts is discarded.-data ModGuts- = ModGuts {- mg_module :: !Module, -- ^ Module being compiled- mg_hsc_src :: HscSource, -- ^ Whether it's an hs-boot module- mg_loc :: SrcSpan, -- ^ For error messages from inner passes- mg_exports :: ![AvailInfo], -- ^ What it exports- mg_deps :: !Dependencies, -- ^ What it depends on, directly or- -- otherwise- mg_usages :: ![Usage], -- ^ What was used? Used for interfaces.-- mg_used_th :: !Bool, -- ^ Did we run a TH splice?- mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment-- -- These fields all describe the things **declared in this module**- mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module.- -- Used for creating interface files.- mg_tcs :: ![TyCon], -- ^ TyCons declared in this module- -- (includes TyCons for classes)- mg_insts :: ![ClsInst], -- ^ Class instances declared in this module- mg_fam_insts :: ![FamInst],- -- ^ Family instances declared in this module- mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module- mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains- -- See Note [Overall plumbing for rules] in "GHC.Core.Rules"- mg_binds :: !CoreProgram, -- ^ Bindings for this module- mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module- mg_foreign_files :: ![(ForeignSrcLang, FilePath)],- -- ^ Files to be compiled with the C compiler- mg_warns :: !Warnings, -- ^ Warnings declared in the module- mg_anns :: [Annotation], -- ^ Annotations declared in this module- mg_complete_matches :: [CompleteMatch], -- ^ Complete Matches- mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module- mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module-- -- The next two fields are unusual, because they give instance- -- environments for *all* modules in the home package, including- -- this module, rather than for *just* this module.- -- Reason: when looking up an instance we don't want to have to- -- look at each module in the home package in turn- mg_inst_env :: InstEnv, -- ^ Class instance environment for- -- /home-package/ modules (including this- -- one); c.f. 'tcg_inst_env'- mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance environment for- -- /home-package/ modules (including this- -- one); c.f. 'tcg_fam_inst_env'-- mg_safe_haskell :: SafeHaskellMode, -- ^ Safe Haskell mode- mg_trust_pkg :: Bool, -- ^ Do we need to trust our- -- own package for Safe Haskell?- -- See Note [Trust Own Package]- -- in "GHC.Rename.Names"-- mg_doc_hdr :: !(Maybe HsDocString), -- ^ Module header.- mg_decl_docs :: !DeclDocMap, -- ^ Docs on declarations.- mg_arg_docs :: !ArgDocMap -- ^ Docs on arguments.- }---- The ModGuts takes on several slightly different forms:------ After simplification, the following fields change slightly:--- mg_rules Orphan rules only (local ones now attached to binds)--- mg_binds With rules attached-------------------------------------------------------------- The Tidy pass forks the information about this module:--- * one lot goes to interface file generation (ModIface)--- and later compilations (ModDetails)--- * the other lot goes to code generation (CgGuts)---- | A restricted form of 'ModGuts' for code generation purposes-data CgGuts- = CgGuts {- cg_module :: !Module,- -- ^ Module being compiled-- cg_tycons :: [TyCon],- -- ^ Algebraic data types (including ones that started- -- life as classes); generate constructors and info- -- tables. Includes newtypes, just for the benefit of- -- External Core-- cg_binds :: CoreProgram,- -- ^ The tidied main bindings, including- -- previously-implicit bindings for record and class- -- selectors, and data constructor wrappers. But *not*- -- data constructor workers; reason: we regard them- -- as part of the code-gen of tycons-- cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs- cg_foreign_files :: ![(ForeignSrcLang, FilePath)],- cg_dep_pkgs :: ![UnitId], -- ^ Dependent packages, used to- -- generate #includes for C code gen- cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information- cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints- cg_spt_entries :: [SptEntry]- -- ^ Static pointer table entries for static forms defined in- -- the module.- -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable"- }---------------------------------------- | Foreign export stubs-data ForeignStubs- = NoStubs- -- ^ We don't have any stubs- | ForeignStubs SDoc SDoc- -- ^ There are some stubs. Parameters:- --- -- 1) Header file prototypes for- -- "foreign exported" functions- --- -- 2) C stubs to use when calling- -- "foreign exported" functions--appendStubC :: ForeignStubs -> SDoc -> ForeignStubs-appendStubC NoStubs c_code = ForeignStubs empty c_code-appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code)--{--************************************************************************-* *- The interactive context-* *-************************************************************************--Note [The interactive package]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Type, class, and value declarations at the command prompt are treated-as if they were defined in modules- interactive:Ghci1- interactive:Ghci2- ...etc...-with each bunch of declarations using a new module, all sharing a-common package 'interactive' (see Module.interactiveUnitId, and-GHC.Builtin.Names.mkInteractiveModule).--This scheme deals well with shadowing. For example:-- ghci> data T = A- ghci> data T = B- ghci> :i A- data Ghci1.T = A -- Defined at <interactive>:2:10--Here we must display info about constructor A, but its type T has been-shadowed by the second declaration. But it has a respectable-qualified name (Ghci1.T), and its source location says where it was-defined.--So the main invariant continues to hold, that in any session an-original name M.T only refers to one unique thing. (In a previous-iteration both the T's above were called :Interactive.T, albeit with-different uniques, which gave rise to all sorts of trouble.)--The details are a bit tricky though:-- * The field ic_mod_index counts which Ghci module we've got up to.- It is incremented when extending ic_tythings-- * ic_tythings contains only things from the 'interactive' package.-- * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go- in the Home Package Table (HPT). When you say :load, that's when we- extend the HPT.-- * The 'homeUnitId' field of DynFlags is *not* set to 'interactive'.- It stays as 'main' (or whatever -this-unit-id says), and is the- package to which :load'ed modules are added to.-- * So how do we arrange that declarations at the command prompt get to- be in the 'interactive' package? Simply by setting the tcg_mod- field of the TcGblEnv to "interactive:Ghci1". This is done by the- call to initTc in initTcInteractive, which in turn get the module- from it 'icInteractiveModule' field of the interactive context.-- The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says.-- * The main trickiness is that the type environment (tcg_type_env) and- fixity envt (tcg_fix_env), now contain entities from all the- interactive-package modules (Ghci1, Ghci2, ...) together, rather- than just a single module as is usually the case. So you can't use- "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs- the HPT/PTE. This is a change, but not a problem provided you- know.--* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields- of the TcGblEnv, which collect "things defined in this module", all- refer to stuff define in a single GHCi command, *not* all the commands- so far.-- In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from- all GhciN modules, which makes sense -- they are all "home package"- modules.---Note [Interactively-bound Ids in GHCi]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The Ids bound by previous Stmts in GHCi are currently- a) GlobalIds, with- b) An External Name, like Ghci4.foo- See Note [The interactive package] above- c) A tidied type-- (a) They must be GlobalIds (not LocalIds) otherwise when we come to- compile an expression using these ids later, the byte code- generator will consider the occurrences to be free rather than- global.-- (b) Having an External Name is important because of Note- [GlobalRdrEnv shadowing] in GHC.Types.Names.RdrName-- (c) Their types are tidied. This is important, because :info may ask- to look at them, and :info expects the things it looks up to have- tidy types--Where do interactively-bound Ids come from?-- - GHCi REPL Stmts e.g.- ghci> let foo x = x+1- These start with an Internal Name because a Stmt is a local- construct, so the renamer naturally builds an Internal name for- each of its binders. Then in tcRnStmt they are externalised via- GHC.Tc.Module.externaliseAndTidyId, so they get Names like Ghic4.foo.-- - Ids bound by the debugger etc have Names constructed by- GHC.Iface.Env.newInteractiveBinder; at the call sites it is followed by- mkVanillaGlobal or mkVanillaGlobalWithInfo. So again, they are- all Global, External.-- - TyCons, Classes, and Ids bound by other top-level declarations in- GHCi (eg foreign import, record selectors) also get External- Names, with Ghci9 (or 8, or 7, etc) as the module name.---Note [ic_tythings]-~~~~~~~~~~~~~~~~~~-The ic_tythings field contains- * The TyThings declared by the user at the command prompt- (eg Ids, TyCons, Classes)-- * The user-visible Ids that arise from such things, which- *don't* come from 'implicitTyThings', notably:- - record selectors- - class ops- The implicitTyThings are readily obtained from the TyThings- but record selectors etc are not--It does *not* contain- * DFunIds (they can be gotten from ic_instances)- * CoAxioms (ditto)--See also Note [Interactively-bound Ids in GHCi]--Note [Override identical instances in GHCi]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If you declare a new instance in GHCi that is identical to a previous one,-we simply override the previous one; we don't regard it as overlapping.-e.g. Prelude> data T = A | B- Prelude> instance Eq T where ...- Prelude> instance Eq T where ... -- This one overrides--It's exactly the same for type-family instances. See #7102--}---- | Interactive context, recording information about the state of the--- context in which statements are executed in a GHCi session.-data InteractiveContext- = InteractiveContext {- ic_dflags :: DynFlags,- -- ^ The 'DynFlags' used to evaluate interactive expressions- -- and statements.-- ic_mod_index :: Int,- -- ^ Each GHCi stmt or declaration brings some new things into- -- scope. We give them names like interactive:Ghci9.T,- -- where the ic_index is the '9'. The ic_mod_index is- -- incremented whenever we add something to ic_tythings- -- See Note [The interactive package]-- ic_imports :: [InteractiveImport],- -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with- -- these imports- --- -- This field is only stored here so that the client- -- can retrieve it with GHC.getContext. GHC itself doesn't- -- use it, but does reset it to empty sometimes (such- -- as before a GHC.load). The context is set with GHC.setContext.-- ic_tythings :: [TyThing],- -- ^ TyThings defined by the user, in reverse order of- -- definition (ie most recent at the front)- -- See Note [ic_tythings]-- ic_rn_gbl_env :: GlobalRdrEnv,- -- ^ The cached 'GlobalRdrEnv', built by- -- 'GHC.Runtime.Eval.setContext' and updated regularly- -- It contains everything in scope at the command line,- -- including everything in ic_tythings-- ic_instances :: ([ClsInst], [FamInst]),- -- ^ All instances and family instances created during- -- this session. These are grabbed en masse after each- -- update to be sure that proper overlapping is retained.- -- That is, rather than re-check the overlapping each- -- time we update the context, we just take the results- -- from the instance code that already does that.-- ic_fix_env :: FixityEnv,- -- ^ Fixities declared in let statements-- ic_default :: Maybe [Type],- -- ^ The current default types, set by a 'default' declaration-- ic_resume :: [Resume],- -- ^ The stack of breakpoint contexts-- ic_monad :: Name,- -- ^ The monad that GHCi is executing in-- ic_int_print :: Name,- -- ^ The function that is used for printing results- -- of expressions in ghci and -e mode.-- ic_cwd :: Maybe FilePath- -- virtual CWD of the program- }--data InteractiveImport- = IIDecl (ImportDecl GhcPs)- -- ^ Bring the exports of a particular module- -- (filtered by an import decl) into scope-- | IIModule ModuleName- -- ^ Bring into scope the entire top-level envt of- -- of this module, including the things imported- -- into it.----- | Constructs an empty InteractiveContext.-emptyInteractiveContext :: DynFlags -> InteractiveContext-emptyInteractiveContext dflags- = InteractiveContext {- ic_dflags = dflags,- ic_imports = [],- ic_rn_gbl_env = emptyGlobalRdrEnv,- ic_mod_index = 1,- ic_tythings = [],- ic_instances = ([],[]),- ic_fix_env = emptyNameEnv,- ic_monad = ioTyConName, -- IO monad by default- ic_int_print = printName, -- System.IO.print by default- ic_default = Nothing,- ic_resume = [],- ic_cwd = Nothing }--icInteractiveModule :: InteractiveContext -> Module-icInteractiveModule (InteractiveContext { ic_mod_index = index })- = mkInteractiveModule index---- | This function returns the list of visible TyThings (useful for--- e.g. showBindings)-icInScopeTTs :: InteractiveContext -> [TyThing]-icInScopeTTs = ic_tythings---- | Get the PrintUnqualified function based on the flags and this InteractiveContext-icPrintUnqual :: UnitState -> HomeUnit -> InteractiveContext -> PrintUnqualified-icPrintUnqual unit_state home_unit InteractiveContext{ ic_rn_gbl_env = grenv } =- mkPrintUnqualified unit_state home_unit grenv---- | extendInteractiveContext is called with new TyThings recently defined to update the--- InteractiveContext to include them. Ids are easily removed when shadowed,--- but Classes and TyCons are not. Some work could be done to determine--- whether they are entirely shadowed, but as you could still have references--- to them (e.g. instances for classes or values of the type for TyCons), it's--- not clear whether removing them is even the appropriate behavior.-extendInteractiveContext :: InteractiveContext- -> [TyThing]- -> [ClsInst] -> [FamInst]- -> Maybe [Type]- -> FixityEnv- -> InteractiveContext-extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env- = ictxt { ic_mod_index = ic_mod_index ictxt + 1- -- Always bump this; even instances should create- -- a new mod_index (#9426)- , ic_tythings = new_tythings ++ old_tythings- , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings- , ic_instances = ( new_cls_insts ++ old_cls_insts- , new_fam_insts ++ fam_insts )- -- we don't shadow old family instances (#7102),- -- so don't need to remove them here- , ic_default = defaults- , ic_fix_env = fix_env -- See Note [Fixity declarations in GHCi]- }- where- new_ids = [id | AnId id <- new_tythings]- old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)-- -- Discard old instances that have been fully overridden- -- See Note [Override identical instances in GHCi]- (cls_insts, fam_insts) = ic_instances ictxt- old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts--extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext--- Just a specialised version-extendInteractiveContextWithIds ictxt new_ids- | null new_ids = ictxt- | otherwise = ictxt { ic_mod_index = ic_mod_index ictxt + 1- , ic_tythings = new_tythings ++ old_tythings- , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings }- where- new_tythings = map AnId new_ids- old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)--shadowed_by :: [Id] -> TyThing -> Bool-shadowed_by ids = shadowed- where- shadowed id = getOccName id `elemOccSet` new_occs- new_occs = mkOccSet (map getOccName ids)--setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext-setInteractivePrintName ic n = ic{ic_int_print = n}-- -- ToDo: should not add Ids to the gbl env here---- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing--- later ones, and shadowing existing entries in the GlobalRdrEnv.-icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv-icExtendGblRdrEnv env tythings- = foldr add env tythings -- Foldr makes things in the front of- -- the list shadow things at the back- where- -- One at a time, to ensure each shadows the previous ones- add thing env- | is_sub_bndr thing- = env- | otherwise- = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail)- where- env1 = shadowNames env (concatMap availNames avail)- avail = tyThingAvailInfo thing-- -- Ugh! The new_tythings may include record selectors, since they- -- are not implicit-ids, and must appear in the TypeEnv. But they- -- will also be brought into scope by the corresponding (ATyCon- -- tc). And we want the latter, because that has the correct- -- parent (#10520)- is_sub_bndr (AnId f) = case idDetails f of- RecSelId {} -> True- ClassOpId {} -> True- _ -> False- is_sub_bndr _ = False--substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext-substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst- | isEmptyTCvSubst subst = ictxt- | otherwise = ictxt { ic_tythings = map subst_ty tts }- where- subst_ty (AnId id)- = AnId $ updateIdTypeAndMult (substTyAddInScope subst) id- -- Variables in the interactive context *can* mention free type variables- -- because of the runtime debugger. Otherwise you'd expect all- -- variables bound in the interactive context to be closed.- subst_ty tt- = tt--instance Outputable InteractiveImport where- ppr (IIModule m) = char '*' <> ppr m- ppr (IIDecl d) = ppr d--{--************************************************************************-* *- Building a PrintUnqualified-* *-************************************************************************--Note [Printing original names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Deciding how to print names is pretty tricky. We are given a name-P:M.T, where P is the package name, M is the defining module, and T is-the occurrence name, and we have to decide in which form to display-the name given a GlobalRdrEnv describing the current scope.--Ideally we want to display the name in the form in which it is in-scope. However, the name might not be in scope at all, and that's-where it gets tricky. Here are the cases:-- 1. T uniquely maps to P:M.T ---> "T" NameUnqual- 2. There is an X for which X.T- uniquely maps to P:M.T ---> "X.T" NameQual X- 3. There is no binding for "M.T" ---> "M.T" NameNotInScope1- 4. Otherwise ---> "P:M.T" NameNotInScope2--(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at-all. In these cases we still want to refer to the name as "M.T", *but*-"M.T" might mean something else in the current scope (e.g. if there's-an "import X as M"), so to avoid confusion we avoid using "M.T" if-there's already a binding for it. Instead we write P:M.T.--There's one further subtlety: in case (3), what if there are two-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-the (ppr mod) of case (3), in Name.pprModulePrefix--Note [Printing unit ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the old days, original names were tied to PackageIds, which directly-corresponded to the entities that users wrote in Cabal files, and were perfectly-suitable for printing when we need to disambiguate packages. However, with-instantiated units, the situation can be different: if the key is instantiated-with some holes, we should try to give the user some more useful information.--}---- | Creates some functions that work out the best ways to format--- names for the user according to a set of heuristics.-mkPrintUnqualified :: UnitState -> HomeUnit -> GlobalRdrEnv -> PrintUnqualified-mkPrintUnqualified unit_state home_unit env- = QueryQualify qual_name- (mkQualModule unit_state home_unit)- (mkQualPackage unit_state)- where- qual_name mod occ- | [gre] <- unqual_gres- , right_name gre- = NameUnqual -- If there's a unique entity that's in scope- -- unqualified with 'occ' AND that entity is- -- the right one, then we can use the unqualified name-- | [] <- unqual_gres- , any is_name forceUnqualNames- , not (isDerivedOccName occ)- = NameUnqual -- Don't qualify names that come from modules- -- that come with GHC, often appear in error messages,- -- but aren't typically in scope. Doing this does not- -- cause ambiguity, and it reduces the amount of- -- qualification in error messages thus improving- -- readability.- --- -- A motivating example is 'Constraint'. It's often not- -- in scope, but printing GHC.Prim.Constraint seems- -- overkill.-- | [gre] <- qual_gres- = NameQual (greQualModName gre)-- | null qual_gres- = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env)- then NameNotInScope1- else NameNotInScope2-- | otherwise- = NameNotInScope1 -- Can happen if 'f' is bound twice in the module- -- Eg f = True; g = 0; f = False- where- is_name :: Name -> Bool- is_name name = ASSERT2( isExternalName name, ppr name )- nameModule name == mod && nameOccName name == occ-- forceUnqualNames :: [Name]- forceUnqualNames =- map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ]- ++ [ eqTyConName ]-- right_name gre = nameModule_maybe (gre_name gre) == Just mod-- unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env- qual_gres = filter right_name (lookupGlobalRdrEnv env occ)-- -- we can mention a module P:M without the P: qualifier iff- -- "import M" would resolve unambiguously to P:M. (if P is the- -- current package we can just assume it is unqualified).---- | Creates a function for formatting modules based on two heuristics:--- (1) if the module is the current module, don't qualify, and (2) if there--- is only one exposed package which exports this module, don't qualify.-mkQualModule :: UnitState -> HomeUnit -> QueryQualifyModule-mkQualModule unit_state home_unit mod- | isHomeModule home_unit mod = False-- | [(_, pkgconfig)] <- lookup,- mkUnit pkgconfig == moduleUnit mod- -- this says: we are given a module P:M, is there just one exposed package- -- that exposes a module M, and is it package P?- = False-- | otherwise = True- where lookup = lookupModuleInAllUnits unit_state (moduleName mod)---- | Creates a function for formatting packages based on two heuristics:--- (1) don't qualify if the package in question is "main", and (2) only qualify--- with a unit id if the package ID would be ambiguous.-mkQualPackage :: UnitState -> QueryQualifyPackage-mkQualPackage pkgs uid- | uid == mainUnit || uid == interactiveUnit- -- Skip the lookup if it's main, since it won't be in the package- -- database!- = False- | Just pkgid <- mb_pkgid- , searchPackageId pkgs pkgid `lengthIs` 1- -- this says: we are given a package pkg-0.1@MMM, are there only one- -- exposed packages whose package ID is pkg-0.1?- = False- | otherwise- = True- where mb_pkgid = fmap unitPackageId (lookupUnit pkgs uid)---- | A function which only qualifies package names if necessary; but--- qualifies all other identifiers.-pkgQual :: UnitState -> PrintUnqualified-pkgQual pkgs = alwaysQualify { queryQualifyPackage = mkQualPackage pkgs }--{--************************************************************************-* *- Implicit TyThings-* *-************************************************************************--Note [Implicit TyThings]-~~~~~~~~~~~~~~~~~~~~~~~~- DEFINITION: An "implicit" TyThing is one that does not have its own- IfaceDecl in an interface file. Instead, its binding in the type- environment is created as part of typechecking the IfaceDecl for- some other thing.--Examples:- * All DataCons are implicit, because they are generated from the- IfaceDecl for the data/newtype. Ditto class methods.-- * Record selectors are *not* implicit, because they get their own- free-standing IfaceDecl.-- * Associated data/type families are implicit because they are- included in the IfaceDecl of the parent class. (NB: the- IfaceClass decl happens to use IfaceDecl recursively for the- associated types, but that's irrelevant here.)-- * Dictionary function Ids are not implicit.-- * Axioms for newtypes are implicit (same as above), but axioms- for data/type family instances are *not* implicit (like DFunIds).--}---- | Determine the 'TyThing's brought into scope by another 'TyThing'--- /other/ than itself. For example, Id's don't have any implicit TyThings--- as they just bring themselves into scope, but classes bring their--- dictionary datatype, type constructor and some selector functions into--- scope, just for a start!---- N.B. the set of TyThings returned here *must* match the set of--- names returned by 'GHC.Iface.Load.ifaceDeclImplicitBndrs', in the sense that--- TyThing.getOccName should define a bijection between the two lists.--- This invariant is used in 'GHC.Iface.Load.loadDecl' (see note [Tricky iface loop])--- The order of the list does not matter.-implicitTyThings :: TyThing -> [TyThing]-implicitTyThings (AnId _) = []-implicitTyThings (ACoAxiom _cc) = []-implicitTyThings (ATyCon tc) = implicitTyConThings tc-implicitTyThings (AConLike cl) = implicitConLikeThings cl--implicitConLikeThings :: ConLike -> [TyThing]-implicitConLikeThings (RealDataCon dc)- = dataConImplicitTyThings dc--implicitConLikeThings (PatSynCon {})- = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher- -- are not "implicit"; they are simply new top-level bindings,- -- and they have their own declaration in an interface file- -- Unless a record pat syn when there are implicit selectors- -- They are still not included here as `implicitConLikeThings` is- -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked- -- by `tcTopValBinds`.--implicitClassThings :: Class -> [TyThing]-implicitClassThings cl- = -- Does not include default methods, because those Ids may have- -- their own pragmas, unfoldings etc, not derived from the Class object-- -- associated types- -- No recursive call for the classATs, because they- -- are only the family decls; they have no implicit things- map ATyCon (classATs cl) ++-- -- superclass and operation selectors- map AnId (classAllSelIds cl)--implicitTyConThings :: TyCon -> [TyThing]-implicitTyConThings tc- = class_stuff ++- -- fields (names of selectors)-- -- (possibly) implicit newtype axioms- -- or type family axioms- implicitCoTyCon tc ++-- -- for each data constructor in order,- -- the constructor, worker, and (possibly) wrapper- [ thing | dc <- tyConDataCons tc- , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ]- -- NB. record selectors are *not* implicit, they have fully-fledged- -- bindings that pass through the compilation pipeline as normal.- where- class_stuff = case tyConClass_maybe tc of- Nothing -> []- Just cl -> implicitClassThings cl---- For newtypes and closed type families (only) add the implicit coercion tycon-implicitCoTyCon :: TyCon -> [TyThing]-implicitCoTyCon tc- | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co]- | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc- = [ACoAxiom co]- | otherwise = []---- | Returns @True@ if there should be no interface-file declaration--- for this thing on its own: either it is built-in, or it is part--- of some other declaration, or it is generated implicitly by some--- other declaration.-isImplicitTyThing :: TyThing -> Bool-isImplicitTyThing (AConLike cl) = case cl of- RealDataCon {} -> True- PatSynCon {} -> False-isImplicitTyThing (AnId id) = isImplicitId id-isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc-isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax---- | tyThingParent_maybe x returns (Just p)--- when pprTyThingInContext should print a declaration for p--- (albeit with some "..." in it) when asked to show x--- It returns the *immediate* parent. So a datacon returns its tycon--- but the tycon could be the associated type of a class, so it in turn--- might have a parent.-tyThingParent_maybe :: TyThing -> Maybe TyThing-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 (AnId id) = case idDetails id of- RecSelId { sel_tycon = RecSelData tc } ->- Just (ATyCon tc)- ClassOpId cls ->- Just (ATyCon (classTyCon cls))- _other -> Nothing-tyThingParent_maybe _other = Nothing--tyThingsTyCoVars :: [TyThing] -> TyCoVarSet-tyThingsTyCoVars tts =- unionVarSets $ map ttToVarSet tts- where- ttToVarSet (AnId id) = tyCoVarsOfType $ idType id- ttToVarSet (AConLike cl) = case cl of- RealDataCon dc -> tyCoVarsOfType $ dataConRepType dc- PatSynCon{} -> emptyVarSet- ttToVarSet (ATyCon tc)- = case tyConClass_maybe tc of- Just cls -> (mkVarSet . fst . classTvsFds) cls- Nothing -> tyCoVarsOfType $ tyConKind tc- ttToVarSet (ACoAxiom _) = emptyVarSet---- | The Names that a TyThing should bring into scope. Used to build--- the GlobalRdrEnv for the InteractiveContext.-tyThingAvailInfo :: TyThing -> [AvailInfo]-tyThingAvailInfo (ATyCon t)- = case tyConClass_maybe t of- Just c -> [AvailTC n (n : map getName (classMethods c)- ++ map getName (classATs c))- [] ]- where n = getName c- Nothing -> [AvailTC n (n : map getName dcs) flds]- where n = getName t- dcs = tyConDataCons t- flds = tyConFieldLabels t-tyThingAvailInfo (AConLike (PatSynCon p))- = map avail ((getName p) : map flSelector (patSynFieldLabels p))-tyThingAvailInfo t- = [avail (getName t)]--{--************************************************************************-* *- TypeEnv-* *-************************************************************************--}---- | A map from 'Name's to 'TyThing's, constructed by typechecking--- local declarations or interface files-type TypeEnv = NameEnv TyThing--emptyTypeEnv :: TypeEnv-typeEnvElts :: TypeEnv -> [TyThing]-typeEnvTyCons :: TypeEnv -> [TyCon]-typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched]-typeEnvIds :: TypeEnv -> [Id]-typeEnvPatSyns :: TypeEnv -> [PatSyn]-typeEnvDataCons :: TypeEnv -> [DataCon]-typeEnvClasses :: TypeEnv -> [Class]-lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing--emptyTypeEnv = emptyNameEnv-typeEnvElts env = nameEnvElts env-typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env]-typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env]-typeEnvIds env = [id | AnId id <- typeEnvElts env]-typeEnvPatSyns env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env]-typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env]-typeEnvClasses env = [cl | tc <- typeEnvTyCons env,- Just cl <- [tyConClass_maybe tc]]--mkTypeEnv :: [TyThing] -> TypeEnv-mkTypeEnv things = extendTypeEnvList emptyTypeEnv things--mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv-mkTypeEnvWithImplicits things =- mkTypeEnv things- `plusNameEnv`- mkTypeEnv (concatMap implicitTyThings things)--typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv-typeEnvFromEntities ids tcs famInsts =- mkTypeEnv ( map AnId ids- ++ map ATyCon all_tcs- ++ concatMap implicitTyConThings all_tcs- ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts- )- where- all_tcs = tcs ++ famInstsRepTyCons famInsts--lookupTypeEnv = lookupNameEnv---- Extend the type environment-extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv-extendTypeEnv env thing = extendNameEnv env (getName thing) thing--extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv-extendTypeEnvList env things = foldl' extendTypeEnv env things--extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv-extendTypeEnvWithIds env ids- = extendNameEnvList env [(getName id, AnId id) | id <- ids]--plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv-plusTypeEnv env1 env2 = plusNameEnv env1 env2---- | Find the 'TyThing' for the given 'Name' by using all the resources--- at our disposal: the compiled modules in the 'HomePackageTable' and the--- compiled modules in other packages that live in 'PackageTypeEnv'. Note--- that this does NOT look up the 'TyThing' in the module being compiled: you--- have to do that yourself, if desired-lookupType :: DynFlags- -> HomePackageTable- -> PackageTypeEnv- -> Name- -> Maybe TyThing--lookupType dflags hpt pte name- | isOneShot (ghcMode dflags) -- in one-shot, we don't use the HPT- = lookupNameEnv pte name- | otherwise- = case lookupHptByModule hpt mod of- Just hm -> lookupNameEnv (md_types (hm_details hm)) name- Nothing -> lookupNameEnv pte name- where- mod = ASSERT2( isExternalName name, ppr name )- if isHoleName name- then mkHomeModule (mkHomeUnitFromFlags dflags) (moduleName (nameModule name))- else nameModule name---- | As 'lookupType', but with a marginally easier-to-use interface--- if you have a 'HscEnv'-lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing)-lookupTypeHscEnv hsc_env name = do- eps <- readIORef (hsc_EPS hsc_env)- return $! lookupType dflags hpt (eps_PTE eps) name- where- dflags = hsc_dflags hsc_env- hpt = hsc_HPT hsc_env---- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise-tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon-tyThingTyCon (ATyCon tc) = tc-tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other)---- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise-tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched-tyThingCoAxiom (ACoAxiom ax) = ax-tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (ppr other)---- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise-tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon-tyThingDataCon (AConLike (RealDataCon dc)) = dc-tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other)---- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing.--- Panics otherwise-tyThingConLike :: HasDebugCallStack => TyThing -> ConLike-tyThingConLike (AConLike dc) = dc-tyThingConLike other = pprPanic "tyThingConLike" (ppr other)---- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise-tyThingId :: HasDebugCallStack => TyThing -> Id-tyThingId (AnId id) = id-tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc-tyThingId other = pprPanic "tyThingId" (ppr other)--{--************************************************************************-* *-\subsection{MonadThings and friends}-* *-************************************************************************--}---- | Class that abstracts out the common ability of the monads in GHC--- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides--- a number of related convenience functions for accessing particular--- kinds of 'TyThing'-class Monad m => MonadThings m where- lookupThing :: Name -> m TyThing-- lookupId :: Name -> m Id- lookupId = liftM tyThingId . lookupThing-- lookupDataCon :: Name -> m DataCon- lookupDataCon = liftM tyThingDataCon . lookupThing-- lookupTyCon :: Name -> m TyCon- lookupTyCon = liftM tyThingTyCon . lookupThing---- Instance used in GHC.HsToCore.Quote-instance MonadThings m => MonadThings (ReaderT s m) where- lookupThing = lift . lookupThing--{--************************************************************************-* *-\subsection{Auxiliary types}-* *-************************************************************************--These types are defined here because they are mentioned in ModDetails,-but they are mostly elaborated elsewhere--}-------------------- Warnings ---------------------------- | Warning information for a module-data Warnings- = NoWarnings -- ^ Nothing deprecated- | WarnAll WarningTxt -- ^ Whole module deprecated- | WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated-- -- Only an OccName is needed because- -- (1) a deprecation always applies to a binding- -- defined in the module in which the deprecation appears.- -- (2) deprecations are only reported outside the defining module.- -- this is important because, otherwise, if we saw something like- --- -- {-# DEPRECATED f "" #-}- -- f = ...- -- h = f- -- g = let f = undefined in f- --- -- we'd need more information than an OccName to know to say something- -- about the use of f in h but not the use of the locally bound f in g- --- -- however, because we only report about deprecations from the outside,- -- and a module can only export one value called f,- -- an OccName suffices.- --- -- this is in contrast with fixity declarations, where we need to map- -- a Name to its fixity declaration.- deriving( Eq )--instance Binary Warnings where- put_ bh NoWarnings = putByte bh 0- put_ bh (WarnAll t) = do- putByte bh 1- put_ bh t- put_ bh (WarnSome ts) = do- putByte bh 2- put_ bh ts-- get bh = do- h <- getByte bh- case h of- 0 -> return NoWarnings- 1 -> do aa <- get bh- return (WarnAll aa)- _ -> do aa <- get bh- return (WarnSome aa)---- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'-mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt-mkIfaceWarnCache NoWarnings = \_ -> Nothing-mkIfaceWarnCache (WarnAll t) = \_ -> Just t-mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs)--emptyIfaceWarnCache :: OccName -> Maybe WarningTxt-emptyIfaceWarnCache _ = Nothing--plusWarns :: Warnings -> Warnings -> Warnings-plusWarns d NoWarnings = d-plusWarns NoWarnings d = d-plusWarns _ (WarnAll t) = WarnAll t-plusWarns (WarnAll t) _ = WarnAll t-plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2)---- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface'-mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity-mkIfaceFixCache pairs- = \n -> lookupOccEnv env n- where- env = mkOccEnv pairs--emptyIfaceFixCache :: OccName -> Maybe Fixity-emptyIfaceFixCache _ = Nothing---- | Fixity environment mapping names to their fixities-type FixityEnv = NameEnv FixItem---- | Fixity information for an 'Name'. We keep the OccName in the range--- so that we can generate an interface from it-data FixItem = FixItem OccName Fixity--instance Outputable FixItem where- ppr (FixItem occ fix) = ppr fix <+> ppr occ--emptyFixityEnv :: FixityEnv-emptyFixityEnv = emptyNameEnv--lookupFixity :: FixityEnv -> Name -> Fixity-lookupFixity env n = case lookupNameEnv env n of- Just (FixItem _ fix) -> fix- Nothing -> defaultFixity--{--************************************************************************-* *-\subsection{WhatsImported}-* *-************************************************************************--}---- | Records whether a module has orphans. An \"orphan\" is one of:------ * An instance declaration in a module other than the definition--- module for one of the type constructors or classes in the instance head------ * A rewrite rule in a module other than the one defining--- the function in the head of the rule----type WhetherHasOrphans = Bool---- | Does this module define family instances?-type WhetherHasFamInst = Bool---- | Dependency information about ALL modules and packages below this one--- in the import hierarchy.------ Invariant: the dependencies of a module @M@ never includes @M@.------ Invariant: none of the lists contain duplicates.-data Dependencies- = Deps { dep_mods :: [ModuleNameWithIsBoot]- -- ^ All home-package modules transitively below this one- -- I.e. modules that this one imports, or that are in the- -- dep_mods of those directly-imported modules-- , dep_pkgs :: [(UnitId, Bool)]- -- ^ All packages transitively below this module- -- I.e. packages to which this module's direct imports belong,- -- or that are in the dep_pkgs of those modules- -- The bool indicates if the package is required to be- -- trusted when the module is imported as a safe import- -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names-- , dep_orphs :: [Module]- -- ^ Transitive closure of orphan modules (whether- -- home or external pkg).- --- -- (Possible optimization: don't include family- -- instance orphans as they are anyway included in- -- 'dep_finsts'. But then be careful about code- -- which relies on dep_orphs having the complete list!)- -- This does NOT include us, unlike 'imp_orphs'.-- , dep_finsts :: [Module]- -- ^ Transitive closure of depended upon modules which- -- contain family instances (whether home or external).- -- This is used by 'checkFamInstConsistency'. This- -- does NOT include us, unlike 'imp_finsts'. See Note- -- [The type family instance consistency story].-- , dep_plgins :: [ModuleName]- -- ^ All the plugins used while compiling this module.- }- deriving( Eq )- -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints- -- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies.--instance Binary Dependencies where- put_ bh deps = do put_ bh (dep_mods deps)- put_ bh (dep_pkgs deps)- put_ bh (dep_orphs deps)- put_ bh (dep_finsts deps)- put_ bh (dep_plgins deps)-- get bh = do ms <- get bh- ps <- get bh- os <- get bh- fis <- get bh- pl <- get bh- return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,- dep_finsts = fis, dep_plgins = pl })--noDependencies :: Dependencies-noDependencies = Deps [] [] [] [] []---- | Records modules for which changes may force recompilation of this module--- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance------ This differs from Dependencies. A module X may be in the dep_mods of this--- module (via an import chain) but if we don't use anything from X it won't--- appear in our Usage-data Usage- -- | Module from another package- = UsagePackageModule {- usg_mod :: Module,- -- ^ External package module depended on- usg_mod_hash :: Fingerprint,- -- ^ Cached module fingerprint- usg_safe :: IsSafeImport- -- ^ Was this module imported as a safe import- }- -- | Module from the current package- | UsageHomeModule {- usg_mod_name :: ModuleName,- -- ^ Name of the module- usg_mod_hash :: Fingerprint,- -- ^ Cached module fingerprint- usg_entities :: [(OccName,Fingerprint)],- -- ^ Entities we depend on, sorted by occurrence name and fingerprinted.- -- NB: usages are for parent names only, e.g. type constructors- -- but not the associated data constructors.- usg_exports :: Maybe Fingerprint,- -- ^ Fingerprint for the export list of this module,- -- if we directly imported it (and hence we depend on its export list)- usg_safe :: IsSafeImport- -- ^ Was this module imported as a safe import- } -- ^ Module from the current package- -- | A file upon which the module depends, e.g. a CPP #include, or using TH's- -- 'addDependentFile'- | UsageFile {- usg_file_path :: FilePath,- -- ^ External file dependency. From a CPP #include or TH- -- addDependentFile. Should be absolute.- usg_file_hash :: Fingerprint- -- ^ 'Fingerprint' of the file contents.-- -- Note: We don't consider things like modification timestamps- -- here, because there's no reason to recompile if the actual- -- contents don't change. This previously lead to odd- -- recompilation behaviors; see #8114- }- -- | A requirement which was merged into this one.- | UsageMergedRequirement {- usg_mod :: Module,- usg_mod_hash :: Fingerprint- }- deriving( Eq )- -- The export list field is (Just v) if we depend on the export list:- -- i.e. we imported the module directly, whether or not we- -- enumerated the things we imported, or just imported- -- everything- -- We need to recompile if M's exports change, because- -- if the import was import M, we might now have a name clash- -- in the importing module.- -- if the import was import M(x) M might no longer export x- -- The only way we don't depend on the export list is if we have- -- import M()- -- And of course, for modules that aren't imported directly we don't- -- depend on their export lists--instance Binary Usage where- put_ bh usg@UsagePackageModule{} = do- putByte bh 0- put_ bh (usg_mod usg)- put_ bh (usg_mod_hash usg)- put_ bh (usg_safe usg)-- put_ bh usg@UsageHomeModule{} = do- putByte bh 1- put_ bh (usg_mod_name usg)- put_ bh (usg_mod_hash usg)- put_ bh (usg_exports usg)- put_ bh (usg_entities usg)- put_ bh (usg_safe usg)-- put_ bh usg@UsageFile{} = do- putByte bh 2- put_ bh (usg_file_path usg)- put_ bh (usg_file_hash usg)-- put_ bh usg@UsageMergedRequirement{} = do- putByte bh 3- put_ bh (usg_mod usg)- put_ bh (usg_mod_hash usg)-- get bh = do- h <- getByte bh- case h of- 0 -> do- nm <- get bh- mod <- get bh- safe <- get bh- return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }- 1 -> do- nm <- get bh- mod <- get bh- exps <- get bh- ents <- get bh- safe <- get bh- return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,- usg_exports = exps, usg_entities = ents, usg_safe = safe }- 2 -> do- fp <- get bh- hash <- get bh- return UsageFile { usg_file_path = fp, usg_file_hash = hash }- 3 -> do- mod <- get bh- hash <- get bh- return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash }- i -> error ("Binary.get(Usage): " ++ show i)--{--************************************************************************-* *- The External Package State-* *-************************************************************************--}--type PackageTypeEnv = TypeEnv-type PackageRuleBase = RuleBase-type PackageInstEnv = InstEnv-type PackageFamInstEnv = FamInstEnv-type PackageAnnEnv = AnnEnv-type PackageCompleteMatches = CompleteMatches---- | Information about other packages that we have slurped in by reading--- their interface files-data ExternalPackageState- = EPS {- eps_is_boot :: !(ModuleNameEnv ModuleNameWithIsBoot),- -- ^ In OneShot mode (only), home-package modules- -- accumulate in the external package state, and are- -- sucked in lazily. For these home-pkg modules- -- (only) we need to record which are boot modules.- -- We set this field after loading all the- -- explicitly-imported interfaces, but before doing- -- anything else- --- -- The 'ModuleName' part is not necessary, but it's useful for- -- debug prints, and it's convenient because this field comes- -- direct from 'GHC.Tc.Utils.imp_dep_mods'-- eps_PIT :: !PackageIfaceTable,- -- ^ The 'ModIface's for modules in external packages- -- whose interfaces we have opened.- -- The declarations in these interface files are held in the- -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules'- -- fields of this record, not in the 'mi_decls' fields of the- -- interface we have sucked in.- --- -- What /is/ in the PIT is:- --- -- * The Module- --- -- * Fingerprint info- --- -- * Its exports- --- -- * Fixities- --- -- * Deprecations and warnings-- eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName),- -- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on- -- the 'eps_PIT' for this information, EXCEPT that when- -- we do dependency analysis, we need to look at the- -- 'Dependencies' of our imports to determine what their- -- precise free holes are ('moduleFreeHolesPrecise'). We- -- don't want to repeatedly reread in the interface- -- for every import, so cache it here. When the PIT- -- gets filled in we can drop these entries.-- eps_PTE :: !PackageTypeEnv,- -- ^ Result of typechecking all the external package- -- interface files we have sucked in. The domain of- -- the mapping is external-package modules-- eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated- -- from all the external-package modules- eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated- -- from all the external-package modules- eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' accumulated- -- from all the external-package modules- eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated- -- from all the external-package modules- eps_complete_matches :: !PackageCompleteMatches,- -- ^ The total 'CompleteMatches' accumulated- -- from all the external-package modules-- 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- }---- | Accumulated statistics about what we are putting into the 'ExternalPackageState'.--- \"In\" means stuff that is just /read/ from interface files,--- \"Out\" means actually sucked in and type-checked-data EpsStats = EpsStats { n_ifaces_in- , n_decls_in, n_decls_out- , n_rules_in, n_rules_out- , n_insts_in, n_insts_out :: !Int }--addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats--- ^ Add stats for one newly-read interface-addEpsInStats stats n_decls n_insts n_rules- = stats { n_ifaces_in = n_ifaces_in stats + 1- , n_decls_in = n_decls_in stats + n_decls- , n_insts_in = n_insts_in stats + n_insts- , n_rules_in = n_rules_in stats + n_rules }--{--Names in a NameCache are always stored as a Global, and have the SrcLoc-of their binding locations.--Actually that's not quite right. When we first encounter the original-name, we might not be at its binding site (e.g. we are reading an-interface file); so we give it 'noSrcLoc' then. Later, when we find-its binding site, we fix it up.--}--updNameCache :: IORef NameCache- -> (NameCache -> (NameCache, c)) -- The updating function- -> IO c-updNameCache ncRef upd_fn- = atomicModifyIORef' ncRef upd_fn--mkSOName :: Platform -> FilePath -> FilePath-mkSOName platform root- = case platformOS platform of- OSMinGW32 -> root <.> soExt platform- _ -> ("lib" ++ root) <.> soExt platform--mkHsSOName :: Platform -> FilePath -> FilePath-mkHsSOName platform root = ("lib" ++ root) <.> soExt platform--soExt :: Platform -> FilePath-soExt platform- = case platformOS platform of- OSDarwin -> "dylib"- OSMinGW32 -> "dll"- _ -> "so"--{--************************************************************************-* *- The module graph and ModSummary type- A ModSummary is a node in the compilation manager's- dependency graph, and it's also passed to hscMain-* *-************************************************************************--}---- | A ModuleGraph contains all the nodes from the home package (only).--- There will be a node for each source module, plus a node for each hi-boot--- module.------ The graph is not necessarily stored in topologically-sorted order. Use--- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.-data ModuleGraph = ModuleGraph- { mg_mss :: [ModSummary]- , mg_non_boot :: ModuleEnv ModSummary- -- a map of all non-boot ModSummaries keyed by Modules- , mg_boot :: ModuleSet- -- a set of boot Modules- , mg_needs_th_or_qq :: !Bool- -- does any of the modules in mg_mss require TemplateHaskell or- -- QuasiQuotes?- }---- | Determines whether a set of modules requires Template Haskell or--- Quasi Quotes------ Note that if the session's 'DynFlags' enabled Template Haskell when--- 'depanal' was called, then each module in the returned module graph will--- have Template Haskell enabled whether it is actually needed or not.-needsTemplateHaskellOrQQ :: ModuleGraph -> Bool-needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg---- | Map a function 'f' over all the 'ModSummaries'.--- To preserve invariants 'f' can't change the isBoot status.-mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph-mapMG f mg@ModuleGraph{..} = mg- { mg_mss = map f mg_mss- , mg_non_boot = mapModuleEnv f mg_non_boot- }--mgBootModules :: ModuleGraph -> ModuleSet-mgBootModules ModuleGraph{..} = mg_boot--mgModSummaries :: ModuleGraph -> [ModSummary]-mgModSummaries = mg_mss--mgElemModule :: ModuleGraph -> Module -> Bool-mgElemModule ModuleGraph{..} m = elemModuleEnv m mg_non_boot---- | Look up a ModSummary in the ModuleGraph-mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary-mgLookupModule ModuleGraph{..} m = lookupModuleEnv mg_non_boot m--emptyMG :: ModuleGraph-emptyMG = ModuleGraph [] emptyModuleEnv emptyModuleSet False--isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool-isTemplateHaskellOrQQNonBoot ms =- (xopt LangExt.TemplateHaskell (ms_hspp_opts ms)- || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) &&- (isBootSummary ms == NotBoot)---- | Add a ModSummary to ModuleGraph. Assumes that the new ModSummary is--- not an element of the ModuleGraph.-extendMG :: ModuleGraph -> ModSummary -> ModuleGraph-extendMG ModuleGraph{..} ms = ModuleGraph- { mg_mss = ms:mg_mss- , mg_non_boot = case isBootSummary ms of- IsBoot -> mg_non_boot- NotBoot -> extendModuleEnv mg_non_boot (ms_mod ms) ms- , mg_boot = case isBootSummary ms of- NotBoot -> mg_boot- IsBoot -> extendModuleSet mg_boot (ms_mod ms)- , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms- }--mkModuleGraph :: [ModSummary] -> ModuleGraph-mkModuleGraph = foldr (flip extendMG) emptyMG---- | A single node in a 'ModuleGraph'. The nodes of the module graph--- are one of:------ * A regular Haskell source module--- * A hi-boot source module----data ModSummary- = ModSummary {- ms_mod :: Module,- -- ^ Identity of the module- ms_hsc_src :: HscSource,- -- ^ The module source either plain Haskell or hs-boot- ms_location :: ModLocation,- -- ^ Location of the various files belonging to the module- ms_hs_date :: UTCTime,- -- ^ Timestamp of source file- ms_obj_date :: Maybe UTCTime,- -- ^ Timestamp of object, if we have one- ms_iface_date :: Maybe UTCTime,- -- ^ Timestamp of hi file, if we *only* are typechecking (it is- -- 'Nothing' otherwise.- -- See Note [Recompilation checking in -fno-code mode] and #9243- ms_hie_date :: Maybe UTCTime,- -- ^ Timestamp of hie file, if we have one- ms_srcimps :: [(Maybe FastString, Located ModuleName)],- -- ^ Source imports of the module- ms_textual_imps :: [(Maybe FastString, Located ModuleName)],- -- ^ Non-source imports of the module from the module *text*- 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.- ms_hspp_file :: FilePath,- -- ^ Filename of preprocessed source file- ms_hspp_opts :: DynFlags,- -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@- -- pragmas in the modules source code- ms_hspp_buf :: Maybe StringBuffer- -- ^ The actual preprocessed source, if we have it- }--ms_installed_mod :: ModSummary -> InstalledModule-ms_installed_mod = fst . getModuleInstantiation . ms_mod--ms_mod_name :: ModSummary -> ModuleName-ms_mod_name = moduleName . ms_mod--ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]-ms_imps ms =- ms_textual_imps ms ++- map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms))- where- mk_additional_import mod_nm = (Nothing, noLoc mod_nm)--home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]-home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps,- isLocal mb_pkg ]- where isLocal Nothing = True- isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special- isLocal _ = False--ms_home_allimps :: ModSummary -> [ModuleName]-ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)---- | Like 'ms_home_imps', but for SOURCE imports.-ms_home_srcimps :: ModSummary -> [Located ModuleName]-ms_home_srcimps = home_imps . ms_srcimps---- | All of the (possibly) home module imports from a--- 'ModSummary'; that is to say, each of these module names--- could be a home import if an appropriately named file--- existed. (This is in contrast to package qualified--- imports, which are guaranteed not to be home imports.)-ms_home_imps :: ModSummary -> [Located ModuleName]-ms_home_imps = home_imps . ms_imps---- The ModLocation contains both the original source filename and the--- filename of the cleaned-up source file after all preprocessing has been--- done. The point is that the summariser will have to cpp/unlit/whatever--- all files anyway, and there's no point in doing this twice -- just--- park the result in a temp file, put the name of it in the location,--- and let @compile@ read from that file on the way back up.---- The ModLocation is stable over successive up-sweeps in GHCi, wheres--- the ms_hs_date and imports can, of course, change--msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath-msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms))-msHiFilePath ms = ml_hi_file (ms_location ms)-msObjFilePath ms = ml_obj_file (ms_location ms)--msDynObjFilePath :: ModSummary -> DynFlags -> FilePath-msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms)---- | Did this 'ModSummary' originate from a hs-boot file?-isBootSummary :: ModSummary -> IsBootInterface-isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot--instance Outputable ModSummary where- ppr ms- = sep [text "ModSummary {",- nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),- text "ms_mod =" <+> ppr (ms_mod ms)- <> text (hscSourceString (ms_hsc_src ms)) <> comma,- text "ms_textual_imps =" <+> ppr (ms_textual_imps ms),- text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),- char '}'- ]--showModMsg :: DynFlags -> Bool -> ModSummary -> SDoc-showModMsg dflags recomp mod_summary =- if gopt Opt_HideSourcePaths dflags- then text mod_str- else hsep $- [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')- , char '('- , text (op $ msHsFilePath mod_summary) <> char ','- ] ++- if gopt Opt_BuildDynamicToo dflags- then [ text obj_file <> char ','- , text dyn_file- , char ')'- ]- else [ text obj_file, char ')' ]- where- op = normalise- mod = moduleName (ms_mod mod_summary)- mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)- dyn_file = op $ msDynObjFilePath mod_summary dflags- obj_file = case backend dflags of- Interpreter | recomp -> "interpreted"- NoBackend -> "nothing"- _ -> (op $ msObjFilePath mod_summary)--{--************************************************************************-* *-\subsection{Recompilation}-* *-************************************************************************--}---- | Indicates whether a given module's source has been modified since it--- was last compiled.-data SourceModified- = SourceModified- -- ^ the source has been modified- | SourceUnmodified- -- ^ the source has not been modified. Compilation may or may- -- not be necessary, depending on whether any dependencies have- -- changed since we last compiled.- | SourceUnmodifiedAndStable- -- ^ the source has not been modified, and furthermore all of- -- its (transitive) dependencies are up to date; it definitely- -- does not need to be recompiled. This is important for two- -- reasons: (a) we can omit the version check in checkOldIface,- -- and (b) if the module used TH splices we don't need to force- -- recompilation.--{--************************************************************************-* *-\subsection{Hpc Support}-* *-************************************************************************--}---- | Information about a modules use of Haskell Program Coverage-data HpcInfo- = HpcInfo- { hpcInfoTickCount :: Int- , hpcInfoHash :: Int- }- | NoHpcInfo- { hpcUsed :: AnyHpcUsage -- ^ Is hpc used anywhere on the module \*tree\*?- }---- | This is used to signal if one of my imports used HPC instrumentation--- even if there is no module-local HPC usage-type AnyHpcUsage = Bool--emptyHpcInfo :: AnyHpcUsage -> HpcInfo-emptyHpcInfo = NoHpcInfo---- | Find out if HPC is used by this module or any of the modules--- it depends upon-isHpcUsed :: HpcInfo -> AnyHpcUsage-isHpcUsed (HpcInfo {}) = True-isHpcUsed (NoHpcInfo { hpcUsed = used }) = used--{--************************************************************************-* *-\subsection{Safe Haskell Support}-* *-************************************************************************--This stuff here is related to supporting the Safe Haskell extension,-primarily about storing under what trust type a module has been compiled.--}---- | Is an import a safe import?-type IsSafeImport = Bool---- | Safe Haskell information for 'ModIface'--- Simply a wrapper around SafeHaskellMode to sepperate iface and flags-newtype IfaceTrustInfo = TrustInfo SafeHaskellMode--getSafeMode :: IfaceTrustInfo -> SafeHaskellMode-getSafeMode (TrustInfo x) = x--setSafeMode :: SafeHaskellMode -> IfaceTrustInfo-setSafeMode = TrustInfo--noIfaceTrustInfo :: IfaceTrustInfo-noIfaceTrustInfo = setSafeMode Sf_None--trustInfoToNum :: IfaceTrustInfo -> Word8-trustInfoToNum it- = case getSafeMode it of- Sf_None -> 0- Sf_Unsafe -> 1- Sf_Trustworthy -> 2- Sf_Safe -> 3- Sf_SafeInferred -> 4- Sf_Ignore -> 0--numToTrustInfo :: Word8 -> IfaceTrustInfo-numToTrustInfo 0 = setSafeMode Sf_None-numToTrustInfo 1 = setSafeMode Sf_Unsafe-numToTrustInfo 2 = setSafeMode Sf_Trustworthy-numToTrustInfo 3 = setSafeMode Sf_Safe-numToTrustInfo 4 = setSafeMode Sf_SafeInferred-numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")"--instance Outputable IfaceTrustInfo where- ppr (TrustInfo Sf_None) = text "none"- ppr (TrustInfo Sf_Ignore) = text "none"- ppr (TrustInfo Sf_Unsafe) = text "unsafe"- ppr (TrustInfo Sf_Trustworthy) = text "trustworthy"- ppr (TrustInfo Sf_Safe) = text "safe"- ppr (TrustInfo Sf_SafeInferred) = text "safe-inferred"--instance Binary IfaceTrustInfo where- put_ bh iftrust = putByte bh $ trustInfoToNum iftrust- get bh = getByte bh >>= (return . numToTrustInfo)--{--************************************************************************-* *-\subsection{Parser result}-* *-************************************************************************--}--data HsParsedModule = HsParsedModule {- hpm_module :: Located HsModule,- hpm_src_files :: [FilePath],- -- ^ extra source files (e.g. from #includes). The lexer collects- -- these from '# <file> <line>' pragmas, which the C preprocessor- -- leaves behind. These files and their timestamps are stored in- -- the .hi file, so that we can force recompilation if any of- -- them change (#3589)- hpm_annotations :: ApiAnns- -- See note [Api annotations] in GHC.Parser.Annotation- }--{--************************************************************************-* *-\subsection{Linkable stuff}-* *-************************************************************************--This stuff is in here, rather than (say) in "GHC.Runtime.Linker", because the "GHC.Runtime.Linker"-stuff is the *dynamic* linker, and isn't present in a stage-1 compiler--}--isObjectLinkable :: Linkable -> Bool-isObjectLinkable l = not (null unlinked) && all isObject unlinked- where unlinked = linkableUnlinked l- -- A linkable with no Unlinked's is treated as a BCO. We can- -- generate a linkable with no Unlinked's as a result of- -- compiling a module in NoBackend mode, and this choice- -- happens to work well with checkStability in module GHC.--linkableObjs :: Linkable -> [FilePath]-linkableObjs l = [ f | DotO f <- linkableUnlinked l ]------------------------------------------------- | Is this an actual file on disk we can link in somehow?-isObject :: Unlinked -> Bool-isObject (DotO _) = True-isObject (DotA _) = True-isObject (DotDLL _) = True-isObject _ = False---- | Is this a bytecode linkable with no file on disk?-isInterpretable :: Unlinked -> Bool-isInterpretable = not . isObject---- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object-nameOfObject :: Unlinked -> FilePath-nameOfObject (DotO fn) = fn-nameOfObject (DotA fn) = fn-nameOfObject (DotDLL fn) = fn-nameOfObject other = pprPanic "nameOfObject" (ppr other)---- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable-byteCodeOfObject :: Unlinked -> CompiledByteCode-byteCodeOfObject (BCOs bc _) = bc-byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other)------------------------------------------------type ConLikeSet = UniqDSet ConLike---- | A list of conlikes which represents a complete pattern match.--- These arise from @COMPLETE@ signatures.--- See also Note [Implementation of COMPLETE pragmas].-type CompleteMatch = ConLikeSet--type CompleteMatches = [CompleteMatch]---- | Foreign language of the phase if the phase deals with a foreign code-phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang-phaseForeignLanguage phase = case phase of- Phase.Cc -> Just LangC- Phase.Ccxx -> Just LangCxx- Phase.Cobjc -> Just LangObjc- Phase.Cobjcxx -> Just LangObjcxx- Phase.HCc -> Just LangC- Phase.As _ -> Just LangAsm- Phase.MergeForeign -> Just RawObject- _ -> Nothing------------------------------------------------- Take care, this instance only forces to the degree necessary to--- avoid major space leaks.-instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where- rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12- f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) =- rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq`- f9 `seq` rnf f10 `seq` rnf f11 `seq` 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- `seq` rnf f24--{--************************************************************************-* *-\subsection{Extensible Iface Fields}-* *-************************************************************************--}--type FieldName = String--newtype ExtensibleFields = ExtensibleFields { getExtensibleFields :: (Map FieldName BinData) }--instance Binary ExtensibleFields where- put_ bh (ExtensibleFields fs) = do- put_ bh (Map.size fs :: Int)-- -- Put the names of each field, and reserve a space- -- for a payload pointer after each name:- header_entries <- forM (Map.toList fs) $ \(name, dat) -> do- put_ bh name- field_p_p <- tellBin bh- put_ bh field_p_p- return (field_p_p, dat)-- -- Now put the payloads and use the reserved space- -- to point to the start of each payload:- forM_ header_entries $ \(field_p_p, dat) -> do- field_p <- tellBin bh- putAt bh field_p_p field_p- seekBin bh field_p- put_ bh dat-- get bh = do- n <- get bh :: IO Int-- -- Get the names and field pointers:- header_entries <- replicateM n $ do- (,) <$> get bh <*> get bh-- -- Seek to and get each field's payload:- fields <- forM header_entries $ \(name, field_p) -> do- seekBin bh field_p- dat <- get bh- return (name, dat)-- return . ExtensibleFields . Map.fromList $ fields--instance NFData ExtensibleFields where- rnf (ExtensibleFields fs) = rnf fs--emptyExtensibleFields :: ExtensibleFields-emptyExtensibleFields = ExtensibleFields Map.empty------------------------------------------------------------------------------------- | Reading--readIfaceField :: Binary a => FieldName -> ModIface -> IO (Maybe a)-readIfaceField name = readIfaceFieldWith name get--readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)-readField name = readFieldWith name get--readIfaceFieldWith :: FieldName -> (BinHandle -> IO a) -> ModIface -> IO (Maybe a)-readIfaceFieldWith name read iface = readFieldWith name read (mi_ext_fields iface)--readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)-readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>- Map.lookup name (getExtensibleFields fields)------------------------------------------------------------------------------------- | Writing--writeIfaceField :: Binary a => FieldName -> a -> ModIface -> IO ModIface-writeIfaceField name x = writeIfaceFieldWith name (`put_` x)--writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields-writeField name x = writeFieldWith name (`put_` x)--writeIfaceFieldWith :: FieldName -> (BinHandle -> IO ()) -> ModIface -> IO ModIface-writeIfaceFieldWith name write iface = do- fields <- writeFieldWith name write (mi_ext_fields iface)- return iface{ mi_ext_fields = fields }--writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields-writeFieldWith name write fields = do- bh <- openBinMem (1024 * 1024)- write bh- --- bd <- handleData bh- return $ ExtensibleFields (Map.insert name bd $ getExtensibleFields fields)--deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields-deleteField name (ExtensibleFields fs) = ExtensibleFields $ Map.delete name fs--deleteIfaceField :: FieldName -> ModIface -> ModIface-deleteIfaceField name iface = iface { mi_ext_fields = deleteField name (mi_ext_fields iface) }
compiler/GHC/Hs.hs view
@@ -33,6 +33,7 @@ Fixity, HsModule(..),+ HsParsedModule(..) ) where -- friends:@@ -46,15 +47,17 @@ import GHC.Hs.Extension import GHC.Hs.Pat import GHC.Hs.Type-import GHC.Types.Basic ( Fixity, WarningTxt ) import GHC.Hs.Utils import GHC.Hs.Doc import GHC.Hs.Instances () -- For Data instances -- others:+import GHC.Parser.Annotation ( ApiAnns ) import GHC.Utils.Outputable+import GHC.Types.Fixity ( Fixity ) import GHC.Types.SrcLoc-import GHC.Unit.Module ( ModuleName )+import GHC.Unit.Module ( ModuleName )+import GHC.Unit.Module.Warnings ( WarningTxt ) -- libraries: import Data.Data hiding ( Fixity )@@ -151,3 +154,16 @@ pp_nonnull :: Outputable t => [t] -> SDoc pp_nonnull [] = empty pp_nonnull xs = vcat (map ppr xs)++data HsParsedModule = HsParsedModule {+ hpm_module :: Located HsModule,+ hpm_src_files :: [FilePath],+ -- ^ extra source files (e.g. from #includes). The lexer collects+ -- these from '# <file> <line>' pragmas, which the C preprocessor+ -- leaves behind. These files and their timestamps are stored in+ -- the .hi file, so that we can force recompilation if any of+ -- them change (#3589)+ hpm_annotations :: ApiAnns+ -- See note [Api annotations] in GHC.Parser.Annotation+ }+
compiler/GHC/Hs/Binds.hs view
@@ -1,3 +1,17 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+ -- in module GHC.Hs.Extension+{-# LANGUAGE ViewPatterns #-}++ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -7,21 +21,6 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]- -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ViewPatterns #-}- module GHC.Hs.Binds where import GHC.Prelude@@ -38,8 +37,10 @@ import GHC.Core.Type import GHC.Types.Name.Set import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var+import GHC.Types.Fixity import GHC.Data.Bag import GHC.Data.FastString import GHC.Data.BooleanFormula (LBooleanFormula)@@ -983,7 +984,7 @@ -- For details on above see note [Api annotations] in GHC.Parser.Annotation | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass)- -- Note [Pragma source text] in GHC.Types.Basic+ -- Note [Pragma source text] in GHC.Types.SourceText -- | A minimal complete definition pragma --@@ -996,7 +997,7 @@ -- For details on above see note [Api annotations] in GHC.Parser.Annotation | MinimalSig (XMinimalSig pass) SourceText (LBooleanFormula (LIdP pass))- -- Note [Pragma source text] in GHC.Types.Basic+ -- Note [Pragma source text] in GHC.Types.SourceText -- | A "set cost centre" pragma for declarations --@@ -1007,7 +1008,7 @@ -- > {-# SCC funName "cost_centre_name" #-} | SCCFunSig (XSCCFunSig pass)- SourceText -- Note [Pragma source text] in GHC.Types.Basic+ SourceText -- Note [Pragma source text] in GHC.Types.SourceText (LIdP pass) -- Function name (Maybe (XRec pass StringLiteral)) -- | A complete match pragma@@ -1161,8 +1162,8 @@ (interpp'SP ty) inl) where pragmaSrc = case spec of- NoUserInline -> "{-# SPECIALISE"- _ -> "{-# SPECIALISE_INLINE"+ NoUserInlinePrag -> "{-# SPECIALISE"+ _ -> "{-# SPECIALISE_INLINE" ppr_sig (InlineSig _ var inl) = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl <+> pprPrefixOcc (unLoc var))
compiler/GHC/Hs/Decls.hs view
@@ -1,20 +1,21 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+ -- in module GHC.Hs.Extension+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,- DeriveTraversable #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]- -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -73,8 +74,8 @@ CImportSpec(..), -- ** Data-constructor declarations ConDecl(..), LConDecl,- HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta,- getConNames, getConArgs,+ HsConDeclH98Details, HsConDeclGADTDetails(..), hsConDeclTheta,+ getConNames, getRecConArgs_maybe, -- ** Document comments DocDecl(..), LDocDecl, docDeclDoc, -- ** Deprecations@@ -113,6 +114,7 @@ import GHC.Hs.Extension import GHC.Types.Name import GHC.Types.Name.Set+import GHC.Types.Fixity -- others: import GHC.Core.Class@@ -120,7 +122,9 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Types.SrcLoc+import GHC.Types.SourceText import GHC.Core.Type+import GHC.Unit.Module.Warnings import GHC.Data.Bag import GHC.Data.Maybe@@ -1472,9 +1476,9 @@ -- Whether or not there is an /explicit/ forall, we still -- need to capture the implicitly-bound type/kind variables - , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)- , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon- , con_res_ty :: LHsType pass -- ^ Result type+ , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)+ , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix+ , con_res_ty :: LHsType pass -- ^ Result type , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment.@@ -1491,7 +1495,7 @@ -- False => con_ex_tvs is empty , con_ex_tvs :: [LHsTyVarBndr Specificity pass] -- ^ Existentials only , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any)- , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon+ , con_args :: HsConDeclH98Details pass -- ^ Arguments; can be infix , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment.@@ -1622,27 +1626,35 @@ quantification occurs after a visible argument type. -} --- | Haskell data Constructor Declaration Details-type HsConDeclDetails pass+-- | The arguments in a Haskell98-style data constructor.+type HsConDeclH98Details pass = HsConDetails (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass]) +-- | The arguments in a GADT constructor. Unlike Haskell98-style constructors,+-- GADT constructors cannot be declared with infix syntax. As a result, we do+-- not use 'HsConDetails' here, as 'InfixCon' would be an unrepresentable+-- state. (There is a notion of infix GADT constructors for the purposes of+-- derived Show instances—see Note [Infix GADT constructors] in+-- GHC.Tc.TyCl—but that is an orthogonal concern.)+data HsConDeclGADTDetails pass+ = PrefixConGADT [HsScaled pass (LBangType pass)]+ | RecConGADT (XRec pass [LConDeclField pass])+ getConNames :: ConDecl GhcRn -> [Located Name] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names -getConArgs :: ConDecl GhcRn -> HsConDeclDetails GhcRn-getConArgs d = con_args d--hsConDeclArgTys :: HsConDeclDetails (GhcPass p) -> [HsScaled (GhcPass p) (LBangType (GhcPass p))]-hsConDeclArgTys (PrefixCon tys) = tys-hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]-hsConDeclArgTys (RecCon flds) = map (hsLinear . cd_fld_type . unLoc) (unLoc flds)- -- Remark: with the record syntax, constructors have all their argument- -- linear, despite the fact that projections do not make sense on linear- -- constructors. The design here is that the record projection themselves are- -- typed to take an unrestricted argument (that is the record itself is- -- unrestricted). By the transfer property, projections are then correct in- -- that all the non-projected fields have multiplicity Many, and can be dropped.+-- | Return @'Just' fields@ if a data constructor declaration uses record+-- syntax (i.e., 'RecCon'), where @fields@ are the field selectors.+-- Otherwise, return 'Nothing'.+getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (Located [LConDeclField GhcRn])+getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of+ PrefixCon{} -> Nothing+ RecCon flds -> Just flds+ InfixCon{} -> Nothing+getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of+ PrefixConGADT{} -> Nothing+ RecConGADT flds -> Just flds hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)] hsConDeclTheta Nothing = []@@ -1722,15 +1734,14 @@ cxt = fromMaybe noLHsContext mcxt pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars- , con_mb_cxt = mcxt, con_args = args+ , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_doc = doc }) = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon <+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) cxt, ppr_arrow_chain (get_args args ++ [ppr res_ty]) ]) where- get_args (PrefixCon args) = map ppr args- get_args (RecCon fields) = [pprConDeclFields (unLoc fields)]- get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons)+ get_args (PrefixConGADT args) = map ppr args+ get_args (RecConGADT fields) = [pprConDeclFields (unLoc fields)] cxt = fromMaybe noLHsContext mcxt @@ -2371,7 +2382,7 @@ -- | Located Rule Declarations type LRuleDecls pass = XRec pass (RuleDecls pass) - -- Note [Pragma source text] in GHC.Types.Basic+ -- Note [Pragma source text] in GHC.Types.SourceText -- | Rule Declarations data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass , rds_src :: SourceText@@ -2514,7 +2525,7 @@ -- | Located Warning Declarations type LWarnDecls pass = XRec pass (WarnDecls pass) - -- Note [Pragma source text] in GHC.Types.Basic+ -- Note [Pragma source text] in GHC.Types.SourceText -- | Warning pragma Declarations data WarnDecls pass = Warnings { wd_ext :: XWarnings pass , wd_src :: SourceText@@ -2562,7 +2573,7 @@ -- | Annotation Declaration data AnnDecl pass = HsAnnotation (XHsAnnotation pass)- SourceText -- Note [Pragma source text] in GHC.Types.Basic+ SourceText -- Note [Pragma source text] in GHC.Types.SourceText (AnnProvenance (IdP pass)) (XRec pass (HsExpr pass)) -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', -- 'GHC.Parser.Annotation.AnnType'
compiler/GHC/Hs/Doc.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} module GHC.Hs.Doc ( HsDocString
compiler/GHC/Hs/Dump.hs view
@@ -17,19 +17,21 @@ import GHC.Prelude -import Data.Data hiding (Fixity)+import GHC.Hs++import GHC.Core.DataCon+ import GHC.Data.Bag-import GHC.Types.Basic import GHC.Data.FastString import GHC.Types.Name.Set import GHC.Types.Name-import GHC.Core.DataCon import GHC.Types.SrcLoc-import GHC.Hs import GHC.Types.Var+import GHC.Types.SourceText import GHC.Unit.Module import GHC.Utils.Outputable +import Data.Data hiding (Fixity) import qualified Data.ByteString as B data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan
compiler/GHC/Hs/Expr.hs view
@@ -1,27 +1,25 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}--{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}+ -- | Abstract Haskell syntax for expressions. module GHC.Hs.Expr where @@ -44,8 +42,10 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Basic-import GHC.Core.ConLike+import GHC.Types.Fixity+import GHC.Types.SourceText import GHC.Types.SrcLoc+import GHC.Core.ConLike import GHC.Unit.Module (ModuleName) import GHC.Utils.Misc import GHC.Utils.Outputable@@ -577,8 +577,9 @@ , rupd_in_tys :: [Type] -- Argument types of *input* record type , rupd_out_tys :: [Type] -- and *output* record type- -- The original type can be reconstructed- -- with conLikeResTy+ -- For a data family, these are the type args of the+ -- /representation/ type constructor+ , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] } @@ -832,7 +833,7 @@ -- | A pragma, written as {-# ... #-}, that may appear within an expression. data HsPragE p = HsPragSCC (XSCC p)- SourceText -- Note [Pragma source text] in GHC.Types.Basic+ SourceText -- Note [Pragma source text] in GHC.Types.SourceText StringLiteral -- "set cost centre" SCC pragma -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',@@ -847,7 +848,6 @@ | XHsPragE !(XXPragE p) type instance XSCC (GhcPass _) = NoExtField-type instance XCoreAnn (GhcPass _) = NoExtField type instance XXPragE (GhcPass _) = NoExtCon -- | Located Haskell Tuple Argument@@ -2403,7 +2403,7 @@ Just False -> text "return" Nothing -> empty) <+> ppr expr-pprStmt (BindStmt _ pat expr) = hsep [ppr pat, larrow, ppr expr]+pprStmt (BindStmt _ pat expr) = pprBindStmt pat expr pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds] pprStmt (BodyStmt _ expr _ _) = ppr expr pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss))@@ -2439,11 +2439,8 @@ flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] flattenArg (_, ApplicativeArgOne _ pat expr isBody)- | isBody = -- See Note [Applicative BodyStmt]- [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr- :: ExprStmt (GhcPass idL))]- | otherwise =- [ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))]+ | isBody = [ppr expr] -- See Note [Applicative BodyStmt]+ | otherwise = [pprBindStmt pat expr] flattenArg (_, ApplicativeArgMany _ stmts _ _ _) = concatMap flattenStmt stmts @@ -2457,6 +2454,8 @@ pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc pp_arg (_, applicativeArg) = ppr applicativeArg +pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc+pprBindStmt pat expr = hsep [ppr pat, larrow, ppr expr] instance (OutputableBndrId idL) => Outputable (ApplicativeArg (GhcPass idL)) where@@ -2464,18 +2463,13 @@ pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc pprArg (ApplicativeArgOne _ pat expr isBody)- | isBody = -- See Note [Applicative BodyStmt]- ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr- :: ExprStmt (GhcPass idL))- | otherwise =- ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))+ | isBody = ppr expr -- See Note [Applicative BodyStmt]+ | otherwise = pprBindStmt pat expr pprArg (ApplicativeArgMany _ stmts return pat ctxt) = ppr pat <+> text "<-" <+>- ppr (HsDo (panic "pprStmt") ctxt (noLoc- (stmts ++- [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)]))- :: HsExpr (GhcPass idL))+ pprDo ctxt (stmts +++ [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)]) pprTransformStmt :: (OutputableBndrId p) => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
compiler/GHC/Hs/Extension.hs view
@@ -1,24 +1,20 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE EmptyDataDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]- -- in module GHC.Hs.Extension-{-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc]-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE AllowAmbiguousTypes #-} -- for pprIfTc, etc.+{-# LANGUAGE AllowAmbiguousTypes #-} -- for pprIfTc, etc.+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE EmptyDataDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc]+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+ -- in module GHC.Hs.Extension module GHC.Hs.Extension where @@ -331,11 +327,11 @@ type family XEmptyLocalBinds x x' type family XXHsLocalBindsLR x x' --- ValBindsLR type families+-- HsValBindsLR type families type family XValBinds x x' type family XXValBindsLR x x' --- HsBindsLR type families+-- HsBindLR type families type family XFunBind x x' type family XPatBind x x' type family XVarBind x x'@@ -469,7 +465,7 @@ type family XXClsInstDecl x -- ---------------------------------------- ClsInstDecl type families+-- InstDecl type families type family XClsInstD x type family XDataFamInstD x type family XTyFamInstD x@@ -490,7 +486,7 @@ type family XXDefaultDecl x -- ---------------------------------------- DefaultDecl type families+-- ForeignDecl type families type family XForeignImport x type family XForeignExport x type family XXForeignDecl x@@ -517,7 +513,7 @@ type family XXWarnDecls x -- ---------------------------------------- AnnDecl type families+-- WarnDecl type families type family XWarning x type family XXWarnDecl x @@ -574,32 +570,34 @@ type family XPragE x type family XXExpr x +-- -------------------------------------+-- HsPragE type families type family XSCC x-type family XCoreAnn x-type family XTickPragma x type family XXPragE x--- --------------------------------------------------------------------- ++-- -------------------------------------+-- AmbiguousFieldOcc type families type family XUnambiguous x type family XAmbiguous x type family XXAmbiguousFieldOcc x --- -----------------------------------------------------------------------+-- -------------------------------------+-- HsTupArg type families type family XPresent x type family XMissing x 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 --- ----------------------------------------------------------------------+-- -------------------------------------+-- HsBracket type families type family XExpBr x type family XPatBr x type family XDecBrL x@@ -609,33 +607,33 @@ type family XTExpBr x type family XXBracket x --- ----------------------------------------------------------------------+-- -------------------------------------+-- HsCmdTop type families type family XCmdTop x type family XXCmdTop x -- --------------------------------------+-- MatchGroup type families type family XMG x b type family XXMatchGroup x b -- --------------------------------------+-- Match type families type family XCMatch x b type family XXMatch x b -- --------------------------------------+-- GRHSs type families type family XCGRHSs x b type family XXGRHSs x b -- --------------------------------------+-- GRHS type families type family XCGRHS x b type family XXGRHS x b -- --------------------------------------+-- StmtLR type families type family XLastStmt x x' b type family XBindStmt x x' b type family XApplicativeStmt x x' b@@ -646,8 +644,8 @@ type family XRecStmt x x' b type family XXStmtLR x x' b --- ----------------------------------------------------------------------+-- -------------------------------------+-- HsCmd type families type family XCmdArrApp x type family XCmdArrForm x type family XCmdApp x@@ -661,13 +659,13 @@ type family XCmdWrap x type family XXCmd x --- ----------------------------------------------------------------------+-- -------------------------------------+-- ParStmtBlock type families type family XParStmtBlock x x' type family XXParStmtBlock x x' --- ----------------------------------------------------------------------+-- -------------------------------------+-- ApplicativeArg type families type family XApplicativeArgOne x type family XApplicativeArgMany x type family XXApplicativeArg x@@ -697,6 +695,8 @@ type family XHsDoublePrim x type family XXLit x +-- -------------------------------------+-- HsOverLit type families type family XOverLit x type family XXOverLit x @@ -725,26 +725,29 @@ -- ===================================================================== -- Type families for the HsTypes type families ++-- -------------------------------------+-- LHsQTyVars type families type family XHsQTvs x type family XXLHsQTyVars x -- --------------------------------------+-- HsImplicitBndrs type families type family XHsIB x b type family XXHsImplicitBndrs x b -- --------------------------------------+-- HsWildCardBndrs type families type family XHsWC x b type family XXHsWildCardBndrs x b -- --------------------------------------+-- HsPatSigType type families type family XHsPS x type family XXHsPatSigType x -- --------------------------------------+-- HsType type families type family XForAllTy x type family XQualTy x type family XTyVar x@@ -770,35 +773,37 @@ type family XXType x -- ----------------------------------------------------------------------+-- HsForAllTelescope type families type family XHsForAllVis x type family XHsForAllInvis x type family XXHsForAllTelescope x -- ----------------------------------------------------------------------+-- HsTyVarBndr type families type family XUserTyVar x type family XKindedTyVar x type family XXTyVarBndr x -- ----------------------------------------------------------------------+-- ConDeclField type families type family XConDeclField x type family XXConDeclField x -- ----------------------------------------------------------------------+-- FieldOcc type families type family XCFieldOcc x type family XXFieldOcc x -- ===================================================================== -- Type families for the HsImpExp type families +-- -------------------------------------+-- ImportDecl type families type family XCImportDecl x type family XXImportDecl x -- --------------------------------------+-- IE type families type family XIEVar x type family XIEThingAbs x type family XIEThingAll x
compiler/GHC/Hs/ImpExp.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+ -- in module GHC.Hs.Extension {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,14 +12,6 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]- -- in module GHC.Hs.Extension- module GHC.Hs.ImpExp where import GHC.Prelude@@ -21,7 +19,7 @@ import GHC.Unit.Module ( ModuleName, IsBootInterface(..) ) import GHC.Hs.Doc ( HsDocString ) import GHC.Types.Name.Occurrence ( HasOccName(..), isTcOcc, isSymOcc )-import GHC.Types.Basic ( SourceText(..), StringLiteral(..), pprWithSourceText )+import GHC.Types.SourceText ( SourceText(..), StringLiteral(..), pprWithSourceText ) import GHC.Types.FieldLabel ( FieldLbl(..) ) import GHC.Utils.Outputable@@ -81,7 +79,7 @@ = ImportDecl { ideclExt :: XCImportDecl pass, ideclSourceSrc :: SourceText,- -- Note [Pragma source text] in GHC.Types.Basic+ -- Note [Pragma source text] in GHC.Types.SourceText ideclName :: XRec pass ModuleName, -- ^ Module name. ideclPkgQual :: Maybe StringLiteral, -- ^ Package qualifier. ideclSource :: IsBootInterface, -- ^ IsBoot <=> {-\# SOURCE \#-} import@@ -310,9 +308,6 @@ lieWrappedName :: LIEWrappedName name -> name lieWrappedName (L _ n) = ieWrappedName n--ieLWrappedName :: LIEWrappedName name -> Located name-ieLWrappedName (L l n) = L l (ieWrappedName n) replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2 replaceWrappedName (IEName (L l _)) n = IEName (L l n)
compiler/GHC/Hs/Instances.hs view
@@ -173,6 +173,11 @@ deriving instance Data (ConDecl GhcRn) deriving instance Data (ConDecl GhcTc) +-- deriving instance DataIdLR p p => Data (HsConDeclGADTDetails p)+deriving instance Data (HsConDeclGADTDetails GhcPs)+deriving instance Data (HsConDeclGADTDetails GhcRn)+deriving instance Data (HsConDeclGADTDetails GhcTc)+ -- deriving instance DataIdLR p p => Data (TyFamInstDecl p) deriving instance Data (TyFamInstDecl GhcPs) deriving instance Data (TyFamInstDecl GhcRn)
compiler/GHC/Hs/Lit.hs view
@@ -1,20 +1,19 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+ -- in module GHC.Hs.Extension+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -\section[HsLit]{Abstract syntax: source-language literals} -} -{-# LANGUAGE CPP, DeriveDataTypeable #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]- -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}-+-- | Source-language literals module GHC.Hs.Lit where #include "GhclibHsVersions.h"@@ -22,10 +21,8 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr )-import GHC.Types.Basic- ( IntegralLit(..), FractionalLit(..), negateIntegralLit- , negateFractionalLit, SourceText(..), pprWithSourceText- , PprPrec(..), topPrec )+import GHC.Types.Basic (PprPrec(..), topPrec )+import GHC.Types.SourceText import GHC.Core.Type import GHC.Utils.Outputable import GHC.Utils.Panic
compiler/GHC/Hs/Pat.hs view
@@ -1,4 +1,17 @@ +{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+ -- in module GHC.Hs.Extension+{-# LANGUAGE ViewPatterns #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,23 +19,6 @@ \section[PatSyntax]{Abstract Haskell syntax---patterns} -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]- -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE LambdaCase #-}- module GHC.Hs.Pat ( Pat(..), LPat, ConPatTc (..),@@ -61,6 +57,7 @@ import GHC.Hs.Type import GHC.Tc.Types.Evidence import GHC.Types.Basic+import GHC.Types.SourceText -- others: import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Builtin.Types
compiler/GHC/Hs/Type.hs view
@@ -1,3 +1,14 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+ -- in module GHC.Hs.Extension {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,20 +17,6 @@ GHC.Hs.Type: Abstract syntax: user-defined types -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]- -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ViewPatterns #-}- module GHC.Hs.Type ( Mult, HsScaled(..), hsMult, hsScaledThing,@@ -90,6 +87,7 @@ import GHC.Hs.Extension import GHC.Types.Id ( Id )+import GHC.Types.SourceText import GHC.Types.Name( Name, NamedThing(getName) ) import GHC.Types.Name.Reader ( RdrName ) import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..),@@ -106,6 +104,7 @@ import Data.Data hiding ( Fixity, Prefix, Infix ) import Data.Maybe+import GHC.Parser.Annotation {- ************************************************************************@@ -933,22 +932,23 @@ -- | Denotes the type of arrows in the surface language data HsArrow pass- = HsUnrestrictedArrow- -- ^ a -> b- | HsLinearArrow- -- ^ a %1 -> b- | HsExplicitMult (LHsType pass)- -- ^ a %m -> b (very much including `a %Many -> b`! This is how the- -- programmer wrote it). It is stored as an `HsType` so as to preserve the- -- syntax as written in the program.+ = HsUnrestrictedArrow IsUnicodeSyntax+ -- ^ a -> b or a → b+ | HsLinearArrow IsUnicodeSyntax+ -- ^ a %1 -> b or a %1 → b, or a ⊸ b+ | HsExplicitMult IsUnicodeSyntax (LHsType 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+ -- `HsType` so as to preserve the syntax as written in the+ -- program. -- | Convert an arrow into its corresponding multiplicity. In essence this -- erases the information of whether the programmer wrote an explicit -- multiplicity or a shorthand. arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn-arrowToHsType HsUnrestrictedArrow = noLoc manyDataConHsTy-arrowToHsType HsLinearArrow = noLoc oneDataConHsTy-arrowToHsType (HsExplicitMult p) = p+arrowToHsType (HsUnrestrictedArrow _) = noLoc manyDataConHsTy+arrowToHsType (HsLinearArrow _) = noLoc oneDataConHsTy+arrowToHsType (HsExplicitMult _ p) = p -- | This is used in the syntax. In constructor declaration. It must keep the -- arrow representation.@@ -963,20 +963,23 @@ -- | When creating syntax we use the shorthands. It's better for printing, also, -- the shorthands work trivially at each pass. hsUnrestricted, hsLinear :: a -> HsScaled pass a-hsUnrestricted = HsScaled HsUnrestrictedArrow-hsLinear = HsScaled HsLinearArrow+hsUnrestricted = HsScaled (HsUnrestrictedArrow NormalSyntax)+hsLinear = HsScaled (HsLinearArrow NormalSyntax) instance Outputable a => Outputable (HsScaled pass a) where ppr (HsScaled _cnt t) = -- ppr cnt <> ppr t- ppr t+ ppr t instance (OutputableBndrId pass) => Outputable (HsArrow (GhcPass pass)) where- ppr HsUnrestrictedArrow = parens arrow- ppr HsLinearArrow = parens lollipop- ppr (HsExplicitMult p) = parens (mulArrow (ppr p))+ ppr arr = parens (pprHsArrow arr) +-- See #18846+pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc+pprHsArrow (HsUnrestrictedArrow _) = arrow+pprHsArrow (HsLinearArrow _) = lollipop+pprHsArrow (HsExplicitMult _ p) = (mulArrow (ppr p)) {- Note [Unit tuples]@@ -1057,20 +1060,19 @@ HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing, because of the #. However, with -XConstraintKinds we can only distinguish between constraint and boxed tuples during type checking, in general. Hence the-four constructors of HsTupleSort:+two constructors of HsTupleSort: HsUnboxedTuple -> Produced by the parser- HsBoxedTuple -> Certainly a boxed tuple- HsConstraintTuple -> Certainly a constraint tuple HsBoxedOrConstraintTuple -> Could be a boxed or a constraint tuple. Produced by the parser only, disappears after type checking++After typechecking, we use TupleSort (which clearly distinguishes between+constraint tuples and boxed tuples) rather than HsTupleSort. -} -- | Haskell Tuple Sort data HsTupleSort = HsUnboxedTuple- | HsBoxedTuple- | HsConstraintTuple | HsBoxedOrConstraintTuple deriving Data @@ -1100,9 +1102,22 @@ => Outputable (ConDeclField (GhcPass p)) where ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty --- HsConDetails is used for patterns/expressions *and* for data type--- declarations--- | Haskell Constructor Details+-- | Describes the arguments to a data constructor. This is a common+-- representation for several constructor-related concepts, including:+--+-- * The arguments in a Haskell98-style constructor declaration+-- (see 'HsConDeclH98Details' in "GHC.Hs.Decls").+--+-- * The arguments in constructor patterns in @case@/function definitions+-- (see 'HsConPatDetails' in "GHC.Hs.Pat").+--+-- * The left-hand side arguments in a pattern synonym binding+-- (see 'HsPatSynDetails' in "GHC.Hs.Binds").+--+-- One notable exception is the arguments in a GADT constructor, which uses+-- a separate data type entirely (see 'HsConDeclGADTDetails' in+-- "GHC.Hs.Decls"). This is because GADT constructors cannot be declared with+-- infix syntax, unlike the concepts above (#18844). data HsConDetails arg rec = PrefixCon [arg] -- C p1 p2 p3 | RecCon rec -- C { x = p1, y = p2 }@@ -1325,17 +1340,20 @@ -- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) -- Breaks up any parens in the result type: -- splitHsFunType (a -> (b -> c)) = ([a,b], c)+-- It returns API Annotations for any parens removed splitHsFunType :: LHsType (GhcPass p)- -> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))-splitHsFunType (L _ (HsParTy _ ty))- = splitHsFunType ty+ -> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p), [AddAnn])+splitHsFunType ty = go ty []+ where+ go (L l (HsParTy _ ty)) anns+ = go ty (anns ++ mkParensApiAnn l) -splitHsFunType (L _ (HsFunTy _ mult x y))- | (args, res) <- splitHsFunType y- = (HsScaled mult x:args, res)+ go (L _ (HsFunTy _ mult x y)) anns+ | (args, res, anns') <- go y anns+ = (HsScaled mult x:args, res, anns') -splitHsFunType other = ([], other)+ go other anns = ([], other, anns) -- | Retrieve the name of the \"head\" of a nested type application. -- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more@@ -1577,8 +1595,8 @@ -- Works on (LHsSigType GhcPs) getLHsInstDeclClass_maybe inst_ty = do { let head_ty = getLHsInstDeclHead inst_ty- ; cls <- hsTyGetAppHead_maybe head_ty- ; return cls }+ ; hsTyGetAppHead_maybe head_ty+ } {- Note [No nested foralls or contexts in instance types]@@ -1958,10 +1976,7 @@ ppr_fun_ty mult ty1 ty2 = let p1 = ppr_mono_lty ty1 p2 = ppr_mono_lty ty2- arr = case mult of- HsLinearArrow -> lollipop- HsUnrestrictedArrow -> arrow- HsExplicitMult p -> mulArrow (ppr p)+ arr = pprHsArrow mult in sep [p1, arr <+> p2] @@ -1985,11 +2000,9 @@ -- Special-case unary boxed tuple applications so that they are -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612) -- See Note [One-tuples] in GHC.Builtin.Types- go_hs_ty (HsTupleTy _ con [L _ ty])+ go_hs_ty (HsTupleTy _ con [_]) = case con of- HsBoxedTuple -> p >= appPrec HsBoxedOrConstraintTuple -> p >= appPrec- HsConstraintTuple -> go_hs_ty ty HsUnboxedTuple -> False go_hs_ty (HsTupleTy{}) = False go_hs_ty (HsSumTy{}) = False
compiler/GHC/Hs/Utils.hs view
@@ -116,8 +116,6 @@ import GHC.Hs.Extension import GHC.Tc.Types.Evidence-import GHC.Types.Name.Reader-import GHC.Types.Var import GHC.Core.TyCo.Rep import GHC.Core.Multiplicity ( pattern Many ) import GHC.Builtin.Types ( unitTy )@@ -128,11 +126,16 @@ import GHC.Types.Name import GHC.Types.Name.Set hiding ( unitFV ) import GHC.Types.Name.Env+import GHC.Types.Name.Reader+import GHC.Types.Var import GHC.Types.Basic 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.Parser.Annotation import GHC.Utils.Misc import GHC.Utils.Outputable@@ -351,9 +354,10 @@ mkRnBindStmt pat body = BindStmt (XBindStmtRn { xbsrn_bindOp = noSyntaxExpr, xbsrn_failOp = Nothing }) pat body mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr, xbstc_boundResultType = unitTy,+ -- unitTy is a dummy value+ -- can't panic here: it's forced during zonking xbstc_boundResultMult = Many, xbstc_failOp = Nothing }) pat body- -- don't use placeHolderTypeTc above, because that panics during zonking emptyRecStmt' :: forall idL idR body. IsPass idR => XRecStmt (GhcPass idL) (GhcPass idR) body@@ -537,12 +541,12 @@ nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p)-nlHsFunTy :: HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)+nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsAppTy f t = noLoc (HsAppTy noExtField f (parenthesizeHsType appPrec t)) nlHsTyVar x = noLoc (HsTyVar noExtField NotPromoted (noLoc x))-nlHsFunTy mult a b = noLoc (HsFunTy noExtField mult (parenthesizeHsType funPrec a) b)+nlHsFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) (parenthesizeHsType funPrec a) b) nlHsParTy t = noLoc (HsParTy noExtField t) nlHsTyConApp :: LexicalFixity -> IdP (GhcPass p)@@ -1255,29 +1259,36 @@ in case unLoc r of -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156)- ConDeclGADT { con_names = names, con_args = args }+ ConDeclGADT { con_names = names, con_g_args = args } -> (map (L loc . unLoc) names ++ ns, flds ++ fs) where- (remSeen', flds) = get_flds remSeen args+ (remSeen', flds) = get_flds_gadt remSeen args (ns, fs) = go remSeen' rs ConDeclH98 { con_name = name, con_args = args } -> ([L loc (unLoc name)] ++ ns, flds ++ fs) where- (remSeen', flds) = get_flds remSeen args+ (remSeen', flds) = get_flds_h98 remSeen args (ns, fs) = go remSeen' rs - get_flds :: Seen p -> HsConDeclDetails (GhcPass p)+ get_flds_h98 :: Seen p -> HsConDeclH98Details (GhcPass p)+ -> (Seen p, [LFieldOcc (GhcPass p)])+ get_flds_h98 remSeen (RecCon flds) = get_flds remSeen flds+ get_flds_h98 remSeen _ = (remSeen, [])++ get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p)+ -> (Seen p, [LFieldOcc (GhcPass p)])+ get_flds_gadt remSeen (RecConGADT flds) = get_flds remSeen flds+ get_flds_gadt remSeen _ = (remSeen, [])++ get_flds :: Seen p -> Located [LConDeclField (GhcPass p)] -> (Seen p, [LFieldOcc (GhcPass p)])- get_flds remSeen (RecCon flds)- = (remSeen', fld_names)+ get_flds remSeen flds = (remSeen', fld_names) where fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds)) remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v | v <- fld_names]- get_flds remSeen _- = (remSeen, []) {-
+ compiler/GHC/Iface/Ext/Fields.hs view
@@ -0,0 +1,94 @@+module GHC.Iface.Ext.Fields+ ( ExtensibleFields (..)+ , FieldName+ , emptyExtensibleFields+ -- * Reading+ , readField+ , readFieldWith+ -- * Writing+ , writeField+ , writeFieldWith+ -- * Deletion+ , deleteField+ )+where++import GHC.Prelude+import GHC.Utils.Binary++import Control.Monad+import Data.Map ( Map )+import qualified Data.Map as Map+import Control.DeepSeq++type FieldName = String++newtype ExtensibleFields = ExtensibleFields { getExtensibleFields :: (Map FieldName BinData) }++instance Binary ExtensibleFields where+ put_ bh (ExtensibleFields fs) = do+ put_ bh (Map.size fs :: Int)++ -- Put the names of each field, and reserve a space+ -- for a payload pointer after each name:+ header_entries <- forM (Map.toList fs) $ \(name, dat) -> do+ put_ bh name+ field_p_p <- tellBin bh+ put_ bh field_p_p+ return (field_p_p, dat)++ -- Now put the payloads and use the reserved space+ -- to point to the start of each payload:+ forM_ header_entries $ \(field_p_p, dat) -> do+ field_p <- tellBin bh+ putAt bh field_p_p field_p+ seekBin bh field_p+ put_ bh dat++ get bh = do+ n <- get bh :: IO Int++ -- Get the names and field pointers:+ header_entries <- replicateM n $+ (,) <$> get bh <*> get bh++ -- Seek to and get each field's payload:+ fields <- forM header_entries $ \(name, field_p) -> do+ seekBin bh field_p+ dat <- get bh+ return (name, dat)++ return . ExtensibleFields . Map.fromList $ fields++instance NFData ExtensibleFields where+ rnf (ExtensibleFields fs) = rnf fs++emptyExtensibleFields :: ExtensibleFields+emptyExtensibleFields = ExtensibleFields Map.empty++--------------------------------------------------------------------------------+-- | Reading++readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)+readField name = readFieldWith name get++readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)+readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>+ Map.lookup name (getExtensibleFields fields)++--------------------------------------------------------------------------------+-- | Writing++writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields+writeField name x = writeFieldWith name (`put_` x)++writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields+writeFieldWith name write fields = do+ bh <- openBinMem (1024 * 1024)+ write bh+ --+ bd <- handleData bh+ return $ ExtensibleFields (Map.insert name bd $ getExtensibleFields fields)++deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields+deleteField name (ExtensibleFields fs) = ExtensibleFields $ Map.delete name fs
compiler/GHC/Iface/Recomp/Binary.hs view
@@ -35,8 +35,7 @@ computeFingerprint put_nonbinding_name a = do bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block put_ bh a- fp <- fingerprintBinMem bh- return fp+ fingerprintBinMem bh where set_user_data bh = setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS
compiler/GHC/Iface/Syntax.hs view
@@ -73,6 +73,7 @@ import GHC.Utils.Lexeme (isLexSym) import GHC.Utils.Fingerprint import GHC.Utils.Binary+import GHC.Utils.Binary.Typeable () import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, debugIsOn,@@ -194,7 +195,7 @@ | IfDataInstance IfExtName -- Axiom name IfaceTyCon -- Family TyCon (pretty-printing only, not used in GHC.IfaceToCore)- -- see Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing+ -- see Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr IfaceAppArgs -- Arguments of the family TyCon data IfaceFamTyConFlav@@ -203,7 +204,7 @@ | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch])) -- ^ Name of associated axiom and branches for pretty printing purposes, -- or 'Nothing' for an empty closed family without an axiom- -- See Note [Pretty printing via Iface syntax] in "GHC.Core.Ppr.TyThing"+ -- See Note [Pretty printing via Iface syntax] in "GHC.Types.TyThing.Ppr" | IfaceAbstractClosedSynFamilyTyCon | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only @@ -463,12 +464,13 @@ -- *Excludes* the 'main' name, but *includes* the implicitly-bound names -- Deeply revolting, because it has to predict what gets bound, -- especially the question of whether there's a wrapper for a datacon--- See Note [Implicit TyThings] in GHC.Driver.Types+-- 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.Types.implicitTyThings, in the sense that+-- TyThings returned by GHC.Driver.Env.implicitTyThings, in the sense that -- TyThing.getOccName should define a bijection between the two lists.--- This invariant is used in GHC.Iface.Load.loadDecl (see note [Tricky iface loop])+-- This invariant is used in GHC.IfaceToCore.tc_iface_decl_fingerprint (see note+-- [Tricky iface loop]) -- The order of the list does not matter. ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons })@@ -736,7 +738,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The binders in an IfaceDecl are just OccNames, so we don't know what module they come from. But when we pretty-print a TyThing by converting to an IfaceDecl-(see GHC.Core.Ppr.TyThing), the TyThing may come from some other module so we really need+(see GHC.Types.TyThing.Ppr), the TyThing may come from some other module so we really need the module qualifier. We solve this by passing in a pretty-printer for the binders. @@ -806,7 +808,7 @@ pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi--- See Note [Pretty-printing TyThings] in GHC.Core.Ppr.TyThing+-- See Note [Pretty-printing TyThings] in GHC.Types.TyThing.Ppr pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, ifCtxt = context, ifResKind = kind, ifRoles = roles, ifCons = condecls,@@ -2016,13 +2018,13 @@ When we read an interface file, we extend the PTE, a mapping of Names to TyThings, with the declarations we have read. The extension of the PTE is strict in the Names, but not in the TyThings themselves.-GHC.Iface.Load.loadDecl calculates the list of (Name, TyThing) bindings to-add to the PTE. For an IfaceId, there's just one binding to add; and+GHC.IfaceToCore.tcIfaceDecls calculates the list of (Name, TyThing) bindings+to add to the PTE. For an IfaceId, there's just one binding to add; and the ty, details, and idinfo fields of an IfaceId are used only in the TyThing. So by reading those fields lazily we may be able to save the work of ever having to deserialize them (into IfaceType, etc.). -For IfaceData and IfaceClass, loadDecl creates extra implicit bindings+For IfaceData and IfaceClass, tcIfaceDecls creates extra implicit bindings (the constructors and field selectors of the data declaration, or the methods of the class), whose Names depend on more than just the Name of the type constructor or class itself. So deserializing them lazily@@ -2138,10 +2140,10 @@ get bh = do h <- getByte bh case h of- 0 -> do return IfNoBang- 1 -> do return IfStrict- 2 -> do return IfUnpack- _ -> do { a <- get bh; return (IfUnpackCo a) }+ 0 -> return IfNoBang+ 1 -> return IfStrict+ 2 -> return IfUnpack+ _ -> IfUnpackCo <$> get bh instance Binary IfaceSrcBang where put_ bh (IfSrcBang a1 a2) =
compiler/GHC/Iface/Type.hs view
@@ -155,7 +155,7 @@ -- | A kind of universal type, used for types and kinds. -- -- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType'--- before being printed. See Note [Pretty printing via Iface syntax] in "GHC.Core.Ppr.TyThing"+-- before being printed. See Note [Pretty printing via Iface syntax] in "GHC.Types.TyThing.Ppr" data IfaceType = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType] | IfaceTyVar IfLclName -- Type/coercion variable only, not tycon@@ -280,7 +280,7 @@ Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to an IfaceType and pretty printing that. This eliminates a lot of pretty-print duplication, and it matches what we do with pretty--printing TyThings. See Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing.+printing TyThings. See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr. It works fine for closed types, but when printing debug traces (e.g. when using -ddump-tc-trace) we print a lot of /open/ types. These@@ -858,15 +858,15 @@ return (IfaceTvBndr ab) instance Binary IfaceOneShot where- put_ bh IfaceNoOneShot = do+ put_ bh IfaceNoOneShot = putByte bh 0- put_ bh IfaceOneShot = do+ put_ bh IfaceOneShot = putByte bh 1 get bh = do h <- getByte bh case h of- 0 -> do return IfaceNoOneShot- _ -> do return IfaceOneShot+ 0 -> return IfaceNoOneShot+ _ -> return IfaceOneShot -- ----------------------------- Printing IfaceType ------------------------------------ @@ -987,7 +987,7 @@ We certainly don't want to say "Can't match LiftedRep ~ LiftedRep"! But if we are printing the type- (forall (a :: Type r). blah+ (forall (a :: TYPE r). blah we do want to turn that (free) r into LiftedRep, so it prints as (forall a. blah) @@ -1905,7 +1905,7 @@ return (IfaceLitTy n) instance Binary IfaceMCoercion where- put_ bh IfaceMRefl = do+ put_ bh IfaceMRefl = putByte bh 1 put_ bh (IfaceMCo co) = do putByte bh 2
compiler/GHC/Parser/Annotation.hs view
@@ -6,6 +6,7 @@ ApiAnns(..), ApiAnnKey, AnnKeywordId(..),+ AddAnn(..),mkParensApiAnn, AnnotationComment(..), IsUnicodeSyntax(..), unicodeAnn,@@ -148,6 +149,44 @@ type ApiAnnKey = (RealSrcSpan,AnnKeywordId) +-- ---------------------------------------------------------------------++-- | Encapsulated call to addAnnotation, requiring only the SrcSpan of+-- the AST construct the annotation belongs to; together with the+-- AnnKeywordId, this is the key of the annotation map.+--+-- This type is useful for places in the parser where it is not yet+-- known what SrcSpan an annotation should be added to. The most+-- common situation is when we are parsing a list: the annotations+-- need to be associated with the AST element that *contains* the+-- list, not the list itself. 'AddAnn' lets us defer adding the+-- annotations until we finish parsing the list and are now parsing+-- the enclosing element; we then apply the 'AddAnn' to associate+-- the annotations. Another common situation is where a common fragment of+-- the AST has been factored out but there is no separate AST node for+-- this fragment (this occurs in class and data declarations). In this+-- case, the annotation belongs to the parent data declaration.+--+-- The usual way an 'AddAnn' is created is using the 'mj' ("make jump")+-- function, and then it can be discharged using the 'ams' function.+data AddAnn = AddAnn AnnKeywordId SrcSpan++-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate+-- 'AddAnn' values for the opening and closing bordering on the start+-- and end of the span+mkParensApiAnn :: SrcSpan -> [AddAnn]+mkParensApiAnn (UnhelpfulSpan _) = []+mkParensApiAnn (RealSrcSpan ss _) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc]+ where+ f = srcSpanFile ss+ sl = srcSpanStartLine ss+ sc = srcSpanStartCol ss+ el = srcSpanEndLine ss+ ec = srcSpanEndCol ss+ lo = RealSrcSpan (mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1))) Nothing+ lc = RealSrcSpan (mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)) Nothing++-- --------------------------------------------------------------------- -- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' -- of the annotated AST element, and the known type of the annotation. getAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId -> [RealSrcSpan]@@ -197,10 +236,9 @@ -- various syntactic keywords that are not captured in the existing -- AST. ----- The annotations, together with original source comments are made--- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@.--- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in--- @'GHC.Driver.Session.DynFlags'@ before parsing.+-- The annotations, together with original source comments are made available in+-- the @'pm_annotations'@ field of @'GHC.Driver.Env.HsParsedModule'@.+-- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set. -- -- The wiki page describing this feature is -- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations@@ -279,6 +317,8 @@ | AnnDollarDollar -- ^ prefix '$$' -- TemplateHaskell | AnnPackageName | AnnPattern+ | AnnPercent -- ^ '%' -- for HsExplicitMult+ | AnnPercentOne -- ^ '%1' -- for HsLinearArrow | AnnProc | AnnQualified | AnnRarrow -- ^ '->'
+ compiler/GHC/Parser/Errors.hs view
@@ -0,0 +1,420 @@+module GHC.Parser.Errors+ ( Warning(..)+ , TransLayoutReason(..)+ , OperatorWhitespaceSymbol(..)+ , OperatorWhitespaceOccurrence(..)+ , NumUnderscoreReason(..)+ , Error(..)+ , ErrorDesc(..)+ , LexErr(..)+ , CmmParserError(..)+ , LexErrKind(..)+ , Hint(..)+ , StarIsType (..)+ )+where++import GHC.Prelude+import GHC.Types.SrcLoc+import GHC.Types.Name.Reader (RdrName)+import GHC.Types.Name.Occurrence (OccName)+import GHC.Parser.Types+import GHC.Hs.Extension+import GHC.Hs.Expr+import GHC.Hs.Pat+import GHC.Hs.Type+import GHC.Hs.Lit+import GHC.Hs.Decls+import GHC.Core.Coercion.Axiom (Role)+import GHC.Utils.Outputable (SDoc)+import GHC.Data.FastString+import GHC.Unit.Module.Name++data Warning++ -- | Warn when tabulations are found+ = WarnTab+ { tabFirst :: !SrcSpan -- ^ First occurence of a tab+ , tabCount :: !Word -- ^ Number of other occurences+ }++ | WarnTransitionalLayout !SrcSpan !TransLayoutReason+ -- ^ Transitional layout warnings++ | WarnUnrecognisedPragma !SrcSpan+ -- ^ Unrecognised pragma++ | WarnHaddockInvalidPos !SrcSpan+ -- ^ Invalid Haddock comment position++ | WarnHaddockIgnoreMulti !SrcSpan+ -- ^ Multiple Haddock comment for the same entity++ | WarnStarBinder !SrcSpan+ -- ^ Found binding occurence of "*" while StarIsType is enabled++ | WarnStarIsType !SrcSpan+ -- ^ Using "*" for "Type" without StarIsType enabled++ | WarnImportPreQualified !SrcSpan+ -- ^ Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled++ | WarnOperatorWhitespaceExtConflict !SrcSpan !OperatorWhitespaceSymbol+ | WarnOperatorWhitespace !SrcSpan !FastString !OperatorWhitespaceOccurrence++-- | The operator symbol in the 'WarnOperatorWhitespaceExtConflict' warning.+data OperatorWhitespaceSymbol+ = OperatorWhitespaceSymbol_PrefixPercent+ | OperatorWhitespaceSymbol_PrefixDollar+ | OperatorWhitespaceSymbol_PrefixDollarDollar++-- | The operator occurrence type in the 'WarnOperatorWhitespace' warning.+data OperatorWhitespaceOccurrence+ = OperatorWhitespaceOccurrence_Prefix+ | OperatorWhitespaceOccurrence_Suffix+ | OperatorWhitespaceOccurrence_TightInfix++data TransLayoutReason+ = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block"+ | TransLayout_Pipe -- ^ "`|' at the same depth as implicit layout block")++data Error = Error+ { errDesc :: !ErrorDesc -- ^ Error description+ , errHints :: ![Hint] -- ^ Hints+ , errLoc :: !SrcSpan -- ^ Error position+ }++data ErrorDesc+ = ErrLambdaCase+ -- ^ LambdaCase syntax used without the extension enabled++ | ErrNumUnderscores !NumUnderscoreReason+ -- ^ Underscores in literals without the extension enabled++ | ErrPrimStringInvalidChar+ -- ^ Invalid character in primitive string++ | ErrMissingBlock+ -- ^ Missing block++ | ErrLexer !LexErr !LexErrKind+ -- ^ Lexer error++ | ErrSuffixAT+ -- ^ Suffix occurence of `@`++ | ErrParse !String+ -- ^ Parse errors++ | ErrCmmLexer+ -- ^ Cmm lexer error++ | ErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs))+ -- ^ Unsupported boxed sum in expression++ | ErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs))+ -- ^ Unsupported boxed sum in pattern++ | ErrUnexpectedQualifiedConstructor !RdrName+ -- ^ Unexpected qualified constructor++ | ErrTupleSectionInPat+ -- ^ Tuple section in pattern context++ | ErrIllegalBangPattern !(Pat GhcPs)+ -- ^ Bang-pattern without BangPattterns enabled++ | ErrOpFewArgs !StarIsType !RdrName+ -- ^ Operator applied to too few arguments++ | ErrImportQualifiedTwice+ -- ^ Import: multiple occurrences of 'qualified'++ | ErrImportPostQualified+ -- ^ Post qualified import without 'ImportQualifiedPost'++ | ErrIllegalExplicitNamespace+ -- ^ Explicit namespace keyword without 'ExplicitNamespaces'++ | ErrVarForTyCon !RdrName+ -- ^ Expecting a type constructor but found a variable++ | ErrIllegalPatSynExport+ -- ^ Illegal export form allowed by PatternSynonyms++ | ErrMalformedEntityString+ -- ^ Malformed entity string++ | ErrDotsInRecordUpdate+ -- ^ Dots used in record update++ | ErrPrecedenceOutOfRange !Int+ -- ^ Precedence out of range++ | ErrInvalidDataCon !(HsType GhcPs)+ -- ^ Cannot parse data constructor in a data/newtype declaration++ | ErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs)+ -- ^ Cannot parse data constructor in a data/newtype declaration++ | ErrUnpackDataCon+ -- ^ UNPACK applied to a data constructor++ | ErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs)+ -- ^ Unexpected kind application in data/newtype declaration++ | ErrInvalidRecordCon !(PatBuilder GhcPs)+ -- ^ Not a record constructor++ | ErrIllegalUnboxedStringInPat !(HsLit GhcPs)+ -- ^ Illegal unboxed string literal in pattern++ | ErrDoNotationInPat+ -- ^ Do-notation in pattern++ | ErrIfTheElseInPat+ -- ^ If-then-else syntax in pattern++ | ErrTypeAppInPat+ -- ^ Type-application in pattern++ | ErrLambdaCaseInPat+ -- ^ Lambda-case in pattern++ | ErrCaseInPat+ -- ^ case..of in pattern++ | ErrLetInPat+ -- ^ let-syntax in pattern++ | ErrLambdaInPat+ -- ^ Lambda-syntax in pattern++ | ErrArrowExprInPat !(HsExpr GhcPs)+ -- ^ Arrow expression-syntax in pattern++ | ErrArrowCmdInPat !(HsCmd GhcPs)+ -- ^ Arrow command-syntax in pattern++ | ErrArrowCmdInExpr !(HsCmd GhcPs)+ -- ^ Arrow command-syntax in expression++ | ErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs)+ -- ^ View-pattern in expression++ | ErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs)+ -- ^ Type-application without space before '@'++ | ErrLazyPatWithoutSpace !(LHsExpr GhcPs)+ -- ^ Lazy-pattern ('~') without space after it++ | ErrBangPatWithoutSpace !(LHsExpr GhcPs)+ -- ^ Bang-pattern ('!') without space after it++ | ErrUnallowedPragma !(HsPragE GhcPs)+ -- ^ Pragma not allowed in this position++ | ErrQualifiedDoInCmd !ModuleName+ -- ^ Qualified do block in command++ | ErrInvalidInfixHole+ -- ^ Invalid infix hole, expected an infix operator++ | ErrSemiColonsInCondExpr+ -- ^ Unexpected semi-colons in conditional expression+ !(HsExpr GhcPs) -- ^ conditional expr+ !Bool -- ^ "then" semi-colon?+ !(HsExpr GhcPs) -- ^ "then" expr+ !Bool -- ^ "else" semi-colon?+ !(HsExpr GhcPs) -- ^ "else" expr++ | ErrSemiColonsInCondCmd+ -- ^ Unexpected semi-colons in conditional command+ !(HsExpr GhcPs) -- ^ conditional expr+ !Bool -- ^ "then" semi-colon?+ !(HsCmd GhcPs) -- ^ "then" expr+ !Bool -- ^ "else" semi-colon?+ !(HsCmd GhcPs) -- ^ "else" expr++ | ErrAtInPatPos+ -- ^ @-operator in a pattern position++ | ErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs)+ -- ^ Unexpected lambda command in function application++ | ErrCaseCmdInFunAppCmd !(LHsCmd GhcPs)+ -- ^ Unexpected case command in function application++ | ErrIfCmdInFunAppCmd !(LHsCmd GhcPs)+ -- ^ Unexpected if command in function application++ | ErrLetCmdInFunAppCmd !(LHsCmd GhcPs)+ -- ^ Unexpected let command in function application++ | ErrDoCmdInFunAppCmd !(LHsCmd GhcPs)+ -- ^ Unexpected do command in function application++ | ErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)+ -- ^ Unexpected do block in function application++ | ErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)+ -- ^ Unexpected mdo block in function application++ | ErrLambdaInFunAppExpr !(LHsExpr GhcPs)+ -- ^ Unexpected lambda expression in function application++ | ErrCaseInFunAppExpr !(LHsExpr GhcPs)+ -- ^ Unexpected case expression in function application++ | ErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs)+ -- ^ Unexpected lambda-case expression in function application++ | ErrLetInFunAppExpr !(LHsExpr GhcPs)+ -- ^ Unexpected let expression in function application++ | ErrIfInFunAppExpr !(LHsExpr GhcPs)+ -- ^ Unexpected if expression in function application++ | ErrProcInFunAppExpr !(LHsExpr GhcPs)+ -- ^ Unexpected proc expression in function application++ | ErrMalformedTyOrClDecl !(LHsType GhcPs)+ -- ^ Malformed head of type or class declaration++ | ErrIllegalWhereInDataDecl+ -- ^ Illegal 'where' keyword in data declaration++ | ErrIllegalDataTypeContext !(LHsContext GhcPs)+ -- ^ Illegal datatyp context++ | ErrParseErrorOnInput !OccName+ -- ^ Parse error on input++ | ErrMalformedDecl !SDoc !RdrName+ -- ^ Malformed ... declaration for ...++ | ErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName+ -- ^ Unexpected type application in a declaration++ | ErrNotADataCon !RdrName+ -- ^ Not a data constructor++ | ErrRecordSyntaxInPatSynDecl !(LPat GhcPs)+ -- ^ Record syntax used in pattern synonym declaration++ | ErrEmptyWhereInPatSynDecl !RdrName+ -- ^ Empty 'where' clause in pattern-synonym declaration++ | ErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)+ -- ^ Invalid binding name in 'where' clause of pattern-synonym declaration++ | ErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)+ -- ^ Multiple bindings in 'where' clause of pattern-synonym declaration++ | ErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs)+ -- ^ Declaration splice not a top-level++ | ErrInferredTypeVarNotAllowed+ -- ^ Inferred type variables not allowed here++ | ErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs]+ -- ^ Multiple names in standalone kind signatures++ | ErrIllegalImportBundleForm+ -- ^ Illegal import bundle form++ | ErrIllegalRoleName !FastString [Role]+ -- ^ Illegal role name++ | ErrInvalidTypeSignature !(LHsExpr GhcPs)+ -- ^ Invalid type signature++ | ErrUnexpectedTypeInDecl !(LHsType GhcPs) !SDoc !RdrName [LHsTypeArg GhcPs] !SDoc+ -- ^ Unexpected type in declaration++ | ErrExpectedHyphen+ -- ^ Expected a hyphen++ | ErrSpaceInSCC+ -- ^ Found a space in a SCC++ | ErrEmptyDoubleQuotes !Bool-- Is TH on?+ -- ^ Found two single quotes++ | ErrInvalidPackageName !FastString+ -- ^ Invalid package name++ | ErrInvalidRuleActivationMarker+ -- ^ Invalid rule activation marker++ | ErrLinearFunction+ -- ^ Linear function found but LinearTypes not enabled++ | ErrMultiWayIf+ -- ^ Multi-way if-expression found but MultiWayIf not enabled++ | ErrExplicitForall !Bool -- is Unicode forall?+ -- ^ Explicit forall found but no extension allowing it is enabled++ | ErrIllegalQualifiedDo !SDoc+ -- ^ Found qualified-do without QualifiedDo enabled++ | ErrCmmParser !CmmParserError+ -- ^ Cmm parser error++ | ErrIllegalTraditionalRecordSyntax !SDoc+ -- ^ Illegal traditional record syntax+ --+ -- TODO: distinguish errors without using SDoc++ | ErrParseErrorInCmd !SDoc+ -- ^ Parse error in command+ --+ -- TODO: distinguish errors without using SDoc++ | ErrParseErrorInPat !SDoc+ -- ^ Parse error in pattern+ --+ -- TODO: distinguish errors without using SDoc+++newtype StarIsType = StarIsType Bool++data NumUnderscoreReason+ = NumUnderscore_Integral+ | NumUnderscore_Float+ deriving (Show,Eq,Ord)++data Hint+ = SuggestTH+ | SuggestRecursiveDo+ | SuggestDo+ | SuggestMissingDo+ | SuggestLetInDo+ | SuggestPatternSynonyms+ | SuggestInfixBindMaybeAtPat !RdrName++data LexErrKind+ = LexErrKind_EOF -- ^ End of input+ | LexErrKind_UTF8 -- ^ UTF-8 decoding error+ | LexErrKind_Char !Char -- ^ Error at given character+ deriving (Show,Eq,Ord)++data LexErr+ = LexError -- ^ Lexical error+ | LexUnknownPragma -- ^ Unknown pragma+ | LexErrorInPragma -- ^ Lexical error in pragma+ | LexNumEscapeRange -- ^ Numeric escape sequence out of range+ | LexStringCharLit -- ^ Llexical error in string/character literal+ | LexStringCharLitEOF -- ^ Unexpected end-of-file in string/character literal+ | LexUnterminatedComment -- ^ Unterminated `{-'+ | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma+ | LexUnterminatedQQ -- ^ Unterminated quasiquotation++-- | Errors from the Cmm parser+data CmmParserError+ = CmmUnknownPrimitive !FastString -- ^ Unknown Cmm primitive+ | CmmUnknownMacro !FastString -- ^ Unknown macro+ | CmmUnknownCConv !String -- ^ Unknown calling convention+ | CmmUnrecognisedSafety !String -- ^ Unrecognised safety+ | CmmUnrecognisedHint !String -- ^ Unrecognised hint
+ compiler/GHC/Parser/Errors/Ppr.hs view
@@ -0,0 +1,613 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}++module GHC.Parser.Errors.Ppr+ ( pprWarning+ , pprError+ )+where++import GHC.Prelude+import GHC.Driver.Flags+import GHC.Parser.Errors+import GHC.Parser.Types+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Types.Name.Reader (starInfo, rdrNameOcc, opIsAt, mkUnqual)+import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName)+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Data.FastString+import GHC.Hs.Expr (prependQualified,HsExpr(..))+import GHC.Hs.Type (pprLHsContext)+import GHC.Builtin.Names (allNameStrings)+import GHC.Builtin.Types (filterCTuple)++mkParserErr :: SrcSpan -> SDoc -> ErrMsg+mkParserErr span doc = ErrMsg+ { errMsgSpan = span+ , errMsgContext = alwaysQualify+ , errMsgDoc = ErrDoc [doc] [] []+ , errMsgShortString = renderWithContext defaultSDocContext doc+ , errMsgSeverity = SevError+ , errMsgReason = NoReason+ }++mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> ErrMsg+mkParserWarn flag span doc = ErrMsg+ { errMsgSpan = span+ , errMsgContext = alwaysQualify+ , errMsgDoc = ErrDoc [doc] [] []+ , errMsgShortString = renderWithContext defaultSDocContext doc+ , errMsgSeverity = SevWarning+ , errMsgReason = Reason flag+ }++pprWarning :: Warning -> ErrMsg+pprWarning = \case+ WarnTab loc tc+ -> mkParserWarn Opt_WarnTabs loc $+ text "Tab character found here"+ <> (if tc == 1+ then text ""+ else text ", and in" <+> speakNOf (fromIntegral (tc - 1)) (text "further location"))+ <> text "."+ $+$ text "Please use spaces instead."++ WarnTransitionalLayout loc reason+ -> mkParserWarn Opt_WarnAlternativeLayoutRuleTransitional loc $+ 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"+ )++ WarnUnrecognisedPragma loc+ -> mkParserWarn Opt_WarnUnrecognisedPragmas loc $+ text "Unrecognised pragma"++ WarnHaddockInvalidPos loc+ -> mkParserWarn Opt_WarnInvalidHaddock loc $+ text "A Haddock comment cannot appear in this position and will be ignored."++ WarnHaddockIgnoreMulti loc+ -> mkParserWarn Opt_WarnInvalidHaddock loc $+ text "Multiple Haddock comments for a single entity are not allowed." $$+ text "The extraneous comment will be ignored."++ WarnStarBinder loc+ -> mkParserWarn Opt_WarnStarBinder loc $+ text "Found binding occurrence of" <+> quotes (text "*")+ <+> text "yet StarIsType is enabled."+ $$ text "NB. To use (or export) this operator in"+ <+> text "modules with StarIsType,"+ $$ text " including the definition module, you must qualify it."++ WarnStarIsType loc+ -> mkParserWarn Opt_WarnStarIsType loc $+ text "Using" <+> quotes (text "*")+ <+> text "(or its Unicode variant) to mean"+ <+> quotes (text "Data.Kind.Type")+ $$ text "relies on the StarIsType extension, which will become"+ $$ text "deprecated in the future."+ $$ text "Suggested fix: use" <+> quotes (text "Type")+ <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."++ WarnImportPreQualified loc+ -> mkParserWarn Opt_WarnPrepositiveQualifiedModule loc $+ text "Found" <+> quotes (text "qualified")+ <+> text "in prepositive position"+ $$ text "Suggested fix: place " <+> quotes (text "qualified")+ <+> text "after the module name instead."+ $$ text "To allow this, enable language extension 'ImportQualifiedPost'"++ WarnOperatorWhitespaceExtConflict loc sym+ -> mkParserWarn Opt_WarnOperatorWhitespaceExtConflict loc $+ let mk_prefix_msg operator_symbol extension_name syntax_meaning =+ text "The prefix use of a" <+> quotes (text operator_symbol)+ <+> text "would denote" <+> text syntax_meaning+ $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.")+ $$ text "Suggested fix: add whitespace after the"+ <+> quotes (text operator_symbol) <> char '.'+ in+ 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"+++ WarnOperatorWhitespace loc sym occ_type+ -> mkParserWarn Opt_WarnOperatorWhitespace loc $+ let mk_msg occ_type_str =+ text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym)+ <+> text "might be repurposed as special syntax"+ $$ nest 2 (text "by a future language extension.")+ $$ text "Suggested fix: add whitespace around it."+ in+ case occ_type of+ OperatorWhitespaceOccurrence_Prefix -> mk_msg "prefix"+ OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix"+ OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix"++pprError :: Error -> ErrMsg+pprError err = mkParserErr (errLoc err) $ vcat+ (pp_err (errDesc err) : map pp_hint (errHints err))++pp_err :: ErrorDesc -> SDoc+pp_err = \case+ ErrLambdaCase+ -> text "Illegal lambda-case (use LambdaCase)"++ ErrNumUnderscores reason+ -> text $ case reason of+ NumUnderscore_Integral -> "Use NumericUnderscores to allow underscores in integer literals"+ NumUnderscore_Float -> "Use NumericUnderscores to allow underscores in floating literals"++ ErrPrimStringInvalidChar+ -> text "primitive string literal must contain only characters <= \'\\xFF\'"++ ErrMissingBlock+ -> text "Missing block"++ ErrLexer err kind+ -> 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"+++ , text $ case kind of+ LexErrKind_EOF -> " at end of input"+ LexErrKind_UTF8 -> " (UTF-8 decoding error)"+ LexErrKind_Char c -> " at character " ++ show c+ ]++ ErrSuffixAT+ -> text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."++ ErrParse token+ | null token+ -> text "parse error (possibly incorrect indentation or mismatched brackets)"++ | otherwise+ -> text "parse error on input" <+> quotes (text token)++ ErrCmmLexer+ -> text "Cmm lexical error"++ ErrUnsupportedBoxedSumExpr s+ -> hang (text "Boxed sums not supported:") 2+ (pprSumOrTuple Boxed s)++ ErrUnsupportedBoxedSumPat s+ -> hang (text "Boxed sums not supported:") 2+ (pprSumOrTuple Boxed s)++ ErrUnexpectedQualifiedConstructor v+ -> hang (text "Expected an unqualified type constructor:") 2+ (ppr v)++ ErrTupleSectionInPat+ -> text "Tuple section in pattern context"++ ErrIllegalBangPattern e+ -> text "Illegal bang-pattern (use BangPatterns):" $$ ppr e++ ErrOpFewArgs (StarIsType star_is_type) op+ -> text "Operator applied to too few arguments:" <+> ppr op+ $$ starInfo star_is_type op++ ErrImportQualifiedTwice+ -> text "Multiple occurrences of 'qualified'"++ ErrImportPostQualified+ -> text "Found" <+> quotes (text "qualified")+ <+> text "in postpositive position. "+ $$ text "To allow this, enable language extension 'ImportQualifiedPost'"++ ErrIllegalExplicitNamespace+ -> text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"++ ErrVarForTyCon name+ -> text "Expecting a type constructor but found a variable,"+ <+> quotes (ppr name) <> text "."+ $$ if isSymOcc $ rdrNameOcc name+ then text "If" <+> quotes (ppr name) <+> text "is a type constructor"+ <+> text "then enable ExplicitNamespaces and use the 'type' keyword."+ else empty++ ErrIllegalPatSynExport+ -> text "Illegal export form (use PatternSynonyms to enable)"++ ErrMalformedEntityString+ -> text "Malformed entity string"++ ErrDotsInRecordUpdate+ -> text "You cannot use `..' in a record update"++ ErrPrecedenceOutOfRange i+ -> text "Precedence out of range: " <> int i++ ErrInvalidDataCon t+ -> hang (text "Cannot parse data constructor in a data/newtype declaration:") 2+ (ppr t)++ ErrInvalidInfixDataCon lhs tc rhs+ -> hang (text "Cannot parse an infix data constructor in a data/newtype declaration:")+ 2 (ppr lhs <+> ppr tc <+> ppr rhs)++ ErrUnpackDataCon+ -> text "{-# UNPACK #-} cannot be applied to a data constructor."++ ErrUnexpectedKindAppInDataCon lhs ki+ -> hang (text "Unexpected kind application in a data/newtype declaration:") 2+ (ppr lhs <+> text "@" <> ppr ki)++ ErrInvalidRecordCon p+ -> text "Not a record constructor:" <+> ppr p++ ErrIllegalUnboxedStringInPat lit+ -> text "Illegal unboxed string literal in pattern:" $$ ppr lit++ ErrDoNotationInPat+ -> text "do-notation in pattern"++ ErrIfTheElseInPat+ -> text "(if ... then ... else ...)-syntax in pattern"++ ErrTypeAppInPat+ -> text "Type applications in patterns are not yet supported"++ ErrLambdaCaseInPat+ -> text "(\\case ...)-syntax in pattern"++ ErrCaseInPat+ -> text "(case ... of ...)-syntax in pattern"++ ErrLetInPat+ -> text "(let ... in ...)-syntax in pattern"++ ErrLambdaInPat+ -> text "Lambda-syntax in pattern."+ $$ text "Pattern matching on functions is not possible."++ ErrArrowExprInPat e+ -> text "Expression syntax in pattern:" <+> ppr e++ ErrArrowCmdInPat c+ -> text "Command syntax in pattern:" <+> ppr c++ ErrArrowCmdInExpr c+ -> vcat+ [ text "Arrow command found where an expression was expected:"+ , nest 2 (ppr c)+ ]++ ErrViewPatInExpr a b+ -> sep [ text "View pattern in expression context:"+ , nest 4 (ppr a <+> text "->" <+> ppr b)+ ]++ ErrTypeAppWithoutSpace v e+ -> sep [ text "@-pattern in expression context:"+ , nest 4 (pprPrefixOcc v <> text "@" <> ppr e)+ ]+ $$ text "Type application syntax requires a space before '@'"+++ ErrLazyPatWithoutSpace e+ -> sep [ text "Lazy pattern in expression context:"+ , nest 4 (text "~" <> ppr e)+ ]+ $$ text "Did you mean to add a space after the '~'?"++ ErrBangPatWithoutSpace e+ -> sep [ text "Bang pattern in expression context:"+ , nest 4 (text "!" <> ppr e)+ ]+ $$ text "Did you mean to add a space after the '!'?"++ ErrUnallowedPragma prag+ -> hang (text "A pragma is not allowed in this position:") 2+ (ppr prag)++ ErrQualifiedDoInCmd m+ -> hang (text "Parse error in command:") 2 $+ text "Found a qualified" <+> ppr m <> text ".do block in a command, but"+ $$ text "qualified 'do' is not supported in commands."++ ErrParseErrorInCmd s+ -> hang (text "Parse error in command:") 2 s++ ErrParseErrorInPat s+ -> text "Parse error in pattern:" <+> s+++ ErrInvalidInfixHole+ -> text "Invalid infix hole, expected an infix operator"++ ErrSemiColonsInCondExpr c st t se e+ -> text "Unexpected semi-colons in conditional:"+ $$ nest 4 expr+ $$ text "Perhaps you meant to use DoAndIfThenElse?"+ where+ pprOptSemi True = semi+ pprOptSemi False = empty+ expr = text "if" <+> ppr c <> pprOptSemi st <+>+ text "then" <+> ppr t <> pprOptSemi se <+>+ text "else" <+> ppr e++ ErrSemiColonsInCondCmd c st t se e+ -> text "Unexpected semi-colons in conditional:"+ $$ nest 4 expr+ $$ text "Perhaps you meant to use DoAndIfThenElse?"+ where+ pprOptSemi True = semi+ pprOptSemi False = empty+ expr = text "if" <+> ppr c <> pprOptSemi st <+>+ text "then" <+> ppr t <> pprOptSemi se <+>+ text "else" <+> ppr e+++ ErrAtInPatPos+ -> text "Found a binding for the"+ <+> quotes (text "@")+ <+> text "operator in a pattern position."+ $$ perhaps_as_pat++ ErrLambdaCmdInFunAppCmd a+ -> pp_unexpected_fun_app (text "lambda command") a++ ErrCaseCmdInFunAppCmd a+ -> pp_unexpected_fun_app (text "case command") a++ ErrIfCmdInFunAppCmd a+ -> pp_unexpected_fun_app (text "if command") a++ ErrLetCmdInFunAppCmd a+ -> pp_unexpected_fun_app (text "let command") a++ ErrDoCmdInFunAppCmd a+ -> pp_unexpected_fun_app (text "do command") a++ ErrDoInFunAppExpr m a+ -> pp_unexpected_fun_app (prependQualified m (text "do block")) a++ ErrMDoInFunAppExpr m a+ -> pp_unexpected_fun_app (prependQualified m (text "mdo block")) a++ ErrLambdaInFunAppExpr a+ -> pp_unexpected_fun_app (text "lambda expression") a++ ErrCaseInFunAppExpr a+ -> pp_unexpected_fun_app (text "case expression") a++ ErrLambdaCaseInFunAppExpr a+ -> pp_unexpected_fun_app (text "lambda-case expression") a++ ErrLetInFunAppExpr a+ -> pp_unexpected_fun_app (text "let expression") a++ ErrIfInFunAppExpr a+ -> pp_unexpected_fun_app (text "if expression") a++ ErrProcInFunAppExpr a+ -> pp_unexpected_fun_app (text "proc expression") a++ ErrMalformedTyOrClDecl ty+ -> text "Malformed head of type or class declaration:"+ <+> ppr ty++ ErrIllegalWhereInDataDecl+ -> vcat+ [ text "Illegal keyword 'where' in data declaration"+ , text "Perhaps you intended to use GADTs or a similar language"+ , text "extension to enable syntax: data T where"+ ]++ ErrIllegalTraditionalRecordSyntax s+ -> text "Illegal record syntax (use TraditionalRecordSyntax):"+ <+> s++ ErrParseErrorOnInput occ+ -> text "parse error on input" <+> ftext (occNameFS occ)++ ErrIllegalDataTypeContext c+ -> text "Illegal datatype context (use DatatypeContexts):"+ <+> pprLHsContext c++ ErrMalformedDecl what for+ -> text "Malformed" <+> what+ <+> text "declaration for" <+> quotes (ppr for)++ ErrUnexpectedTypeAppInDecl ki what for+ -> vcat [ text "Unexpected type application"+ <+> text "@" <> ppr ki+ , text "In the" <+> what+ <+> text "declaration for"+ <+> quotes (ppr for)+ ]++ ErrNotADataCon name+ -> text "Not a data constructor:" <+> quotes (ppr name)++ ErrRecordSyntaxInPatSynDecl pat+ -> text "record syntax not supported for pattern synonym declarations:"+ $$ ppr pat++ ErrEmptyWhereInPatSynDecl patsyn_name+ -> text "pattern synonym 'where' clause cannot be empty"+ $$ text "In the pattern synonym declaration for: "+ <+> ppr (patsyn_name)++ ErrInvalidWhereBindInPatSynDecl patsyn_name decl+ -> text "pattern synonym 'where' clause must bind the pattern synonym's name"+ <+> quotes (ppr patsyn_name) $$ ppr decl++ ErrNoSingleWhereBindInPatSynDecl _patsyn_name decl+ -> text "pattern synonym 'where' clause must contain a single binding:"+ $$ ppr decl++ ErrDeclSpliceNotAtTopLevel d+ -> hang (text "Declaration splices are allowed only"+ <+> text "at the top level:")+ 2 (ppr d)++ ErrInferredTypeVarNotAllowed+ -> text "Inferred type variables are not allowed here"++ ErrIllegalRoleName role nearby+ -> text "Illegal role name" <+> quotes (ppr role)+ $$ case nearby of+ [] -> empty+ [r] -> text "Perhaps you meant" <+> quotes (ppr r)+ -- will this last case ever happen??+ _ -> hang (text "Perhaps you meant one of these:")+ 2 (pprWithCommas (quotes . ppr) nearby)++ ErrMultipleNamesInStandaloneKindSignature vs+ -> vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")+ 2 (pprWithCommas ppr vs)+ , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details."+ ]++ ErrIllegalImportBundleForm+ -> text "Illegal import form, this syntax can only be used to bundle"+ $+$ text "pattern synonyms with types in module exports."++ ErrInvalidTypeSignature lhs+ -> text "Invalid type signature:"+ <+> ppr lhs+ <+> text ":: ..."+ $$ text hint+ where+ hint | foreign_RDR `looks_like` lhs+ = "Perhaps you meant to use ForeignFunctionInterface?"+ | default_RDR `looks_like` lhs+ = "Perhaps you meant to use DefaultSignatures?"+ | pattern_RDR `looks_like` lhs+ = "Perhaps you meant to use PatternSynonyms?"+ | otherwise+ = "Should be of form <variable> :: <type>"++ -- A common error is to forget the ForeignFunctionInterface flag+ -- so check for that, and suggest. cf #3805+ -- Sadly 'foreign import' still barfs 'parse error' because+ -- 'import' is a keyword+ looks_like s (L _ (HsVar _ (L _ v))) = v == s+ looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs+ looks_like _ _ = False++ foreign_RDR = mkUnqual varName (fsLit "foreign")+ default_RDR = mkUnqual varName (fsLit "default")+ pattern_RDR = mkUnqual varName (fsLit "pattern")++ ErrUnexpectedTypeInDecl t what tc tparms equals_or_where+ -> vcat [ text "Unexpected type" <+> quotes (ppr t)+ , text "In the" <+> what+ <+> ptext (sLit "declaration for") <+> quotes tc'+ , vcat[ (text "A" <+> what+ <+> ptext (sLit "declaration should have form"))+ , nest 2+ (what+ <+> tc'+ <+> hsep (map text (takeList tparms allNameStrings))+ <+> equals_or_where) ] ]+ where+ -- Avoid printing a constraint tuple in the error message. Print+ -- a plain old tuple instead (since that's what the user probably+ -- wrote). See #14907+ tc' = ppr $ filterCTuple tc++ ErrCmmParser cmm_err -> case cmm_err of+ CmmUnknownPrimitive name -> text "unknown primitive" <+> ftext name+ CmmUnknownMacro fun -> text "unknown macro" <+> ftext fun+ CmmUnknownCConv cconv -> text "unknown calling convention:" <+> text cconv+ CmmUnrecognisedSafety safety -> text "unrecognised safety" <+> text safety+ CmmUnrecognisedHint hint -> text "unrecognised hint:" <+> text hint++ ErrExpectedHyphen+ -> text "Expected a hyphen"++ ErrSpaceInSCC+ -> text "Spaces are not allowed in SCCs"++ ErrEmptyDoubleQuotes th_on+ -> if th_on then vcat (msg ++ th_msg) else vcat msg+ where+ msg = [ text "Parser error on `''`"+ , text "Character literals may not be empty"+ ]+ th_msg = [ text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"+ , text "but the type variable or constructor is missing"+ ]++ ErrInvalidPackageName pkg+ -> vcat+ [ text "Parse error" <> colon <+> quotes (ftext pkg)+ , text "Version number or non-alphanumeric" <+>+ text "character in package name"+ ]++ ErrInvalidRuleActivationMarker+ -> text "Invalid rule activation marker"++ ErrLinearFunction+ -> text "Enable LinearTypes to allow linear functions"++ ErrMultiWayIf+ -> text "Multi-way if-expressions need MultiWayIf turned on"++ ErrExplicitForall is_unicode+ -> vcat+ [ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type"+ , text "Perhaps you intended to use RankNTypes or a similar language"+ , text "extension to enable explicit-forall syntax:" <+>+ forallSym is_unicode <+> text "<tvs>. <type>"+ ]+ where+ forallSym True = text "∀"+ forallSym False = text "forall"++ ErrIllegalQualifiedDo qdoDoc+ -> vcat+ [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block"+ , text "Perhaps you intended to use QualifiedDo"+ ]++pp_unexpected_fun_app :: Outputable a => SDoc -> a -> SDoc+pp_unexpected_fun_app e a =+ text "Unexpected " <> e <> text " in function application:"+ $$ nest 4 (ppr a)+ $$ text "You could write it with parentheses"+ $$ text "Or perhaps you meant to enable BlockArguments?"++pp_hint :: Hint -> SDoc+pp_hint = \case+ SuggestTH -> text "Perhaps you intended to use TemplateHaskell"+ SuggestDo -> text "Perhaps this statement should be within a 'do' block?"+ SuggestMissingDo -> text "Possibly caused by a missing 'do'?"+ SuggestRecursiveDo -> text "Perhaps you intended to use RecursiveDo"+ SuggestLetInDo -> text "Perhaps you need a 'let' in a 'do' block?"+ $$ text "e.g. 'let x = 5' instead of 'x = 5'"+ SuggestPatternSynonyms -> text "Perhaps you intended to use PatternSynonyms"++ SuggestInfixBindMaybeAtPat fun+ -> text "In a function binding for the"+ <+> quotes (ppr fun)+ <+> text "operator."+ $$ if opIsAt fun+ then perhaps_as_pat+ else empty++perhaps_as_pat :: SDoc+perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"+
compiler/GHC/Parser/Header.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} -----------------------------------------------------------------------------@@ -27,28 +26,35 @@ import GHC.Prelude import GHC.Platform-import GHC.Driver.Types++import GHC.Driver.Session+import GHC.Driver.Config++import GHC.Parser.Errors.Ppr+import GHC.Parser.Errors import GHC.Parser ( parseHeader ) import GHC.Parser.Lexer-import GHC.Data.FastString+ import GHC.Hs import GHC.Unit.Module import GHC.Builtin.Names-import GHC.Data.StringBuffer+ import GHC.Types.SrcLoc-import GHC.Driver.Session-import GHC.Driver.Config+import GHC.Types.SourceError+import GHC.Types.SourceText+ import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Data.Maybe-import GHC.Data.Bag ( emptyBag, listToBag, unitBag ) import GHC.Utils.Monad import GHC.Utils.Exception as Exception-import GHC.Types.Basic-import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.StringBuffer+import GHC.Data.Maybe+import GHC.Data.Bag ( Bag, emptyBag, listToBag, unitBag, isEmptyBag )+import GHC.Data.FastString+ import Control.Monad import System.IO import System.IO.Unsafe@@ -59,33 +65,32 @@ -- | Parse the imports of a source file. -- -- Throws a 'SourceError' if parsing fails.-getImports :: DynFlags+getImports :: ParserOpts -- ^ Parser options+ -> Bool -- ^ Implicit Prelude? -> StringBuffer -- ^ Parse this. -> FilePath -- ^ Filename the buffer came from. Used for -- reporting parse error locations. -> FilePath -- ^ The original source filename (used for locations -- in the function result) -> IO (Either- ErrorMessages+ (Bag Error) ([(Maybe FastString, Located ModuleName)], [(Maybe FastString, Located ModuleName)], Located ModuleName)) -- ^ The source imports and normal imports (with optional package -- names from -XPackageImports), and the module name.-getImports dflags buf filename source_filename = do+getImports popts implicit_prelude buf filename source_filename = do let loc = mkRealSrcLoc (mkFastString filename) 1 1- case unP parseHeader (initParserState (initParserOpts dflags) buf loc) of+ case unP parseHeader (initParserState popts buf loc) of PFailed pst -> -- assuming we're not logging warnings here as per below- return $ Left $ getErrorMessages pst dflags+ return $ Left $ getErrorMessages pst POk pst rdr_module -> fmap Right $ do- let _ms@(_warns, errs) = getMessages pst dflags+ let (_warns, errs) = getMessages pst -- don't log warnings: they'll be reported when we parse the file -- for real. See #2500.- ms = (emptyBag, errs)- -- logWarnings warns- if errorsFound dflags ms- then throwIO $ mkSrcErr errs+ if not (isEmptyBag errs)+ then throwIO $ mkSrcErr (fmap pprError errs) else let hsmod = unLoc rdr_module mb_mod = hsmodName hsmod@@ -100,7 +105,6 @@ . ideclName . unLoc) ord_idecls - implicit_prelude = xopt LangExt.ImplicitPrelude dflags implicit_imports = mkPrelImports (unLoc mod) main_loc implicit_prelude imps convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)@@ -160,7 +164,7 @@ (hClose) (\handle -> do opts <- fmap (getOptions' dflags)- (lazyGetToks dflags' filename handle)+ (lazyGetToks (initParserOpts dflags') filename handle) seqList opts $ return opts) where -- We don't need to get haddock doc tokens when we're just -- getting the options from pragmas, and lazily lexing them@@ -176,16 +180,16 @@ -- blockSize = 17 -- for testing :-) blockSize = 1024 -lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]-lazyGetToks dflags filename handle = do+lazyGetToks :: ParserOpts -> FilePath -> Handle -> IO [Located Token]+lazyGetToks popts filename handle = do buf <- hGetStringBufferBlock handle blockSize- let prag_state = initPragState (initParserOpts dflags) buf loc+ let prag_state = initPragState popts buf loc unsafeInterleaveIO $ lazyLexBuf handle prag_state False blockSize where loc = mkRealSrcLoc (mkFastString filename) 1 1 lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]- lazyLexBuf handle state eof size = do+ lazyLexBuf handle state eof size = case unP (lexer False return) state of POk state' t -> do -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())@@ -215,10 +219,10 @@ unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size -getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]-getToks dflags filename buf = lexAll pstate+getToks :: ParserOpts -> FilePath -> StringBuffer -> [Located Token]+getToks popts filename buf = lexAll pstate where- pstate = initPragState (initParserOpts dflags) buf loc+ pstate = initPragState popts buf loc loc = mkRealSrcLoc (mkFastString filename) 1 1 lexAll state = case unP (lexer False return) state of@@ -235,7 +239,7 @@ -> FilePath -- ^ Source filename. Used for location info. -> [Located String] -- ^ Parsed options. getOptions dflags buf filename- = getOptions' dflags (getToks dflags filename buf)+ = getOptions' dflags (getToks (initParserOpts dflags) filename buf) -- The token parser is written manually because Happy can't -- return a partial result when it encounters a lexer error.
compiler/GHC/Parser/PostProcess.hs view
@@ -1,23 +1,19 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ -- -- (c) The University of Glasgow 2002-2006 -- -- Functions over HsSyn specialised to RdrName. -{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Parser.PostProcess ( mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString,@@ -35,7 +31,6 @@ mkTyClD, mkInstD, mkRdrRecordCon, mkRdrRecordUpd, setRdrNameSpace,- filterCTuple, fromSpecTyVarBndr, fromSpecTyVarBndrs, cvBindGroup,@@ -58,7 +53,7 @@ checkPrecP, -- Int -> P Int checkContext, -- HsType -> P HsContext checkPattern, -- HsExp -> P HsPat- checkPattern_msg,+ checkPattern_hints, checkMonadComp, -- P (HsStmtContext GhcPs) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSigLhs,@@ -81,7 +76,6 @@ checkImportSpec, -- Token symbols- forallSym, starSym, -- Warnings and errors@@ -106,7 +100,6 @@ -- Type/datacon ambiguity resolution DisambTD(..), addUnpackednessP,- DataConBuilder(), dataConBuilderCon, dataConBuilderDetails, ) where@@ -121,27 +114,30 @@ import GHC.Types.Name import GHC.Unit.Module (ModuleName) import GHC.Types.Basic+import GHC.Types.Fixity+import GHC.Types.SourceText+import GHC.Parser.Types import GHC.Parser.Lexer+import GHC.Parser.Errors import GHC.Utils.Lexeme ( isLexCon )-import GHC.Core.Type ( TyThing(..), unrestrictedFunTyCon, Specificity(..) )+import GHC.Types.TyThing+import GHC.Core.Type ( unrestrictedFunTyCon, Specificity(..) ) import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey,- listTyConName, listTyConKey, eqTyCon_RDR,- tupleTyConName, cTupleTyConNameArity_maybe )+ listTyConName, listTyConKey, eqTyCon_RDR ) import GHC.Types.ForeignCall-import GHC.Builtin.Names ( allNameStrings ) import GHC.Types.SrcLoc import GHC.Types.Unique ( hasKey ) import GHC.Data.OrdList import GHC.Utils.Outputable as Outputable import GHC.Data.FastString import GHC.Data.Maybe+import GHC.Data.Bag import GHC.Utils.Misc import GHC.Parser.Annotation import Data.List import Data.Foldable-import GHC.Driver.Session ( WarningFlag(..), DynFlags )-import GHC.Utils.Error ( Messages )+import GHC.Driver.Flags ( WarningFlag(..) ) import GHC.Utils.Panic import Control.Monad@@ -264,16 +260,12 @@ check_lhs_name v@(unLoc->name) = if isUnqual name && isTcOcc (rdrNameOcc name) then return v- else addFatalError (getLoc v) $- hang (text "Expected an unqualified type constructor:") 2 (ppr v)+ else addFatalError $ Error (ErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLoc v) check_singular_lhs vs = case vs of [] -> panic "mkStandaloneKindSig: empty left-hand side" [v] -> return v- _ -> addFatalError (getLoc lhs) $- vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")- 2 (pprWithCommas ppr vs)- , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ]+ _ -> addFatalError $ Error (ErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs) mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs] -> LHsType GhcPs@@ -346,8 +338,8 @@ -- If the user wrote -- [pads| ... ] then return a QuasiQuoteD -- $(e) then return a SpliceD--- but if she wrote, say,--- f x then behave as if she'd written $(f x)+-- but if they wrote, say,+-- f x then behave as if they'd written $(f x) -- ie a SpliceD -- -- Typed splices are not allowed at the top level, thus we do not represent them@@ -383,15 +375,7 @@ let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) in- addFatalError loc_role- (text "Illegal role name" <+> quotes (ppr role) $$- suggestions nearby)-- suggestions [] = empty- suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r)- -- will this last case ever happen??- suggestions list = hang (text "Perhaps you meant one of these:")- 2 (pprWithCommas (quotes . ppr) list)+ addFatalError $ Error (ErrIllegalRoleName role nearby) [] loc_role -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to -- binders without annotations. Only accepts specified variables, and errors if@@ -411,8 +395,7 @@ where check_spec :: Specificity -> SrcSpan -> P () check_spec SpecifiedSpec _ = return ()- check_spec InferredSpec loc = addFatalError loc- (text "Inferred type variables are not allowed here")+ check_spec InferredSpec loc = addFatalError $ Error ErrInferredTypeVarNotAllowed [] loc {- ********************************************************************** @@ -463,10 +446,7 @@ -- called on top-level declarations. drop_bad_decls [] = return [] drop_bad_decls (L l (SpliceD _ d) : ds) = do- addError l $- hang (text "Declaration splices are allowed only" <+>- text "at the top level:")- 2 (ppr d)+ addError $ Error (ErrDeclSpliceNotAtTopLevel d) [] l drop_bad_decls ds drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds @@ -571,17 +551,16 @@ -- | Reinterpret a type constructor, including type operators, as a data -- constructor. -- See Note [Parsing data constructors is hard]-tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)+tyConToDataCon :: SrcSpan -> RdrName -> Either Error (Located RdrName) tyConToDataCon loc tc | isTcOcc occ || isDataOcc occ , isLexCon (occNameFS occ) = return (L loc (setRdrNameSpace tc srcDataName)) | otherwise- = Left (loc, msg)+ = Left $ Error (ErrNotADataCon tc) [] loc where occ = rdrNameOcc tc- msg = text "Not a data constructor:" <+> quotes (ppr tc) mkPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl GhcPs))@@ -619,28 +598,20 @@ fromDecl (L loc decl) = extraDeclErr loc decl extraDeclErr loc decl =- addFatalError loc $- text "pattern synonym 'where' clause must contain a single binding:" $$- ppr decl+ addFatalError $ Error (ErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc wrongNameBindingErr loc decl =- addFatalError loc $- text "pattern synonym 'where' clause must bind the pattern synonym's name"- <+> quotes (ppr patsyn_name) $$ ppr decl+ addFatalError $ Error (ErrInvalidWhereBindInPatSynDecl patsyn_name decl) [] loc wrongNumberErr loc =- addFatalError loc $- text "pattern synonym 'where' clause cannot be empty" $$- text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)+ addFatalError $ Error (ErrEmptyWhereInPatSynDecl patsyn_name) [] loc recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat =- addFatalError loc $- text "record syntax not supported for pattern synonym declarations:" $$- ppr pat+ addFatalError $ Error (ErrRecordSyntaxInPatSynDecl pat) [] loc mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]- -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs+ -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs -> ConDecl GhcPs mkConDeclH98 name mb_forall mb_cxt args@@ -659,33 +630,26 @@ -- provided), context (if provided), argument types, and result type, and -- records whether this is a prefix or record GADT constructor. See -- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.------ * If -XLinearTypes is not enabled, the function arrows in a prefix GADT--- constructor are always interpreted as linear. If -XLinearTypes is enabled,--- we faithfully record whether -> or %1 -> was used. mkGadtDecl :: [Located RdrName] -> LHsType GhcPs- -> P (ConDecl GhcPs)+ -> P (ConDecl GhcPs, [AddAnn]) mkGadtDecl names ty = do- linearEnabled <- getBit LinearTypesBit-- let (args, res_ty)+ let (args, res_ty, anns) | L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty- = (RecCon (L loc rf), res_ty)+ = (RecConGADT (L loc rf), res_ty, []) | otherwise- = let (arg_types, res_type) = splitHsFunType body_ty- arg_types' | linearEnabled = arg_types- | otherwise = map (hsLinear . hsScaledThing) arg_types- in (PrefixCon arg_types', res_type)+ = let (arg_types, res_type, anns) = splitHsFunType body_ty+ in (PrefixConGADT arg_types, res_type, anns) - pure $ ConDeclGADT { con_g_ext = noExtField+ pure ( ConDeclGADT { con_g_ext = noExtField , con_names = names , con_forall = L (getLoc ty) $ isJust mtvs , con_qvars = fromMaybe [] mtvs , con_mb_cxt = mcxt- , con_args = args+ , con_g_args = args , con_res_ty = res_ty , con_doc = Nothing }+ , anns ) where (mtvs, mcxt, body_ty) = splitLHsGadtTy ty @@ -761,12 +725,6 @@ | otherwise -- See Note [setRdrNameSpace for wired-in names] = Unqual (setOccNameSpace tcClsName (getOccName dc)) --- | Replaces constraint tuple names with corresponding boxed ones.-filterCTuple :: RdrName -> RdrName-filterCTuple (Exact n)- | Just arity <- cTupleTyConNameArity_maybe n- = Exact $ tupleTyConName BoxedTuple arity-filterCTuple rdr = rdr {- Note [setRdrNameSpace for wired-in names]@@ -781,10 +739,10 @@ really doesn't matter! -} -eitherToP :: MonadP m => Either (SrcSpan, SDoc) a -> m a+eitherToP :: MonadP m => Either Error a -> m a -- Adapts the Either monad to the P monad-eitherToP (Left (loc, doc)) = addFatalError loc doc-eitherToP (Right thing) = return thing+eitherToP (Left err) = addFatalError err+eitherToP (Right thing) = return thing checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] -> P ( LHsQTyVars GhcPs -- the synthesized type variables@@ -795,16 +753,9 @@ = do { (tvs, anns) <- fmap unzip $ mapM check tparms ; return (mkHsQTvs tvs, concat anns) } where- check (HsTypeArg _ ki@(L loc _))- = addFatalError loc $- vcat [ text "Unexpected type application" <+>- text "@" <> ppr ki- , text "In the" <+> pp_what <+>- ptext (sLit "declaration for") <+> quotes (ppr tc)]+ check (HsTypeArg _ ki@(L loc _)) = addFatalError $ Error (ErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] loc check (HsValArg ty) = chkParens [] ty- check (HsArgPar sp) = addFatalError sp $- vcat [text "Malformed" <+> pp_what- <+> text "declaration for" <+> quotes (ppr tc)]+ check (HsArgPar sp) = addFatalError $ Error (ErrMalformedDecl pp_what (unLoc tc)) [] sp -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddAnn] -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs, [AddAnn])@@ -820,23 +771,7 @@ chk (L l (HsTyVar _ _ (L ltv tv))) | isRdrTyVar tv = return (L l (UserTyVar noExtField () (L ltv tv))) chk t@(L loc _)- = addFatalError loc $- vcat [ text "Unexpected type" <+> quotes (ppr t)- , text "In the" <+> pp_what- <+> ptext (sLit "declaration for") <+> quotes tc'- , vcat[ (text "A" <+> pp_what- <+> ptext (sLit "declaration should have form"))- , nest 2- (pp_what- <+> tc'- <+> hsep (map text (takeList tparms allNameStrings))- <+> equals_or_where) ] ]-- -- Avoid printing a constraint tuple in the error message. Print- -- a plain old tuple instead (since that's what the user probably- -- wrote). See #14907- tc' = ppr $ fmap filterCTuple tc-+ = addFatalError $ Error (ErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] loc whereDots, equalsDots :: SDoc@@ -848,10 +783,7 @@ checkDatatypeContext Nothing = return () checkDatatypeContext (Just c) = do allowed <- getBit DatatypeContextsBit- unless allowed $- addError (getLoc c)- (text "Illegal datatype context (use DatatypeContexts):"- <+> pprLHsContext c)+ unless allowed $ addError $ Error (ErrIllegalDataTypeContext c) [] (getLoc c) type LRuleTyTmVar = Located RuleTyTmVar data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))@@ -878,17 +810,16 @@ -- See note [Parsing explicit foralls in Rules] in Parser.y checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P () checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)- where check (L loc (Unqual occ)) = do+ where check (L loc (Unqual occ)) =+ -- TODO: don't use string here, OccName has a Unique/FastString when ((occNameString occ ==) `any` ["forall","family","role"])- (addFatalError loc (text $ "parse error on input "- ++ occNameString occ))+ (addFatalError $ Error (ErrParseErrorOnInput occ) [] loc) check _ = panic "checkRuleTyVarBndrNames" checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a) checkRecordSyntax lr@(L loc r) = do allowed <- getBit TraditionalRecordSyntaxBit- unless allowed $ addError loc $- text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r+ unless allowed $ addError $ Error (ErrIllegalTraditionalRecordSyntax (ppr r)) [] loc return lr -- | Check if the gadt_constrlist is empty. Only raise parse error for@@ -897,11 +828,7 @@ -> P (Located ([AddAnn], [LConDecl GhcPs])) checkEmptyGADTs gadts@(L span (_, [])) -- Empty GADT declaration. = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax- unless gadtSyntax $ addError span $ vcat- [ text "Illegal keyword 'where' in data declaration"- , text "Perhaps you intended to use GADTs or a similar language"- , text "extension to enable syntax: data T where"- ]+ unless gadtSyntax $ addError $ Error ErrIllegalWhereInDataDecl [] span return gadts checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. @@ -923,7 +850,7 @@ -- workaround to define '*' despite StarIsType go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix- = do { warnStarBndr l+ = do { addWarning Opt_WarnStarBinder (WarnStarBinder l) ; let name = mkOccName tcClsName (starSym isUni) ; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } @@ -942,8 +869,7 @@ | otherwise = getName (tupleTyCon Boxed arity) -- See Note [Unit tuples] in GHC.Hs.Type (TODO: is this still relevant?) go l _ _ _ _- = addFatalError l (text "Malformed head of type or class declaration:"- <+> ppr ty)+ = addFatalError $ Error (ErrMalformedTyOrClDecl ty) [] l -- | Yield a parse error if we have a function applied directly to a do block -- etc. and BlockArguments is not enabled.@@ -952,36 +878,30 @@ (checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd) where checkExpr :: LHsExpr GhcPs -> PV ()- checkExpr expr = do- case unLoc expr of- HsDo _ (DoExpr m) _ -> check (prependQualified m (text "do block")) expr- HsDo _ (MDoExpr m) _ -> check (prependQualified m (text "mdo block")) expr- HsLam {} -> check (text "lambda expression") expr- HsCase {} -> check (text "case expression") expr- HsLamCase {} -> check (text "lambda-case expression") expr- HsLet {} -> check (text "let expression") expr- HsIf {} -> check (text "if expression") expr- HsProc {} -> check (text "proc expression") expr- _ -> return ()+ checkExpr expr = case unLoc expr of+ HsDo _ (DoExpr m) _ -> check (ErrDoInFunAppExpr m) expr+ HsDo _ (MDoExpr m) _ -> check (ErrMDoInFunAppExpr m) expr+ HsLam {} -> check ErrLambdaInFunAppExpr expr+ HsCase {} -> check ErrCaseInFunAppExpr expr+ HsLamCase {} -> check ErrLambdaCaseInFunAppExpr expr+ HsLet {} -> check ErrLetInFunAppExpr expr+ HsIf {} -> check ErrIfInFunAppExpr expr+ HsProc {} -> check ErrProcInFunAppExpr expr+ _ -> return () checkCmd :: LHsCmd GhcPs -> PV () checkCmd cmd = case unLoc cmd of- HsCmdLam {} -> check (text "lambda command") cmd- HsCmdCase {} -> check (text "case command") cmd- HsCmdIf {} -> check (text "if command") cmd- HsCmdLet {} -> check (text "let command") cmd- HsCmdDo {} -> check (text "do command") cmd- _ -> return ()+ HsCmdLam {} -> check ErrLambdaCmdInFunAppCmd cmd+ HsCmdCase {} -> check ErrCaseCmdInFunAppCmd cmd+ HsCmdIf {} -> check ErrIfCmdInFunAppCmd cmd+ HsCmdLet {} -> check ErrLetCmdInFunAppCmd cmd+ HsCmdDo {} -> check ErrDoCmdInFunAppCmd cmd+ _ -> return () - check :: Outputable a => SDoc -> Located a -> PV ()- check element a = do+ check err a = do blockArguments <- getBit BlockArgumentsBit unless blockArguments $- addError (getLoc a) $- text "Unexpected " <> element <> text " in function application:"- $$ nest 4 (ppr a)- $$ text "You could write it with parentheses"- $$ text "Or perhaps you meant to enable BlockArguments?"+ addError $ Error (err a) [] (getLoc a) -- | Validate the context constraints and break up a context into a list -- of predicates.@@ -1044,8 +964,8 @@ checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = runPV . checkLPat -checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)-checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat)+checkPattern_hints :: [Hint] -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)+checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat) checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs) checkLPat e@(L l _) = checkPat l e []@@ -1059,7 +979,7 @@ , pat_args = PrefixCon args } | not (null args) && patIsRec c =- localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $+ add_hint SuggestRecursiveDo $ patFail l (ppr e) checkPat loc (L _ (PatBuilderApp f e)) args = do p <- checkLPat e@@ -1092,9 +1012,7 @@ -- Improve error messages for the @-operator when the user meant an @-pattern PatBuilderOpApp _ op _ | opIsAt (unLoc op) -> do- addError (getLoc op) $- text "Found a binding for the" <+> quotes (ppr op) <+> text "operator in a pattern position." $$- perhaps_as_pat+ addError $ Error ErrAtInPatPos [] (getLoc op) return (WildPat noExtField) PatBuilderOpApp l (L cl c) r@@ -1126,14 +1044,11 @@ return (L l (fld { hsRecFieldArg = p })) patFail :: SrcSpan -> SDoc -> PV a-patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e+patFail loc e = addFatalError $ Error (ErrParseErrorInPat e) [] loc patIsRec :: RdrName -> Bool patIsRec e = e == mkUnqual varName (fsLit "rec") -opIsAt :: RdrName -> Bool-opIsAt e = e == mkUnqual varName (fsLit "@")- --------------------------------------------------------------------------- -- Check Equation Syntax @@ -1166,7 +1081,7 @@ -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn],HsBind GhcPs) checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)- = do ps <- runPV_msg param_hint (mapM checkLPat pats)+ = do ps <- runPV_hints param_hints (mapM checkLPat pats) let match_span = combineSrcSpans lhs_loc rhs_span -- Add back the annotations stripped from any HsPar values in the lhs -- mapM_ (\a -> a match_span) ann@@ -1181,14 +1096,9 @@ -- The span of the match covers the entire equation. -- That isn't quite right, but it'll do for now. where- param_hint- | Infix <- is_infix- = text "In a function binding for the" <+> quotes (ppr fun) <+> text "operator." $$- if opIsAt (unLoc fun) then perhaps_as_pat else empty- | otherwise = empty--perhaps_as_pat :: SDoc-perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"+ param_hints+ | Infix <- is_infix = [SuggestInfixBindMaybeAtPat (unLoc fun)]+ | otherwise = [] makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs@@ -1226,49 +1136,23 @@ = return lrdr checkValSigLhs lhs@(L l _)- = addFatalError l ((text "Invalid type signature:" <+>- ppr lhs <+> text ":: ...")- $$ text hint)- where- hint | foreign_RDR `looks_like` lhs- = "Perhaps you meant to use ForeignFunctionInterface?"- | default_RDR `looks_like` lhs- = "Perhaps you meant to use DefaultSignatures?"- | pattern_RDR `looks_like` lhs- = "Perhaps you meant to use PatternSynonyms?"- | otherwise- = "Should be of form <variable> :: <type>"-- -- A common error is to forget the ForeignFunctionInterface flag- -- so check for that, and suggest. cf #3805- -- Sadly 'foreign import' still barfs 'parse error' because- -- 'import' is a keyword- looks_like s (L _ (HsVar _ (L _ v))) = v == s- looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs- looks_like _ _ = False-- foreign_RDR = mkUnqual varName (fsLit "foreign")- default_RDR = mkUnqual varName (fsLit "default")- pattern_RDR = mkUnqual varName (fsLit "pattern")+ = addFatalError $ Error (ErrInvalidTypeSignature lhs) [] l checkDoAndIfThenElse :: (Outputable a, Outputable b, Outputable c)- => Located a -> Bool -> b -> Bool -> Located c -> PV ()-checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr- | semiThen || semiElse- = do doAndIfThenElse <- getBit DoAndIfThenElseBit- unless doAndIfThenElse $ do- addError (combineLocs guardExpr elseExpr)- (text "Unexpected semi-colons in conditional:"- $$ nest 4 expr- $$ text "Perhaps you meant to use DoAndIfThenElse?")- | otherwise = return ()- where pprOptSemi True = semi- pprOptSemi False = empty- expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+>- text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+>- text "else" <+> ppr elseExpr+ => (a -> Bool -> b -> Bool -> c -> ErrorDesc)+ -> Located a -> Bool -> Located b -> Bool -> Located c -> PV ()+checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr+ | semiThen || semiElse = do+ doAndIfThenElse <- getBit DoAndIfThenElseBit+ let e = err (unLoc guardExpr)+ semiThen (unLoc thenExpr)+ semiElse (unLoc elseExpr)+ loc = combineLocs guardExpr elseExpr + unless doAndIfThenElse $ addError (Error e [] loc)+ | otherwise = return ()+ isFunLhs :: Located (PatBuilder GhcPs) -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn])) -- A variable binding is parsed as a FunBind.@@ -1373,8 +1257,7 @@ instance DisambInfixOp RdrName where mkHsConOpPV (L l v) = return $ L l v mkHsVarOpPV (L l v) = return $ L l v- mkHsInfixHolePV l =- addFatalError l $ text "Invalid infix hole, expected an infix operator"+ mkHsInfixHolePV l = addFatalError $ Error ErrInvalidInfixHole [] l -- | Disambiguate constructs that may appear when we do not know ahead of time whether we are -- parsing an expression, a command, or a pattern.@@ -1530,13 +1413,10 @@ return $ L l (HsCmdApp noExtField c e) mkHsAppTypePV l c t = cmdFail l (ppr c <+> text "@" <> ppr t) mkHsIfPV l c semi1 a semi2 b = do- checkDoAndIfThenElse c semi1 a semi2 b+ checkDoAndIfThenElse ErrSemiColonsInCondCmd c semi1 a semi2 b return $ L l (mkHsCmdIf c a b) mkHsDoPV l Nothing stmts = return $ L l (HsCmdDo noExtField stmts)- mkHsDoPV l (Just m) _ =- cmdFail l $- text "Found a qualified" <+> ppr m <> text ".do block in a command, but"- $$ text "qualified 'do' is not supported in commands."+ mkHsDoPV l (Just m) _ = addFatalError $ Error (ErrQualifiedDoInCmd m) [] l mkHsParPV l c = return $ L l (HsCmdPar noExtField c) mkHsVarPV (L l v) = cmdFail l (ppr v) mkHsLitPV (L l a) = cmdFail l (ppr a)@@ -1565,22 +1445,19 @@ rejectPragmaPV _ = return () cmdFail :: SrcSpan -> SDoc -> PV a-cmdFail loc e = addFatalError loc $- hang (text "Parse error in command:") 2 (ppr e)+cmdFail loc e = addFatalError $ Error (ErrParseErrorInCmd e) [] loc instance DisambECP (HsExpr GhcPs) where type Body (HsExpr GhcPs) = HsExpr ecpFromCmd' (L l c) = do- addError l $ vcat- [ text "Arrow command found where an expression was expected:",- nest 2 (ppr c) ]+ addError $ Error (ErrArrowCmdInExpr c) [] l return (L l hsHoleExpr) ecpFromExp' = return mkHsLamPV l mg = return $ L l (HsLam noExtField mg) mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c) type InfixOp (HsExpr GhcPs) = HsExpr GhcPs superInfixOp m = m- mkHsOpAppPV l e1 op e2 = do+ mkHsOpAppPV l e1 op e2 = return $ L l $ OpApp noExtField e1 op e2 mkHsCasePV l e mg = return $ L l (HsCase noExtField e mg) mkHsLamCasePV l mg = return $ L l (HsLamCase noExtField mg)@@ -1594,7 +1471,7 @@ checkExpBlockArguments e return $ L l (HsAppType noExtField e (mkHsWildCardBndrs t)) mkHsIfPV l c semi1 a semi2 b = do- checkDoAndIfThenElse c semi1 a semi2 b+ checkDoAndIfThenElse ErrSemiColonsInCondExpr c semi1 a semi2 b return $ L l (mkHsIf c a b) mkHsDoPV l mod stmts = return $ L l (HsDo noExtField (DoExpr mod) stmts) mkHsParPV l e = return $ L l (HsPar noExtField e)@@ -1610,76 +1487,42 @@ checkRecordSyntax (L l r) mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr) mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e)- mkHsViewPatPV l a b = patSynErr "View pattern" l (ppr a <+> text "->" <+> ppr b) empty- mkHsAsPatPV l v e =- patSynErr "@-pattern" l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) $- text "Type application syntax requires a space before '@'"- mkHsLazyPatPV l e = patSynErr "Lazy pattern" l (text "~" <> ppr e) $- text "Did you mean to add a space after the '~'?"- mkHsBangPatPV l e = patSynErr "Bang pattern" l (text "!" <> ppr e) $- text "Did you mean to add a space after the '!'?"+ mkHsViewPatPV l a b = addError (Error (ErrViewPatInExpr a b) [] l)+ >> return (L l hsHoleExpr)+ mkHsAsPatPV l v e = addError (Error (ErrTypeAppWithoutSpace (unLoc v) e) [] l)+ >> return (L l hsHoleExpr)+ mkHsLazyPatPV l e = addError (Error (ErrLazyPatWithoutSpace e) [] l)+ >> return (L l hsHoleExpr)+ mkHsBangPatPV l e = addError (Error (ErrBangPatWithoutSpace e) [] l)+ >> return (L l hsHoleExpr) mkSumOrTuplePV = mkSumOrTupleExpr rejectPragmaPV (L _ (OpApp _ _ _ e)) = -- assuming left-associative parsing of operators rejectPragmaPV e- rejectPragmaPV (L l (HsPragE _ prag _)) =- addError l $- hang (text "A pragma is not allowed in this position:") 2 (ppr prag)- rejectPragmaPV _ = return ()--patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)-patSynErr item l e explanation =- do { addError l $- sep [text item <+> text "in expression context:",- nest 4 (ppr e)] $$- explanation- ; return (L l hsHoleExpr) }+ rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ Error (ErrUnallowedPragma prag) [] l+ rejectPragmaPV _ = return () hsHoleExpr :: HsExpr GhcPs hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_") --- | See Note [Ambiguous syntactic categories] and Note [PatBuilder]-data PatBuilder p- = PatBuilderPat (Pat p)- | PatBuilderPar (Located (PatBuilder p))- | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))- | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))- | PatBuilderVar (Located RdrName)- | PatBuilderOverLit (HsOverLit GhcPs)--instance Outputable (PatBuilder GhcPs) where- ppr (PatBuilderPat p) = ppr p- ppr (PatBuilderPar (L _ p)) = parens (ppr p)- ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2- ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2- ppr (PatBuilderVar v) = ppr v- ppr (PatBuilderOverLit l) = ppr l- instance DisambECP (PatBuilder GhcPs) where type Body (PatBuilder GhcPs) = PatBuilder- ecpFromCmd' (L l c) =- addFatalError l $- text "Command syntax in pattern:" <+> ppr c- ecpFromExp' (L l e) =- addFatalError l $- text "Expression syntax in pattern:" <+> ppr e- mkHsLamPV l _ = addFatalError l $- text "Lambda-syntax in pattern." $$- text "Pattern matching on functions is not possible."- mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern"+ ecpFromCmd' (L l c) = addFatalError $ Error (ErrArrowCmdInPat c) [] l+ ecpFromExp' (L l e) = addFatalError $ Error (ErrArrowExprInPat e) [] l+ mkHsLamPV l _ = addFatalError $ Error ErrLambdaInPat [] l+ mkHsLetPV l _ _ = addFatalError $ Error ErrLetInPat [] l type InfixOp (PatBuilder GhcPs) = RdrName superInfixOp m = m mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2- mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern"- mkHsLamCasePV l _ = addFatalError l $ text "(\\case ...)-syntax in pattern"+ mkHsCasePV l _ _ = addFatalError $ Error ErrCaseInPat [] l+ mkHsLamCasePV l _ = addFatalError $ Error ErrLambdaCaseInPat [] l type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs superFunArg m = m- mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)- mkHsAppTypePV l _ _ = addFatalError l $- text "Type applications in patterns are not yet supported"- mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern"- mkHsDoPV l _ _ = addFatalError l $ text "do-notation in pattern"- mkHsParPV l p = return $ L l (PatBuilderPar p)+ mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)+ mkHsAppTypePV l _ _ = addFatalError $ Error ErrTypeAppInPat [] l+ mkHsIfPV l _ _ _ _ _ = addFatalError $ Error ErrIfTheElseInPat [] l+ mkHsDoPV l _ _ = addFatalError $ Error ErrDoNotationInPat [] l+ mkHsParPV l p = return $ L l (PatBuilderPar p) mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v) mkHsLitPV lit@(L l a) = do checkUnboxedStringLitPat lit@@ -1723,7 +1566,7 @@ checkUnboxedStringLitPat (L loc lit) = case lit of HsStringPrim _ _ -- Trac #13260- -> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit)+ -> addFatalError $ Error (ErrIllegalUnboxedStringInPat lit) [] loc _ -> return () mkPatRec ::@@ -1739,7 +1582,7 @@ , pat_args = RecCon (HsRecFields fs dd) } mkPatRec p _ =- addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p+ addFatalError $ Error (ErrInvalidRecordCon (unLoc p)) [] (getLoc p) -- | Disambiguate constructs that may appear when we do not know -- ahead of time whether we are parsing a type or a newtype/data constructor.@@ -1770,39 +1613,11 @@ mkHsOpTyPV t1 op t2 = return (mkLHsOpTy t1 op t2) mkUnpackednessPV = addUnpackednessP --- | An accumulator to build a prefix data constructor,--- e.g. when parsing @MkT A B C@, the accumulator will evolve as follows:------ @--- 1. PrefixDataConBuilder [] MkT--- 2. PrefixDataConBuilder [A] MkT--- 3. PrefixDataConBuilder [A, B] MkT--- 4. PrefixDataConBuilder [A, B, C] MkT--- @------ There are two reasons we have a separate builder type instead of using--- @HsConDeclDetails GhcPs@ directly:------ 1. It's faster, because 'OrdList' gives us constant-time snoc.--- 2. Having a separate type helps ensure that we don't forget to finalize a--- 'RecTy' into a 'RecCon' (we do that in 'dataConBuilderDetails').------ See Note [PatBuilder] for another builder type used in the parser.--- Here the technique is similar, but the motivation is different.-data DataConBuilder- = PrefixDataConBuilder- (OrdList (LHsType GhcPs)) -- Data constructor fields- (Located RdrName) -- Data constructor name- | InfixDataConBuilder- (LHsType GhcPs) -- LHS field- (Located RdrName) -- Data constructor name- (LHsType GhcPs) -- RHS field- dataConBuilderCon :: DataConBuilder -> Located RdrName dataConBuilderCon (PrefixDataConBuilder _ dc) = dc dataConBuilderCon (InfixDataConBuilder _ dc _) = dc -dataConBuilderDetails :: DataConBuilder -> HsConDeclDetails GhcPs+dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs -- Detect when the record syntax is used: -- data T = MkT { ... }@@ -1818,12 +1633,6 @@ dataConBuilderDetails (InfixDataConBuilder lhs _ rhs) = InfixCon (hsLinear lhs) (hsLinear rhs) -instance Outputable DataConBuilder where- ppr (PrefixDataConBuilder flds data_con) =- hang (ppr data_con) 2 (sep (map ppr (toList flds)))- ppr (InfixDataConBuilder lhs data_con rhs) =- ppr lhs <+> ppr data_con <+> ppr rhs- instance DisambTD DataConBuilder where mkHsAppTyHeadPV = tyToDataConBuilder @@ -1837,9 +1646,7 @@ panic "mkHsAppTyPV: InfixDataConBuilder" mkHsAppKindTyPV lhs l_at ki =- addFatalError l_at $- hang (text "Unexpected kind application in a data/newtype declaration:") 2- (ppr lhs <+> text "@" <> ppr ki)+ addFatalError $ Error (ErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at mkHsOpTyPV lhs (L l_tc tc) rhs = do check_no_ops (unLoc rhs) -- check the RHS because parsing type operators is right-associative@@ -1849,9 +1656,7 @@ l = combineLocs lhs rhs check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t) check_no_ops (HsOpTy{}) =- addError l $- hang (text "Cannot parse an infix data constructor in a data/newtype declaration:")- 2 (ppr lhs <+> ppr tc <+> ppr rhs)+ addError $ Error (ErrInvalidInfixDataCon (unLoc lhs) tc (unLoc rhs)) [] l check_no_ops _ = return () mkUnpackednessPV unpk constr_stuff@@ -1862,8 +1667,7 @@ let l = combineLocs unpk constr_stuff return $ L l (InfixDataConBuilder lhs' data_con rhs) | otherwise =- do addError (getLoc unpk) $- text "{-# UNPACK #-} cannot be applied to a data constructor."+ do addError $ Error ErrUnpackDataCon [] (getLoc unpk) return constr_stuff tyToDataConBuilder :: LHsType GhcPs -> PV (Located DataConBuilder)@@ -1874,9 +1678,7 @@ let data_con = L l (getRdrName (tupleDataCon Boxed (length ts))) return $ L l (PrefixDataConBuilder (toOL ts) data_con) tyToDataConBuilder t =- addFatalError (getLoc t) $- hang (text "Cannot parse data constructor in a data/newtype declaration:")- 2 (ppr t)+ addFatalError $ Error (ErrInvalidDataCon (unLoc t)) [] (getLoc t) {- Note [Ambiguous syntactic categories] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2325,7 +2127,7 @@ checkPrecP (L l (_,i)) (L _ ol) | 0 <= i, i <= maxPrecedence = pure () | all specialOp ol = pure ()- | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i))+ | otherwise = addFatalError $ Error (ErrPrecedenceOutOfRange i) [] l where -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs specialOp op = unLoc op `elem` [ eqTyCon_RDR@@ -2341,7 +2143,7 @@ | isRdrDataCon c = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) mkRecConstrOrUpdate exp _ (fs,dd)- | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update")+ | Just dd_loc <- dd = addFatalError $ Error ErrDotsInRecordUpdate [] dd_loc | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs@@ -2368,7 +2170,7 @@ -- The (Maybe Activation) is because the user can omit -- the activation spec (and usually does) mkInlinePragma src (inl, match_info) mb_act- = InlinePragma { inl_src = src -- Note [Pragma source text] in GHC.Types.Basic+ = InlinePragma { inl_src = src -- Note [Pragma source text] in GHC.Types.SourceText , inl_inline = inl , inl_sat = Nothing , inl_act = act@@ -2405,7 +2207,7 @@ mkCImport = do let e = unpackFS entity case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of- Nothing -> addFatalError loc (text "Malformed entity string")+ Nothing -> addFatalError $ Error ErrMalformedEntityString [] loc Just importSpec -> returnSpec importSpec -- currently, all the other import conventions only support a symbol name in@@ -2543,20 +2345,12 @@ in (\newName -> IEThingWith noExtField (L l newName) pos ies []) <$> nameT- else addFatalError l- (text "Illegal export form (use PatternSynonyms to enable)")+ else addFatalError $ Error ErrIllegalPatSynExport [] l where name = ieNameVal specname nameT = if isVarNameSpace (rdrNameSpace name)- then addFatalError l- (text "Expecting a type constructor but found a variable,"- <+> quotes (ppr name) <> text "."- $$ if isSymOcc $ rdrNameOcc name- then text "If" <+> quotes (ppr name)- <+> text "is a type constructor"- <+> text "then enable ExplicitNamespaces and use the 'type' keyword."- else empty)+ then addFatalError $ Error (ErrVarForTyCon name) [] l else return $ ieNameFromSpec specname ieNameVal (ImpExpQcName ln) = unLoc ln@@ -2573,8 +2367,7 @@ -> P (Located RdrName) mkTypeImpExp name = do allowed <- getBit ExplicitNamespacesBit- unless allowed $ addError (getLoc name) $- text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"+ unless allowed $ addError $ Error ErrIllegalExplicitNamespace [] (getLoc name) return (fmap (`setRdrNameSpace` tcClsName) name) checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])@@ -2584,9 +2377,7 @@ (l:_) -> importSpecError l where importSpecError l =- addFatalError l- (text "Illegal import form, this syntax can only be used to bundle"- $+$ text "pattern synonyms with types in module exports.")+ addFatalError $ Error ErrIllegalImportBundleForm [] l -- In the correct order mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)@@ -2607,53 +2398,21 @@ warnPrepositiveQualifiedModule :: SrcSpan -> P () warnPrepositiveQualifiedModule span =- addWarning Opt_WarnPrepositiveQualifiedModule span msg- where- msg = text "Found" <+> quotes (text "qualified")- <+> text "in prepositive position"- $$ text "Suggested fix: place " <+> quotes (text "qualified")- <+> text "after the module name instead."- $$ text "To allow this, enable language extension 'ImportQualifiedPost'"+ addWarning Opt_WarnPrepositiveQualifiedModule (WarnImportPreQualified span) failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()-failOpNotEnabledImportQualifiedPost loc = addError loc msg- where- msg = text "Found" <+> quotes (text "qualified")- <+> text "in postpositive position. "- $$ text "To allow this, enable language extension 'ImportQualifiedPost'"+failOpNotEnabledImportQualifiedPost loc = addError $ Error ErrImportPostQualified [] loc failOpImportQualifiedTwice :: SrcSpan -> P ()-failOpImportQualifiedTwice loc = addError loc msg- where- msg = text "Multiple occurrences of 'qualified'"+failOpImportQualifiedTwice loc = addError $ Error ErrImportQualifiedTwice [] loc warnStarIsType :: SrcSpan -> P ()-warnStarIsType span = addWarning Opt_WarnStarIsType span msg- where- msg = text "Using" <+> quotes (text "*")- <+> text "(or its Unicode variant) to mean"- <+> quotes (text "Data.Kind.Type")- $$ text "relies on the StarIsType extension, which will become"- $$ text "deprecated in the future."- $$ text "Suggested fix: use" <+> quotes (text "Type")- <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."--warnStarBndr :: SrcSpan -> P ()-warnStarBndr span = addWarning Opt_WarnStarBinder span msg- where- msg = text "Found binding occurrence of" <+> quotes (text "*")- <+> text "yet StarIsType is enabled."- $$ text "NB. To use (or export) this operator in"- <+> text "modules with StarIsType,"- $$ text " including the definition module, you must qualify it."+warnStarIsType span = addWarning Opt_WarnStarIsType (WarnStarIsType span) failOpFewArgs :: MonadP m => Located RdrName -> m a failOpFewArgs (L loc op) = do { star_is_type <- getBit StarIsTypeBit- ; let msg = too_few $$ starInfo star_is_type op- ; addFatalError loc msg }- where- too_few = text "Operator applied to too few arguments:" <+> ppr op+ ; addFatalError $ Error (ErrOpFewArgs (StarIsType star_is_type) op) [] loc } ----------------------------------------------------------------------------- -- Misc utils@@ -2661,12 +2420,13 @@ data PV_Context = PV_Context { pv_options :: ParserOpts- , pv_hint :: SDoc -- See Note [Parser-Validator Hint]+ , pv_hints :: [Hint] -- See Note [Parser-Validator Hint] } data PV_Accum = PV_Accum- { pv_messages :: DynFlags -> Messages+ { pv_warnings :: Bag Warning+ , pv_errors :: Bag Error , pv_annotations :: [(ApiAnnKey,[RealSrcSpan])] , pv_comment_q :: [RealLocated AnnotationComment] , pv_annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])]@@ -2709,22 +2469,24 @@ PV_Failed acc' -> PV_Failed acc' runPV :: PV a -> P a-runPV = runPV_msg empty+runPV = runPV_hints [] -runPV_msg :: SDoc -> PV a -> P a-runPV_msg msg m =+runPV_hints :: [Hint] -> PV a -> P a+runPV_hints hints m = P $ \s -> let pv_ctx = PV_Context { pv_options = options s- , pv_hint = msg }+ , pv_hints = hints } pv_acc = PV_Accum- { pv_messages = messages s+ { pv_warnings = warnings s+ , pv_errors = errors s , pv_annotations = annotations s , pv_comment_q = comment_q s , pv_annotations_comments = annotations_comments s } mkPState acc' =- s { messages = pv_messages acc'+ s { warnings = pv_warnings acc'+ , errors = pv_errors acc' , annotations = pv_annotations acc' , comment_q = pv_comment_q acc' , annotations_comments = pv_annotations_comments acc' }@@ -2733,21 +2495,24 @@ PV_Ok acc' a -> POk (mkPState acc') a PV_Failed acc' -> PFailed (mkPState acc') -localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a-localPV_msg f m =- let modifyHint ctx = ctx{pv_hint = f (pv_hint ctx)} in+add_hint :: Hint -> PV a -> PV a+add_hint hint m =+ let modifyHint ctx = ctx{pv_hints = pv_hints ctx ++ [hint]} in PV (\ctx acc -> unPV m (modifyHint ctx) acc) instance MonadP PV where- addError srcspan msg =- PV $ \ctx acc@PV_Accum{pv_messages=m} ->- let msg' = msg $$ pv_hint ctx in- PV_Ok acc{pv_messages=appendError srcspan msg' m} ()- addWarning option srcspan warning =- PV $ \PV_Context{pv_options=o} acc@PV_Accum{pv_messages=m} ->- PV_Ok acc{pv_messages=appendWarning o option srcspan warning m} ()- addFatalError srcspan msg =- addError srcspan msg >> PV (const PV_Failed)+ addError err@(Error e hints loc) =+ PV $ \ctx acc ->+ let err' | null (pv_hints ctx) = err+ | otherwise = Error e (hints ++ pv_hints ctx) loc+ in PV_Ok acc{pv_errors = err' `consBag` pv_errors acc} ()+ addWarning option w =+ PV $ \ctx acc ->+ if warnopt option (pv_options ctx)+ then PV_Ok acc{pv_warnings= w `consBag` pv_warnings acc} ()+ else PV_Ok acc ()+ addFatalError err =+ addError err >> PV (const PV_Failed) getBit ext = PV $ \ctx acc -> let b = ext `xtest` pExtsBitmap (pv_options ctx) in@@ -2802,7 +2567,7 @@ Possibly caused by a missing 'do'? The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed-as the 'pv_hint' field 'PV_Context'. When validating in a context other than+as the 'pv_hints' field 'PV_Context'. When validating in a context other than 'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has no effect on the error messages. @@ -2813,27 +2578,7 @@ hintBangPat span e = do bang_on <- getBit BangPatBit unless bang_on $- addError span- (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)--data SumOrTuple b- = Sum ConTag Arity (Located b)- | Tuple [Located (Maybe (Located b))]--pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc-pprSumOrTuple boxity = \case- Sum alt arity e ->- parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt)- <+> parClose- Tuple xs ->- parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs)- <> parClose- where- ppr_bars n = hsep (replicate n (Outputable.char '|'))- (parOpen, parClose) =- case boxity of- Boxed -> (text "(", text ")")- Unboxed -> (text "(#", text "#)")+ addError $ Error (ErrIllegalBangPattern e) [] span mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs) @@ -2848,8 +2593,7 @@ mkSumOrTupleExpr l Unboxed (Sum alt arity e) = return $ L l (ExplicitSum noExtField alt arity e) mkSumOrTupleExpr l Boxed a@Sum{} =- addFatalError l (hang (text "Boxed sums not supported:") 2- (pprSumOrTuple Boxed a))+ addFatalError $ Error (ErrUnsupportedBoxedSumExpr a) [] l mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs)) @@ -2860,7 +2604,7 @@ where toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs) toTupPat (L l p) = case p of- Nothing -> addFatalError l (text "Tuple section in pattern context")+ Nothing -> addFatalError $ Error ErrTupleSectionInPat [] l Just p' -> checkLPat p' -- Sum@@ -2868,17 +2612,17 @@ p' <- checkLPat p return $ L l (PatBuilderPat (SumPat noExtField p' alt arity)) mkSumOrTuplePat l Boxed a@Sum{} =- addFatalError l (hang (text "Boxed sums not supported:") 2- (pprSumOrTuple Boxed a))+ addFatalError $ Error (ErrUnsupportedBoxedSumPat a) [] l mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs mkLHsOpTy x op y = let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y in L loc (mkHsOpTy x op y) -mkMultTy :: LHsType GhcPs -> HsArrow GhcPs-mkMultTy (L _ (HsTyLit _ (HsNumTy _ 1))) = HsLinearArrow-mkMultTy t = HsExplicitMult t+mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> (HsArrow GhcPs, AddAnn)+mkMultTy u tok t@(L _ (HsTyLit _ (HsNumTy _ 1)))+ = (HsLinearArrow u, AddAnn AnnPercentOne (combineLocs tok t))+mkMultTy u tok t = (HsExplicitMult u t, AddAnn AnnPercent (getLoc tok)) ----------------------------------------------------------------------------- -- Token symbols@@ -2886,7 +2630,3 @@ starSym :: Bool -> String starSym True = "★" starSym False = "*"--forallSym :: Bool -> String-forallSym True = "∀"-forallSym False = "forall"
compiler/GHC/Parser/PostProcess/Haddock.hs view
@@ -1,14 +1,13 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {- | This module implements 'addHaddockToModule', which inserts Haddock comments accumulated during parsing into the AST (#17544).@@ -55,8 +54,7 @@ import GHC.Hs import GHC.Types.SrcLoc-import GHC.Driver.Session ( WarningFlag(..) )-import GHC.Utils.Outputable hiding ( (<>) )+import GHC.Driver.Flags ( WarningFlag(..) ) import GHC.Utils.Panic import GHC.Data.Bag @@ -73,6 +71,7 @@ import qualified Data.Monoid import GHC.Parser.Lexer+import GHC.Parser.Errors import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>)) {- Note [Adding Haddock comments to the syntax tree]@@ -193,12 +192,9 @@ reportHdkWarning :: HdkWarn -> P () reportHdkWarning (HdkWarnInvalidComment (L l _)) =- addWarning Opt_WarnInvalidHaddock (mkSrcSpanPs l) $- text "A Haddock comment cannot appear in this position and will be ignored."+ addWarning Opt_WarnInvalidHaddock $ WarnHaddockInvalidPos (mkSrcSpanPs l) reportHdkWarning (HdkWarnExtraComment (L l _)) =- addWarning Opt_WarnInvalidHaddock l $- text "Multiple Haddock comments for a single entity are not allowed." $$- text "The extraneous comment will be ignored."+ addWarning Opt_WarnInvalidHaddock $ WarnHaddockIgnoreMulti l collectHdkWarnings :: HdkSt -> [HdkWarn] collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } =@@ -694,22 +690,21 @@ addHaddock (L l_con_decl con_decl) = extendHdkA l_con_decl $ case con_decl of- ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_args, con_res_ty } -> do+ ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, 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 (getLoc (head con_names))- con_args' <-- case con_args of- PrefixCon ts -> PrefixCon <$> addHaddock ts- RecCon (L l_rec flds) -> do+ con_g_args' <-+ case con_g_args of+ PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts+ RecConGADT (L l_rec flds) -> do -- discardHasInnerDocs is ok because we don't need this info for GADTs. flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds- pure $ RecCon (L l_rec flds')- InfixCon _ _ -> panic "ConDeclGADT InfixCon"+ pure $ RecConGADT (L l_rec flds') con_res_ty' <- addHaddock con_res_ty pure $ L l_con_decl $ ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_doc = con_doc',- con_args = con_args',+ con_g_args = con_g_args', con_res_ty = con_res_ty' } ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } -> addConTrailingDoc (srcSpanEnd l_con_decl) $@@ -984,10 +979,10 @@ pure $ L l (HsQualTy noExtField lhs rhs') -- arg -> res- HsFunTy _ mult lhs rhs -> do+ HsFunTy u mult lhs rhs -> do lhs' <- addHaddock lhs rhs' <- addHaddock rhs- pure $ L l (HsFunTy noExtField mult lhs' rhs')+ pure $ L l (HsFunTy u mult lhs' rhs') -- other types _ -> liftHdkA $ do
+ compiler/GHC/Parser/Types.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}++module GHC.Parser.Types+ ( SumOrTuple(..)+ , pprSumOrTuple+ , PatBuilder(..)+ , DataConBuilder(..)+ )+where++import GHC.Prelude+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Types.Name.Reader+import GHC.Hs.Extension+import GHC.Hs.Lit+import GHC.Hs.Pat+import GHC.Hs.Type+import GHC.Utils.Outputable as Outputable+import GHC.Data.OrdList++import Data.Foldable++data SumOrTuple b+ = Sum ConTag Arity (Located b)+ | Tuple [Located (Maybe (Located b))]++pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc+pprSumOrTuple boxity = \case+ Sum alt arity e ->+ parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt)+ <+> parClose+ Tuple xs ->+ parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs)+ <> parClose+ where+ ppr_bars n = hsep (replicate n (Outputable.char '|'))+ (parOpen, parClose) =+ case boxity of+ Boxed -> (text "(", text ")")+ Unboxed -> (text "(#", text "#)")++-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] in+-- GHC.parser.PostProcess+data PatBuilder p+ = PatBuilderPat (Pat p)+ | PatBuilderPar (Located (PatBuilder p))+ | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))+ | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))+ | PatBuilderVar (Located RdrName)+ | PatBuilderOverLit (HsOverLit GhcPs)++instance Outputable (PatBuilder GhcPs) where+ ppr (PatBuilderPat p) = ppr p+ ppr (PatBuilderPar (L _ p)) = parens (ppr p)+ ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2+ ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2+ ppr (PatBuilderVar v) = ppr v+ ppr (PatBuilderOverLit l) = ppr l++-- | An accumulator to build a prefix data constructor,+-- e.g. when parsing @MkT A B C@, the accumulator will evolve as follows:+--+-- @+-- 1. PrefixDataConBuilder [] MkT+-- 2. PrefixDataConBuilder [A] MkT+-- 3. PrefixDataConBuilder [A, B] MkT+-- 4. PrefixDataConBuilder [A, B, C] MkT+-- @+--+-- There are two reasons we have a separate builder type instead of using+-- @HsConDeclDetails GhcPs@ directly:+--+-- 1. It's faster, because 'OrdList' gives us constant-time snoc.+-- 2. Having a separate type helps ensure that we don't forget to finalize a+-- 'RecTy' into a 'RecCon' (we do that in 'dataConBuilderDetails').+--+-- See Note [PatBuilder] for another builder type used in the parser.+-- Here the technique is similar, but the motivation is different.+data DataConBuilder+ = PrefixDataConBuilder+ (OrdList (LHsType GhcPs)) -- Data constructor fields+ (Located RdrName) -- Data constructor name+ | InfixDataConBuilder+ (LHsType GhcPs) -- LHS field+ (Located RdrName) -- Data constructor name+ (LHsType GhcPs) -- RHS field++instance Outputable DataConBuilder where+ ppr (PrefixDataConBuilder flds data_con) =+ hang (ppr data_con) 2 (sep (map ppr (toList flds)))+ ppr (InfixDataConBuilder lhs data_con rhs) =+ ppr lhs <+> ppr data_con <+> ppr rhs+
compiler/GHC/Platform.hs view
@@ -31,19 +31,24 @@ , PlatformMisc(..) , SseVersion (..) , BmiVersion (..)+ -- * Shared libraries+ , platformSOName+ , platformHsSOName+ , platformSOExt ) where import Prelude -- See Note [Why do we import Prelude here?] -import Data.Word-import Data.Int- import GHC.Read import GHC.ByteOrder (ByteOrder(..)) import GHC.Platform.Constants import GHC.Platform.ArchOS +import Data.Word+import Data.Int+import System.FilePath+ -- | Platform description -- -- This is used to describe platforms so that we can generate code for them.@@ -209,8 +214,22 @@ , platformMisc_ghcWithSMP :: Bool , platformMisc_ghcRTSWays :: String , platformMisc_libFFI :: Bool- , platformMisc_ghcThreaded :: Bool- , platformMisc_ghcDebugged :: Bool , platformMisc_ghcRtsWithLibdw :: Bool , platformMisc_llvmTarget :: String }++platformSOName :: Platform -> FilePath -> FilePath+platformSOName platform root = case platformOS platform of+ OSMinGW32 -> root <.> platformSOExt platform+ _ -> ("lib" ++ root) <.> platformSOExt platform++platformHsSOName :: Platform -> FilePath -> FilePath+platformHsSOName platform root = ("lib" ++ root) <.> platformSOExt platform++platformSOExt :: Platform -> FilePath+platformSOExt platform+ = case platformOS platform of+ OSDarwin -> "dylib"+ OSMinGW32 -> "dll"+ _ -> "so"+
compiler/GHC/Platform/Ways.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- | Ways -- -- The central concept of a "way" is that all objects in a given@@ -33,13 +35,21 @@ , wayTag , waysTag , waysBuildTag+ , fullWays+ , rtsWays -- * Host GHC ways+ , hostWays , hostFullWays , hostIsProfiled , hostIsDynamic+ , hostIsThreaded+ , hostIsDebugged+ , hostIsTracing ) where +#include "GhclibHsVersions.h"+ import GHC.Prelude import GHC.Platform import GHC.Driver.Flags@@ -47,7 +57,6 @@ import qualified Data.Set as Set import Data.Set (Set) import Data.List (intersperse)-import System.IO.Unsafe ( unsafeDupablePerformIO ) -- | A way --@@ -58,7 +67,7 @@ | WayThreaded -- ^ (RTS only) Multithreaded runtime system | WayDebug -- ^ Debugging, enable trace messages and extra checks | WayProf -- ^ Profiling, enable cost-centre stacks and profiling reports- | WayEventLog -- ^ (RTS only) enable event logging+ | WayTracing -- ^ (RTS only) enable event logging (tracing) | WayDyn -- ^ Dynamic linking deriving (Eq, Ord, Show) @@ -96,7 +105,7 @@ wayTag WayDebug = "debug" wayTag WayDyn = "dyn" wayTag WayProf = "p"-wayTag WayEventLog = "l"+wayTag WayTracing = "l" -- "l" for "logging" -- | Return true for ways that only impact the RTS, not the generated code wayRTSOnly :: Way -> Bool@@ -105,15 +114,23 @@ wayRTSOnly WayProf = False wayRTSOnly WayThreaded = True wayRTSOnly WayDebug = True-wayRTSOnly WayEventLog = True+wayRTSOnly WayTracing = True +-- | Filter ways that have an impact on compilation+fullWays :: Ways -> Ways+fullWays ws = Set.filter (not . wayRTSOnly) ws++-- | Filter RTS-only ways (ways that don't have an impact on compilation)+rtsWays :: Ways -> Ways+rtsWays ws = Set.filter wayRTSOnly ws+ wayDesc :: Way -> String wayDesc (WayCustom xs) = xs wayDesc WayThreaded = "Threaded" wayDesc WayDebug = "Debug" wayDesc WayDyn = "Dynamic" wayDesc WayProf = "Profiling"-wayDesc WayEventLog = "RTS Event Logging"+wayDesc WayTracing = "Tracing" -- | Turn these flags on when enabling this way wayGeneralFlags :: Platform -> Way -> [GeneralFlag]@@ -129,7 +146,7 @@ -- PIC objects can be linked into a .so, we have to compile even -- modules of the main program with -fPIC when using -dynamic. wayGeneralFlags _ WayProf = []-wayGeneralFlags _ WayEventLog = []+wayGeneralFlags _ WayTracing = [] -- | Turn these flags off when enabling this way wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag]@@ -140,7 +157,7 @@ -- There's no point splitting when we're going to be dynamically linking. -- Plus it breaks compilation on OSX x86. wayUnsetGeneralFlags _ WayProf = []-wayUnsetGeneralFlags _ WayEventLog = []+wayUnsetGeneralFlags _ WayTracing = [] -- | Pass these options to the C compiler when enabling this way wayOptc :: Platform -> Way -> [String]@@ -152,7 +169,7 @@ wayOptc _ WayDebug = [] wayOptc _ WayDyn = [] wayOptc _ WayProf = ["-DPROFILING"]-wayOptc _ WayEventLog = ["-DTRACING"]+wayOptc _ WayTracing = ["-DTRACING"] -- | Pass these options to linker when enabling this way wayOptl :: Platform -> Way -> [String]@@ -168,7 +185,7 @@ wayOptl _ WayDebug = [] wayOptl _ WayDyn = [] wayOptl _ WayProf = []-wayOptl _ WayEventLog = []+wayOptl _ WayTracing = [] -- | Pass these options to the preprocessor when enabling this way wayOptP :: Platform -> Way -> [String]@@ -177,29 +194,74 @@ wayOptP _ WayDebug = [] wayOptP _ WayDyn = [] wayOptP _ WayProf = ["-DPROFILING"]-wayOptP _ WayEventLog = ["-DTRACING"]+wayOptP _ WayTracing = ["-DTRACING"] -- | Consult the RTS to find whether it has been built with profiling enabled. hostIsProfiled :: Bool-hostIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0+hostIsProfiled = rtsIsProfiled_ /= 0 -foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO Int+foreign import ccall unsafe "rts_isProfiled" rtsIsProfiled_ :: Int -- | Consult the RTS to find whether GHC itself has been built with -- dynamic linking. This can't be statically known at compile-time, -- because we build both the static and dynamic versions together with -- -dynamic-too. hostIsDynamic :: Bool-hostIsDynamic = unsafeDupablePerformIO rtsIsDynamicIO /= 0+hostIsDynamic = rtsIsDynamic_ /= 0 -foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO Int+foreign import ccall unsafe "rts_isDynamic" rtsIsDynamic_ :: Int --- | Return host "full" ways (i.e. ways that have an impact on the compilation,--- not RTS only ways). These ways must be used when compiling codes targeting--- the internal interpreter.-hostFullWays :: Ways-hostFullWays = Set.unions- [ if hostIsDynamic then Set.singleton WayDyn else Set.empty- , if hostIsProfiled then Set.singleton WayProf else Set.empty+-- we need this until the bootstrap GHC is always recent enough+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)++-- | Consult the RTS to find whether it is threaded.+hostIsThreaded :: Bool+hostIsThreaded = rtsIsThreaded_ /= 0++foreign import ccall unsafe "rts_isThreaded" rtsIsThreaded_ :: Int++-- | Consult the RTS to find whether it is debugged.+hostIsDebugged :: Bool+hostIsDebugged = rtsIsDebugged_ /= 0++foreign import ccall unsafe "rts_isDebugged" rtsIsDebugged_ :: Int++-- | Consult the RTS to find whether it is tracing.+hostIsTracing :: Bool+hostIsTracing = rtsIsTracing_ /= 0++foreign import ccall unsafe "rts_isTracing" rtsIsTracing_ :: Int+++#else++hostIsThreaded :: Bool+hostIsThreaded = False++hostIsDebugged :: Bool+hostIsDebugged = False++hostIsTracing :: Bool+hostIsTracing = False++#endif+++-- | Host ways.+hostWays :: Ways+hostWays = Set.unions+ [ if hostIsDynamic then Set.singleton WayDyn else Set.empty+ , if hostIsProfiled then Set.singleton WayProf else Set.empty+ , if hostIsThreaded then Set.singleton WayThreaded else Set.empty+ , if hostIsDebugged then Set.singleton WayDebug else Set.empty+ , if hostIsTracing then Set.singleton WayTracing else Set.empty ]++-- | Host "full" ways (i.e. ways that have an impact on the compilation,+-- not RTS only ways).+--+-- These ways must be used when compiling codes targeting the internal+-- interpreter.+hostFullWays :: Ways+hostFullWays = fullWays hostWays
+ compiler/GHC/Runtime/Context.hs view
@@ -0,0 +1,389 @@+module GHC.Runtime.Context+ ( InteractiveContext (..)+ , InteractiveImport (..)+ , emptyInteractiveContext+ , extendInteractiveContext+ , extendInteractiveContextWithIds+ , setInteractivePrintName+ , substInteractiveContext+ , icExtendGblRdrEnv+ , icInteractiveModule+ , icInScopeTTs+ , icPrintUnqual+ )+where++import GHC.Prelude++import GHC.Hs++import GHC.Driver.Session++import GHC.Runtime.Eval.Types ( Resume )++import GHC.Unit++import GHC.Core.FamInstEnv+import GHC.Core.InstEnv ( ClsInst, identicalClsInstHead )+import GHC.Core.Type++import GHC.Types.Avail+import GHC.Types.Fixity.Env+import GHC.Types.Id.Info ( IdDetails(..) )+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Reader+import GHC.Types.Name.Ppr+import GHC.Types.TyThing+import GHC.Types.Var++import GHC.Builtin.Names ( ioTyConName, printName, mkInteractiveModule )++import GHC.Utils.Outputable+import GHC.Utils.Misc++{-+Note [The interactive package]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Type, class, and value declarations at the command prompt are treated+as if they were defined in modules+ interactive:Ghci1+ interactive:Ghci2+ ...etc...+with each bunch of declarations using a new module, all sharing a+common package 'interactive' (see Module.interactiveUnitId, and+GHC.Builtin.Names.mkInteractiveModule).++This scheme deals well with shadowing. For example:++ ghci> data T = A+ ghci> data T = B+ ghci> :i A+ data Ghci1.T = A -- Defined at <interactive>:2:10++Here we must display info about constructor A, but its type T has been+shadowed by the second declaration. But it has a respectable+qualified name (Ghci1.T), and its source location says where it was+defined.++So the main invariant continues to hold, that in any session an+original name M.T only refers to one unique thing. (In a previous+iteration both the T's above were called :Interactive.T, albeit with+different uniques, which gave rise to all sorts of trouble.)++The details are a bit tricky though:++ * The field ic_mod_index counts which Ghci module we've got up to.+ It is incremented when extending ic_tythings++ * ic_tythings contains only things from the 'interactive' package.++ * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go+ in the Home Package Table (HPT). When you say :load, that's when we+ extend the HPT.++ * The 'homeUnitId' field of DynFlags is *not* set to 'interactive'.+ It stays as 'main' (or whatever -this-unit-id says), and is the+ package to which :load'ed modules are added to.++ * So how do we arrange that declarations at the command prompt get to+ be in the 'interactive' package? Simply by setting the tcg_mod+ field of the TcGblEnv to "interactive:Ghci1". This is done by the+ call to initTc in initTcInteractive, which in turn get the module+ from it 'icInteractiveModule' field of the interactive context.++ The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says.++ * The main trickiness is that the type environment (tcg_type_env) and+ fixity envt (tcg_fix_env), now contain entities from all the+ interactive-package modules (Ghci1, Ghci2, ...) together, rather+ than just a single module as is usually the case. So you can't use+ "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs+ the HPT/PTE. This is a change, but not a problem provided you+ know.++* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields+ of the TcGblEnv, which collect "things defined in this module", all+ refer to stuff define in a single GHCi command, *not* all the commands+ so far.++ In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from+ all GhciN modules, which makes sense -- they are all "home package"+ modules.+++Note [Interactively-bound Ids in GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Ids bound by previous Stmts in GHCi are currently+ a) GlobalIds, with+ b) An External Name, like Ghci4.foo+ See Note [The interactive package] above+ c) A tidied type++ (a) They must be GlobalIds (not LocalIds) otherwise when we come to+ compile an expression using these ids later, the byte code+ generator will consider the occurrences to be free rather than+ global.++ (b) Having an External Name is important because of Note+ [GlobalRdrEnv shadowing] in GHC.Types.Names.RdrName++ (c) Their types are tidied. This is important, because :info may ask+ to look at them, and :info expects the things it looks up to have+ tidy types++Where do interactively-bound Ids come from?++ - GHCi REPL Stmts e.g.+ ghci> let foo x = x+1+ These start with an Internal Name because a Stmt is a local+ construct, so the renamer naturally builds an Internal name for+ each of its binders. Then in tcRnStmt they are externalised via+ GHC.Tc.Module.externaliseAndTidyId, so they get Names like Ghic4.foo.++ - Ids bound by the debugger etc have Names constructed by+ GHC.Iface.Env.newInteractiveBinder; at the call sites it is followed by+ mkVanillaGlobal or mkVanillaGlobalWithInfo. So again, they are+ all Global, External.++ - TyCons, Classes, and Ids bound by other top-level declarations in+ GHCi (eg foreign import, record selectors) also get External+ Names, with Ghci9 (or 8, or 7, etc) as the module name.+++Note [ic_tythings]+~~~~~~~~~~~~~~~~~~+The ic_tythings field contains+ * The TyThings declared by the user at the command prompt+ (eg Ids, TyCons, Classes)++ * The user-visible Ids that arise from such things, which+ *don't* come from 'implicitTyThings', notably:+ - record selectors+ - class ops+ The implicitTyThings are readily obtained from the TyThings+ but record selectors etc are not++It does *not* contain+ * DFunIds (they can be gotten from ic_instances)+ * CoAxioms (ditto)++See also Note [Interactively-bound Ids in GHCi]++Note [Override identical instances in GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If you declare a new instance in GHCi that is identical to a previous one,+we simply override the previous one; we don't regard it as overlapping.+e.g. Prelude> data T = A | B+ Prelude> instance Eq T where ...+ Prelude> instance Eq T where ... -- This one overrides++It's exactly the same for type-family instances. See #7102+-}++-- | Interactive context, recording information about the state of the+-- context in which statements are executed in a GHCi session.+data InteractiveContext+ = InteractiveContext {+ ic_dflags :: DynFlags,+ -- ^ The 'DynFlags' used to evaluate interactive expressions+ -- and statements.++ ic_mod_index :: Int,+ -- ^ Each GHCi stmt or declaration brings some new things into+ -- scope. We give them names like interactive:Ghci9.T,+ -- where the ic_index is the '9'. The ic_mod_index is+ -- incremented whenever we add something to ic_tythings+ -- See Note [The interactive package]++ ic_imports :: [InteractiveImport],+ -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with+ -- these imports+ --+ -- This field is only stored here so that the client+ -- can retrieve it with GHC.getContext. GHC itself doesn't+ -- use it, but does reset it to empty sometimes (such+ -- as before a GHC.load). The context is set with GHC.setContext.++ ic_tythings :: [TyThing],+ -- ^ TyThings defined by the user, in reverse order of+ -- definition (ie most recent at the front)+ -- See Note [ic_tythings]++ ic_rn_gbl_env :: GlobalRdrEnv,+ -- ^ The cached 'GlobalRdrEnv', built by+ -- 'GHC.Runtime.Eval.setContext' and updated regularly+ -- It contains everything in scope at the command line,+ -- including everything in ic_tythings++ ic_instances :: ([ClsInst], [FamInst]),+ -- ^ All instances and family instances created during+ -- this session. These are grabbed en masse after each+ -- update to be sure that proper overlapping is retained.+ -- That is, rather than re-check the overlapping each+ -- time we update the context, we just take the results+ -- from the instance code that already does that.++ ic_fix_env :: FixityEnv,+ -- ^ Fixities declared in let statements++ ic_default :: Maybe [Type],+ -- ^ The current default types, set by a 'default' declaration++ ic_resume :: [Resume],+ -- ^ The stack of breakpoint contexts++ ic_monad :: Name,+ -- ^ The monad that GHCi is executing in++ ic_int_print :: Name,+ -- ^ The function that is used for printing results+ -- of expressions in ghci and -e mode.++ ic_cwd :: Maybe FilePath+ -- virtual CWD of the program+ }++data InteractiveImport+ = IIDecl (ImportDecl GhcPs)+ -- ^ Bring the exports of a particular module+ -- (filtered by an import decl) into scope++ | IIModule ModuleName+ -- ^ Bring into scope the entire top-level envt of+ -- of this module, including the things imported+ -- into it.+++-- | Constructs an empty InteractiveContext.+emptyInteractiveContext :: DynFlags -> InteractiveContext+emptyInteractiveContext dflags+ = InteractiveContext {+ ic_dflags = dflags,+ ic_imports = [],+ ic_rn_gbl_env = emptyGlobalRdrEnv,+ ic_mod_index = 1,+ ic_tythings = [],+ ic_instances = ([],[]),+ ic_fix_env = emptyNameEnv,+ ic_monad = ioTyConName, -- IO monad by default+ ic_int_print = printName, -- System.IO.print by default+ ic_default = Nothing,+ ic_resume = [],+ ic_cwd = Nothing }++icInteractiveModule :: InteractiveContext -> Module+icInteractiveModule (InteractiveContext { ic_mod_index = index })+ = mkInteractiveModule index++-- | This function returns the list of visible TyThings (useful for+-- e.g. showBindings)+icInScopeTTs :: InteractiveContext -> [TyThing]+icInScopeTTs = ic_tythings++-- | Get the PrintUnqualified function based on the flags and this InteractiveContext+icPrintUnqual :: UnitState -> HomeUnit -> InteractiveContext -> PrintUnqualified+icPrintUnqual unit_state home_unit InteractiveContext{ ic_rn_gbl_env = grenv } =+ mkPrintUnqualified unit_state home_unit grenv++-- | extendInteractiveContext is called with new TyThings recently defined to update the+-- InteractiveContext to include them. Ids are easily removed when shadowed,+-- but Classes and TyCons are not. Some work could be done to determine+-- whether they are entirely shadowed, but as you could still have references+-- to them (e.g. instances for classes or values of the type for TyCons), it's+-- not clear whether removing them is even the appropriate behavior.+extendInteractiveContext :: InteractiveContext+ -> [TyThing]+ -> [ClsInst] -> [FamInst]+ -> Maybe [Type]+ -> FixityEnv+ -> InteractiveContext+extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env+ = ictxt { ic_mod_index = ic_mod_index ictxt + 1+ -- Always bump this; even instances should create+ -- a new mod_index (#9426)+ , ic_tythings = new_tythings ++ old_tythings+ , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings+ , ic_instances = ( new_cls_insts ++ old_cls_insts+ , new_fam_insts ++ fam_insts )+ -- we don't shadow old family instances (#7102),+ -- so don't need to remove them here+ , ic_default = defaults+ , ic_fix_env = fix_env -- See Note [Fixity declarations in GHCi]+ }+ where+ new_ids = [id | AnId id <- new_tythings]+ old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)++ -- Discard old instances that have been fully overridden+ -- See Note [Override identical instances in GHCi]+ (cls_insts, fam_insts) = ic_instances ictxt+ old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts++extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext+-- Just a specialised version+extendInteractiveContextWithIds ictxt new_ids+ | null new_ids = ictxt+ | otherwise = ictxt { ic_mod_index = ic_mod_index ictxt + 1+ , ic_tythings = new_tythings ++ old_tythings+ , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings }+ where+ new_tythings = map AnId new_ids+ old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)++shadowed_by :: [Id] -> TyThing -> Bool+shadowed_by ids = shadowed+ where+ shadowed id = getOccName id `elemOccSet` new_occs+ new_occs = mkOccSet (map getOccName ids)++setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext+setInteractivePrintName ic n = ic{ic_int_print = n}++ -- ToDo: should not add Ids to the gbl env here++-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing+-- later ones, and shadowing existing entries in the GlobalRdrEnv.+icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv+icExtendGblRdrEnv env tythings+ = foldr add env tythings -- Foldr makes things in the front of+ -- the list shadow things at the back+ where+ -- One at a time, to ensure each shadows the previous ones+ add thing env+ | is_sub_bndr thing+ = env+ | otherwise+ = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail)+ where+ env1 = shadowNames env (concatMap availNames avail)+ avail = tyThingAvailInfo thing++ -- Ugh! The new_tythings may include record selectors, since they+ -- are not implicit-ids, and must appear in the TypeEnv. But they+ -- will also be brought into scope by the corresponding (ATyCon+ -- tc). And we want the latter, because that has the correct+ -- parent (#10520)+ is_sub_bndr (AnId f) = case idDetails f of+ RecSelId {} -> True+ ClassOpId {} -> True+ _ -> False+ is_sub_bndr _ = False++substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext+substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst+ | isEmptyTCvSubst subst = ictxt+ | otherwise = ictxt { ic_tythings = map subst_ty tts }+ where+ subst_ty (AnId id)+ = AnId $ updateIdTypeAndMult (substTyAddInScope subst) id+ -- Variables in the interactive context *can* mention free type variables+ -- because of the runtime debugger. Otherwise you'd expect all+ -- variables bound in the interactive context to be closed.+ subst_ty tt+ = tt++instance Outputable InteractiveImport where+ ppr (IIModule m) = char '*' <> ppr m+ ppr (IIDecl d) = ppr d+
compiler/GHC/Runtime/Eval/Types.hs view
@@ -18,9 +18,9 @@ import GHCi.Message (EvalExpr, ResumeContext) import GHC.Types.Id import GHC.Types.Name+import GHC.Types.TyThing import GHC.Unit.Module import GHC.Types.Name.Reader-import GHC.Core.Type import GHC.Types.SrcLoc import GHC.Utils.Exception
compiler/GHC/Runtime/Linker/Types.hs view
@@ -6,27 +6,36 @@ -- ----------------------------------------------------------------------------- -module GHC.Runtime.Linker.Types (- DynLinker(..),- PersistentLinkerState(..),- Linkable(..),- Unlinked(..),- SptEntry(..)- ) where+module GHC.Runtime.Linker.Types+ ( DynLinker(..)+ , PersistentLinkerState(..)+ , Linkable(..)+ , Unlinked(..)+ , SptEntry(..)+ , isObjectLinkable+ , linkableObjs+ , isObject+ , nameOfObject+ , isInterpretable+ , byteCodeOfObject+ )+where -import GHC.Prelude ( FilePath, String, show )+import GHC.Prelude import Data.Time ( UTCTime )-import Data.Maybe ( Maybe ) import Control.Concurrent.MVar ( MVar ) import GHC.Unit ( UnitId, Module ) import GHC.ByteCode.Types ( ItblEnv, CompiledByteCode )-import GHC.Utils.Outputable-import GHC.Types.Var ( Id ) import GHC.Fingerprint.Type ( Fingerprint )+import GHCi.RemoteTypes ( ForeignHValue )++import GHC.Types.Var ( Id ) import GHC.Types.Name.Env ( NameEnv ) import GHC.Types.Name ( Name )-import GHCi.RemoteTypes ( ForeignHValue ) +import GHC.Utils.Outputable+import GHC.Utils.Panic+ type ClosureEnv = NameEnv (Name, ForeignHValue) newtype DynLinker =@@ -106,3 +115,39 @@ instance Outputable SptEntry where ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr ++isObjectLinkable :: Linkable -> Bool+isObjectLinkable l = not (null unlinked) && all isObject unlinked+ where unlinked = linkableUnlinked l+ -- A linkable with no Unlinked's is treated as a BCO. We can+ -- generate a linkable with no Unlinked's as a result of+ -- compiling a module in NoBackend mode, and this choice+ -- happens to work well with checkStability in module GHC.++linkableObjs :: Linkable -> [FilePath]+linkableObjs l = [ f | DotO f <- linkableUnlinked l ]++-------------------------------------------++-- | Is this an actual file on disk we can link in somehow?+isObject :: Unlinked -> Bool+isObject (DotO _) = True+isObject (DotA _) = True+isObject (DotDLL _) = True+isObject _ = False++-- | Is this a bytecode linkable with no file on disk?+isInterpretable :: Unlinked -> Bool+isInterpretable = not . isObject++-- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object+nameOfObject :: Unlinked -> FilePath+nameOfObject (DotO fn) = fn+nameOfObject (DotA fn) = fn+nameOfObject (DotDLL fn) = fn+nameOfObject other = pprPanic "nameOfObject" (ppr other)++-- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable+byteCodeOfObject :: Unlinked -> CompiledByteCode+byteCodeOfObject (BCOs bc _) = bc+byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other)
compiler/GHC/Settings.hs view
@@ -61,8 +61,6 @@ , sGhcWithSMP , sGhcRTSWays , sLibFFI- , sGhcThreaded- , sGhcDebugged , sGhcRtsWithLibdw ) where @@ -276,9 +274,5 @@ sGhcRTSWays = platformMisc_ghcRTSWays . sPlatformMisc sLibFFI :: Settings -> Bool sLibFFI = platformMisc_libFFI . sPlatformMisc-sGhcThreaded :: Settings -> Bool-sGhcThreaded = platformMisc_ghcThreaded . sPlatformMisc-sGhcDebugged :: Settings -> Bool-sGhcDebugged = platformMisc_ghcDebugged . sPlatformMisc sGhcRtsWithLibdw :: Settings -> Bool sGhcRtsWithLibdw = platformMisc_ghcRtsWithLibdw . sPlatformMisc
compiler/GHC/Settings/Constants.hs view
@@ -11,14 +11,14 @@ -- All pretty arbitrary: mAX_TUPLE_SIZE :: Int-mAX_TUPLE_SIZE = 62 -- Should really match the number- -- of decls in Data.Tuple+mAX_TUPLE_SIZE = 64 -- Should really match the number+ -- of decls in GHC.Tuple mAX_CTUPLE_SIZE :: Int -- Constraint tuples-mAX_CTUPLE_SIZE = 62 -- Should match the number of decls in GHC.Classes+mAX_CTUPLE_SIZE = 64 -- Should match the number of decls in GHC.Classes mAX_SUM_SIZE :: Int-mAX_SUM_SIZE = 62+mAX_SUM_SIZE = 64 -- | Default maximum depth for both class instance search and type family -- reduction. See also #5395.
compiler/GHC/Stg/Syntax.hs view
@@ -1,3 +1,12 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -9,16 +18,6 @@ being one that happens to be ideally suited to spineless tagless code generation. -}--{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE LambdaCase #-} module GHC.Stg.Syntax ( StgArg(..),
compiler/GHC/Tc/Types.hs view
@@ -1,12 +1,14 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ {- (c) The University of Glasgow 2006-2012 (c) The GRASP Project, Glasgow University, 1992-2002 -} -{-# LANGUAGE CPP, DeriveFunctor, ExistentialQuantification, GeneralizedNewtypeDeriving,- ViewPatterns #-}- -- | Various types used during typechecking. -- -- Please see "GHC.Tc.Utils.Monad" as well for operations on these types. You probably@@ -85,23 +87,30 @@ import GHC.Prelude import GHC.Platform +import GHC.Driver.Env+import GHC.Driver.Session+ import GHC.Hs-import GHC.Driver.Types++import GHC.Tc.Utils.TcType+import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence+import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes ( HoleFitPlugin )+ import GHC.Core.Type import GHC.Core.TyCon ( TyCon, tyConKind ) import GHC.Core.PatSyn ( PatSyn ) import GHC.Core.Lint ( lintAxioms )-import GHC.Types.Id ( idType, idName )-import GHC.Types.FieldLabel ( FieldLabel ) import GHC.Core.UsageEnv-import GHC.Tc.Utils.TcType-import GHC.Tc.Types.Constraint-import GHC.Tc.Types.Origin-import GHC.Types.Annotations import GHC.Core.InstEnv import GHC.Core.FamInstEnv-import GHC.Data.IOEnv++import GHC.Types.Id ( idType, idName )+import GHC.Types.FieldLabel ( FieldLabel )+import GHC.Types.Fixity.Env+import GHC.Types.Annotations+import GHC.Types.CompleteMatch import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Name.Env@@ -109,26 +118,36 @@ import GHC.Types.Avail import GHC.Types.Var import GHC.Types.Var.Env-import GHC.Unit+import GHC.Types.TypeEnv+import GHC.Types.TyThing+import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Var.Set-import GHC.Utils.Error import GHC.Types.Unique.FM import GHC.Types.Basic+import GHC.Types.CostCentre.State+import GHC.Types.HpcInfo++import GHC.Data.IOEnv import GHC.Data.Bag-import GHC.Driver.Session-import GHC.Utils.Outputable import GHC.Data.List.SetOps++import GHC.Unit+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.Imported+import GHC.Unit.Module.ModDetails++import GHC.Utils.Error+import GHC.Utils.Outputable import GHC.Utils.Fingerprint import GHC.Utils.Misc import GHC.Utils.Panic+ import GHC.Builtin.Names ( isUnboundName )-import GHC.Types.CostCentre.State import Control.Monad (ap) import Data.Set ( Set ) import qualified Data.Set as S- import Data.List ( sort ) import Data.Map ( Map ) import Data.Dynamic ( Dynamic )@@ -137,8 +156,6 @@ import GHCi.Message import GHCi.RemoteTypes -import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes ( HoleFitPlugin )- import qualified Language.Haskell.TH as TH -- | A 'NameShape' is a substitution on 'Name's that can be used@@ -295,7 +312,7 @@ -- module. Currently one always gets a 'FrontendTypecheck', since running the -- frontend involves typechecking a program. hs-sig merges are not handled here. ----- This data type really should be in GHC.Driver.Types, but it needs+-- This data type really should be in GHC.Driver.Env, but it needs -- to have a TcGblEnv which is only defined here. data FrontendResult = FrontendTypecheck TcGblEnv@@ -365,7 +382,7 @@ tcg_fix_env :: FixityEnv, -- ^ Just for things in this module tcg_field_env :: RecFieldEnv, -- ^ Just for things in this module- -- See Note [The interactive package] in "GHC.Driver.Types"+ -- See Note [The interactive package] in "GHC.Runtime.Context" tcg_type_env :: TypeEnv, -- ^ Global type env for the module we are compiling now. All@@ -376,7 +393,7 @@ -- move to the global envt during zonking) -- -- NB: for what "things in this module" means, see- -- Note [The interactive package] in "GHC.Driver.Types"+ -- Note [The interactive package] in "GHC.Runtime.Context" tcg_type_env_var :: TcRef TypeEnv, -- Used only to initialise the interface-file@@ -499,7 +516,8 @@ -- Things defined in this module, or (in GHCi) -- in the declarations for a single GHCi command.- -- For the latter, see Note [The interactive package] in GHC.Driver.Types+ -- For the latter, see Note [The interactive package] in+ -- GHC.Runtime.Context tcg_tr_module :: Maybe Id, -- Id for $trModule :: GHC.Unit.Module -- for which every module has a top-level defn -- except in GHCi in which case we have Nothing@@ -1283,8 +1301,8 @@ -- = ModuleEnv [ImportedModsVal], -- ^ Domain is all directly-imported modules --- -- See the documentation on ImportedModsVal in "GHC.Driver.Types" for the- -- meaning of the fields.+ -- See the documentation on ImportedModsVal in+ -- "GHC.Unit.Module.Imported" for the meaning of the fields. -- -- We need a full ModuleEnv rather than a ModuleNameEnv here, -- because we might be importing modules of the same name from
compiler/GHC/Tc/Types/Evidence.hs view
@@ -48,6 +48,7 @@ mkTcKindCo, tcCoercionKind, mkTcCoVarCo,+ mkTcFamilyTyConAppCo, isTcReflCo, isTcReflexiveCo, tcCoercionRole, unwrapIP, wrapIP,@@ -68,8 +69,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.TyCon-import GHC.Core.DataCon( DataCon, dataConWrapId )-import GHC.Core.Class( Class )+import GHC.Core.DataCon ( DataCon, dataConWrapId ) import GHC.Builtin.Names import GHC.Types.Var.Env import GHC.Types.Var.Set@@ -78,7 +78,7 @@ import GHC.Data.Pair import GHC.Core-import GHC.Core.Class ( classSCSelId )+import GHC.Core.Class (Class, classSCSelId ) import GHC.Core.FVs ( exprSomeFreeVars ) import GHC.Utils.Misc@@ -141,6 +141,7 @@ mkTcPhantomCo :: TcCoercionN -> TcType -> TcType -> TcCoercionP mkTcKindCo :: TcCoercion -> TcCoercionN mkTcCoVarCo :: CoVar -> TcCoercion+mkTcFamilyTyConAppCo :: TyCon -> [TcCoercionN] -> TcCoercionN tcCoercionKind :: TcCoercion -> Pair TcType tcCoercionRole :: TcCoercion -> Role@@ -174,6 +175,7 @@ mkTcPhantomCo = mkPhantomCo mkTcKindCo = mkKindCo mkTcCoVarCo = mkCoVarCo+mkTcFamilyTyConAppCo = mkFamilyTyConAppCo tcCoercionKind = coercionKind tcCoercionRole = coercionRole@@ -1019,7 +1021,7 @@ -- overloaded-label dictionary to expose the underlying value. We -- expect the 'Type' to have the form `IP sym ty` or `IsLabel sym ty`, -- and return a 'Coercion' `co :: IP sym ty ~ ty` or--- `co :: IsLabel sym ty ~ Proxy# sym -> ty`. See also+-- `co :: IsLabel sym ty ~ ty`. See also -- Note [Type-checking overloaded labels] in "GHC.Tc.Gen.Expr". unwrapIP :: Type -> CoercionR unwrapIP ty =
compiler/GHC/Tc/Utils/TcType.hs view
@@ -1,12 +1,15 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, ScopedTypeVariables, MultiWayIf, FlexibleContexts #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- -- | Types used in the typechecker -- -- This module provides the Type interface for front-end parts of the@@ -179,7 +182,7 @@ -------------------------------- pprKind, pprParendKind, pprSigmaType,- pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory,+ pprType, pprParendType, pprTypeApp, pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred, pprTCvBndr, pprTCvBndrs, @@ -1503,9 +1506,8 @@ tcEqKind = tcEqType tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool--- tcEqType is a proper implements the same Note [Non-trivial definitional--- equality] (in GHC.Core.TyCo.Rep) as `eqType`, but Type.eqType believes (* ==--- Constraint), and that is NOT what we want in the type checker!+-- ^ tcEqType implements typechecker equality, as described in+-- @Note [Typechecker equality vs definitional equality]@. tcEqType ty1 ty2 = tc_eq_type False False ki1 ki2 && tc_eq_type False False ty1 ty2@@ -1554,7 +1556,9 @@ go env (ForAllTy (Bndr tv1 vis1) ty1) (ForAllTy (Bndr tv2 vis2) ty2)- = vis1 == vis2+ = 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 @@ -1618,6 +1622,29 @@ = go env w w' && go env arg arg' && go env res res' get_args _ _ = False eqFunTy _ _ _ _ _ = False++{- 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.+-} {- ********************************************************************* * *
compiler/GHC/Types/Basic.hs view
@@ -33,14 +33,6 @@ PromotionFlag(..), isPromoted, FunctionOrData(..), - WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..),-- Fixity(..), FixityDirection(..),- defaultFixity, maxPrecedence, minPrecedence,- negateFixity, funTyFixity,- compareFixity,- LexicalFixity(..),- RecFlag(..), isRec, isNonRec, boolToRecFlag, Origin(..), isGenerated, @@ -100,28 +92,24 @@ SuccessFlag(..), succeeded, failed, successIf, - IntegralLit(..), FractionalLit(..),- negateIntegralLit, negateFractionalLit,- mkIntegralLit, mkFractionalLit,- integralFractionalLit,-- SourceText(..), pprWithSourceText,- IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit, SpliceExplicitFlag(..), - TypeOrKind(..), isTypeLevel, isKindLevel+ TypeOrKind(..), isTypeLevel, isKindLevel,++ ForeignSrcLang (..) ) where import GHC.Prelude +import GHC.ForeignSrcLang import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Types.SrcLoc ( Located,unLoc )-import Data.Data hiding (Fixity, Prefix, Infix)-import Data.Function (on)+import GHC.Utils.Binary+import GHC.Types.SourceText+import Data.Data import Data.Bits import qualified Data.Semigroup as Semi @@ -144,6 +132,16 @@ ppr CLeft = text "Left" ppr CRight = text "Right" +instance Binary LeftOrRight where+ put_ bh CLeft = putByte bh 0+ put_ bh CRight = putByte bh 1++ get bh = do { h <- getByte bh+ ; case h of+ 0 -> return CLeft+ _ -> return CRight }++ {- ************************************************************************ * *@@ -402,6 +400,17 @@ ppr NotPromoted = text "NotPromoted" ppr IsPromoted = text "IsPromoted" +instance Binary PromotionFlag where+ put_ bh NotPromoted = putByte bh 0+ put_ bh IsPromoted = putByte bh 1++ get bh = do+ n <- getByte bh+ case n of+ 0 -> return NotPromoted+ 1 -> return IsPromoted+ _ -> fail "Binary(IsPromoted): fail)"+ {- ************************************************************************ * *@@ -417,62 +426,15 @@ ppr IsFunction = text "(function)" ppr IsData = text "(data)" -{--************************************************************************-* *- Deprecations-* *-************************************************************************--}---- | A String Literal in the source, including its original raw format for use by--- source to source manipulation tools.-data StringLiteral = StringLiteral- { sl_st :: SourceText, -- literal raw source.- -- See not [Literal source text]- sl_fs :: FastString -- literal string value- } deriving Data--instance Eq StringLiteral where- (StringLiteral _ a) == (StringLiteral _ b) = a == b--instance Outputable StringLiteral where- ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)---- | Warning Text------ reason/explanation from a WARNING or DEPRECATED pragma-data WarningTxt = WarningTxt (Located SourceText)- [Located StringLiteral]- | DeprecatedTxt (Located SourceText)- [Located StringLiteral]- deriving (Eq, Data)--instance Outputable WarningTxt where- ppr (WarningTxt lsrc ws)- = case unLoc lsrc of- NoSourceText -> pp_ws ws- SourceText src -> text src <+> pp_ws ws <+> text "#-}"-- ppr (DeprecatedTxt lsrc ds)- = case unLoc lsrc of- NoSourceText -> pp_ws ds- SourceText src -> text src <+> pp_ws ds <+> text "#-}"--pp_ws :: [Located StringLiteral] -> SDoc-pp_ws [l] = ppr $ unLoc l-pp_ws ws- = text "["- <+> vcat (punctuate comma (map (ppr . unLoc) ws))- <+> text "]"---pprWarningTxtForMsg :: WarningTxt -> SDoc-pprWarningTxtForMsg (WarningTxt _ ws)- = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))-pprWarningTxtForMsg (DeprecatedTxt _ ds)- = text "Deprecated:" <+>- doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))+instance Binary FunctionOrData where+ put_ bh IsFunction = putByte bh 0+ put_ bh IsData = putByte bh 1+ get bh = do+ h <- getByte bh+ case h of+ 0 -> return IsFunction+ 1 -> return IsData+ _ -> panic "Binary FunctionOrData" {- ************************************************************************@@ -487,83 +449,8 @@ pprRuleName :: RuleName -> SDoc pprRuleName rn = doubleQuotes (ftext rn) -{--************************************************************************-* *-\subsection[Fixity]{Fixity info}-* *-************************************************************************--} --------------------------data Fixity = Fixity SourceText Int FixityDirection- -- Note [Pragma source text]- deriving Data--instance Outputable Fixity where- ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec]--instance Eq Fixity where -- Used to determine if two fixities conflict- (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2---------------------------data FixityDirection = InfixL | InfixR | InfixN- deriving (Eq, Data)--instance Outputable FixityDirection where- ppr InfixL = text "infixl"- ppr InfixR = text "infixr"- ppr InfixN = text "infix"---------------------------maxPrecedence, minPrecedence :: Int-maxPrecedence = 9-minPrecedence = 0--defaultFixity :: Fixity-defaultFixity = Fixity NoSourceText maxPrecedence InfixL--negateFixity, funTyFixity :: Fixity--- Wired-in fixities-negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate-funTyFixity = Fixity NoSourceText (-1) InfixR -- Fixity of '->', see #15235- {--Consider--\begin{verbatim}- a `op1` b `op2` c-\end{verbatim}-@(compareFixity op1 op2)@ tells which way to arrange application, or-whether there's an error.--}--compareFixity :: Fixity -> Fixity- -> (Bool, -- Error please- Bool) -- Associate to the right: a op1 (b op2 c)-compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)- = case prec1 `compare` prec2 of- GT -> left- LT -> right- EQ -> case (dir1, dir2) of- (InfixR, InfixR) -> right- (InfixL, InfixL) -> left- _ -> error_please- where- right = (False, True)- left = (False, False)- error_please = (True, False)---- |Captures the fixity of declarations as they are parsed. This is not--- necessarily the same as the fixity declaration, as the normal fixity may be--- overridden using parens or backticks.-data LexicalFixity = Prefix | Infix deriving (Data,Eq)--instance Outputable LexicalFixity where- ppr Prefix = text "Prefix"- ppr Infix = text "Infix"--{- ************************************************************************ * * \subsection[Top-level/local]{Top-level/not-top level flag}@@ -637,6 +524,17 @@ ppr Recursive = text "Recursive" ppr NonRecursive = text "NonRecursive" +instance Binary RecFlag where+ put_ bh Recursive =+ putByte bh 0+ put_ bh NonRecursive =+ putByte bh 1+ get bh = do+ h <- getByte bh+ case h of+ 0 -> return Recursive+ _ -> return NonRecursive+ {- ************************************************************************ * *@@ -775,6 +673,31 @@ ppr (Overlaps _) = text "[overlap ok]" ppr (Incoherent _) = text "[incoherent]" +instance Binary OverlapMode where+ put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s+ put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s+ put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s+ put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s+ put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s+ get bh = do+ h <- getByte bh+ case h of+ 0 -> (get bh) >>= \s -> return $ NoOverlap s+ 1 -> (get bh) >>= \s -> return $ Overlaps s+ 2 -> (get bh) >>= \s -> return $ Incoherent s+ 3 -> (get bh) >>= \s -> return $ Overlapping s+ 4 -> (get bh) >>= \s -> return $ Overlappable s+ _ -> panic ("get OverlapMode" ++ show h)+++instance Binary OverlapFlag where+ put_ bh flag = do put_ bh (overlapMode flag)+ put_ bh (isSafeOverlap flag)+ get bh = do+ h <- get bh+ b <- get bh+ return OverlapFlag { overlapMode = h, isSafeOverlap = b }+ pprSafeOverlap :: Bool -> SDoc pprSafeOverlap True = text "[safe]" pprSafeOverlap False = empty@@ -889,6 +812,18 @@ UnboxedTuple -> "UnboxedTuple" ConstraintTuple -> "ConstraintTuple" +instance Binary TupleSort where+ put_ bh BoxedTuple = putByte bh 0+ put_ bh UnboxedTuple = putByte bh 1+ put_ bh ConstraintTuple = putByte bh 2+ get bh = do+ h <- getByte bh+ case h of+ 0 -> return BoxedTuple+ 1 -> return UnboxedTuple+ _ -> return ConstraintTuple++ tupleSortBoxity :: TupleSort -> Boxity tupleSortBoxity BoxedTuple = Boxed tupleSortBoxity UnboxedTuple = Unboxed@@ -1226,83 +1161,6 @@ {- ************************************************************************ * *-\subsection{Source Text}-* *-************************************************************************-Keeping Source Text for source to source conversions--Note [Pragma source text]-~~~~~~~~~~~~~~~~~~~~~~~~~-The lexer does a case-insensitive match for pragmas, as well as-accepting both UK and US spelling variants.--So-- {-# SPECIALISE #-}- {-# SPECIALIZE #-}- {-# Specialize #-}--will all generate ITspec_prag token for the start of the pragma.--In order to be able to do source to source conversions, the original-source text for the token needs to be preserved, hence the-`SourceText` field.--So the lexer will then generate-- ITspec_prag "{ -# SPECIALISE"- ITspec_prag "{ -# SPECIALIZE"- ITspec_prag "{ -# Specialize"--for the cases above.- [without the space between '{' and '-', otherwise this comment won't parse]---Note [Literal source text]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The lexer/parser converts literals from their original source text-versions to an appropriate internal representation. This is a problem-for tools doing source to source conversions, so the original source-text is stored in literals where this can occur.--Motivating examples for HsLit-- 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##- HsInteger 006 == 6--For OverLitVal-- HsIntegral 003 == 0x003- HsIsString "\x41nd" == "And"--}-- -- Note [Literal source text],[Pragma source text]-data SourceText = SourceText String- | NoSourceText -- ^ For when code is generated, e.g. TH,- -- deriving. The pretty printer will then make- -- its own representation of the item.- deriving (Data, Show, Eq )--instance Outputable SourceText where- ppr (SourceText s) = text "SourceText" <+> text s- ppr NoSourceText = text "NoSourceText"---- | Special combinator for showing string literals.-pprWithSourceText :: SourceText -> SDoc -> SDoc-pprWithSourceText NoSourceText d = d-pprWithSourceText (SourceText src) _ = text src--{--************************************************************************-* * \subsection{Activation} * * ************************************************************************@@ -1467,11 +1325,11 @@ -- | Inline Specification data InlineSpec -- What the user's INLINE pragma looked like- = Inline -- User wrote INLINE- | Inlinable -- User wrote INLINABLE- | NoInline -- User wrote NOINLINE- | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE- -- e.g. in `defaultInlinePragma` or when created by CSE+ = Inline -- User wrote INLINE+ | Inlinable -- User wrote INLINABLE+ | NoInline -- User wrote NOINLINE+ | NoUserInlinePrag -- User did not write any of INLINE/INLINABLE/NOINLINE+ -- e.g. in `defaultInlinePragma` or when created by CSE deriving( Eq, Data, Show ) -- Show needed for GHC.Parser.Lexer @@ -1481,7 +1339,7 @@ the source program. If you write nothing at all, you get defaultInlinePragma:- inl_inline = NoUserInline+ inl_inline = NoUserInlinePrag inl_act = AlwaysActive inl_rule = FunLike @@ -1494,7 +1352,7 @@ Note [inl_inline and inl_act] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* inl_inline says what the user wrote: did she say INLINE, NOINLINE,+* inl_inline says what the user wrote: did they say INLINE, NOINLINE, INLINABLE, or nothing at all * inl_act says in what phases the unfolding is active or inactive@@ -1555,15 +1413,15 @@ isFunLike _ = False noUserInlineSpec :: InlineSpec -> Bool-noUserInlineSpec NoUserInline = True-noUserInlineSpec _ = False+noUserInlineSpec NoUserInlinePrag = True+noUserInlineSpec _ = False defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" , inl_act = AlwaysActive , inl_rule = FunLike- , inl_inline = NoUserInline+ , inl_inline = NoUserInlinePrag , inl_sat = Nothing } alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }@@ -1624,19 +1482,87 @@ ppr (ActiveAfter _ n) = brackets (int n) ppr FinalActive = text "[final]" +instance Binary Activation where+ put_ bh NeverActive =+ putByte bh 0+ put_ bh FinalActive =+ putByte bh 1+ put_ bh AlwaysActive =+ putByte bh 2+ put_ bh (ActiveBefore src aa) = do+ putByte bh 3+ put_ bh src+ put_ bh aa+ put_ bh (ActiveAfter src ab) = do+ putByte bh 4+ put_ bh src+ put_ bh ab+ get bh = do+ h <- getByte bh+ case h of+ 0 -> return NeverActive+ 1 -> return FinalActive+ 2 -> return AlwaysActive+ 3 -> do src <- get bh+ aa <- get bh+ return (ActiveBefore src aa)+ _ -> do src <- get bh+ ab <- get bh+ return (ActiveAfter src ab)++ instance Outputable RuleMatchInfo where ppr ConLike = text "CONLIKE" ppr FunLike = text "FUNLIKE" +instance Binary RuleMatchInfo where+ put_ bh FunLike = putByte bh 0+ put_ bh ConLike = putByte bh 1+ get bh = do+ h <- getByte bh+ if h == 1 then return ConLike+ else return FunLike+ instance Outputable InlineSpec where- ppr Inline = text "INLINE"- ppr NoInline = text "NOINLINE"- ppr Inlinable = text "INLINABLE"- ppr NoUserInline = text "NOUSERINLINE" -- what is better?+ ppr Inline = text "INLINE"+ ppr NoInline = text "NOINLINE"+ ppr Inlinable = text "INLINABLE"+ ppr NoUserInlinePrag = empty +instance Binary InlineSpec where+ put_ bh NoUserInlinePrag = putByte bh 0+ put_ bh Inline = putByte bh 1+ put_ bh Inlinable = putByte bh 2+ put_ bh NoInline = putByte bh 3++ get bh = do h <- getByte bh+ case h of+ 0 -> return NoUserInlinePrag+ 1 -> return Inline+ 2 -> return Inlinable+ _ -> return NoInline++ instance Outputable InlinePragma where ppr = pprInline +instance Binary InlinePragma where+ put_ bh (InlinePragma s a b c d) = do+ put_ bh s+ put_ bh a+ put_ bh b+ put_ bh c+ put_ bh d++ get bh = do+ s <- get bh+ a <- get bh+ b <- get bh+ c <- get bh+ d <- get bh+ return (InlinePragma s a b c d)++ pprInline :: InlinePragma -> SDoc pprInline = pprInline' True @@ -1662,99 +1588,6 @@ | otherwise = ppr info --{- *********************************************************************-* *- Integer literals-* *-********************************************************************* -}---- | Integral Literal------ Used (instead of Integer) to represent negative zegative zero which is--- required for NegativeLiterals extension to correctly parse `-0::Double`--- as negative zero. See also #13211.-data IntegralLit- = IL { il_text :: SourceText- , il_neg :: Bool -- See Note [Negative zero]- , il_value :: Integer- }- deriving (Data, Show)--mkIntegralLit :: Integral a => a -> IntegralLit-mkIntegralLit i = IL { il_text = SourceText (show i_integer)- , il_neg = i < 0- , il_value = i_integer }- where- i_integer :: Integer- i_integer = toInteger i--negateIntegralLit :: IntegralLit -> IntegralLit-negateIntegralLit (IL text neg value)- = case text of- SourceText ('-':src) -> IL (SourceText src) False (negate value)- SourceText src -> IL (SourceText ('-':src)) True (negate value)- NoSourceText -> IL NoSourceText (not neg) (negate value)---- | Fractional Literal------ Used (instead of Rational) to represent exactly the floating point literal that we--- encountered in the user's source program. This allows us to pretty-print exactly what--- the user wrote, which is important e.g. for floating point numbers that can't represented--- as Doubles (we used to via Double for pretty-printing). See also #2245.-data FractionalLit- = FL { fl_text :: SourceText -- How the value was written in the source- , fl_neg :: Bool -- See Note [Negative zero]- , fl_value :: Rational -- Numeric value of the literal- }- deriving (Data, Show)- -- The Show instance is required for the derived GHC.Parser.Lexer.Token instance when DEBUG is on--mkFractionalLit :: Real a => a -> FractionalLit-mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))- -- Converting to a Double here may technically lose- -- precision (see #15502). We could alternatively- -- convert to a Rational for the most accuracy, but- -- it would cause Floats and Doubles to be displayed- -- strangely, so we opt not to do this. (In contrast- -- to mkIntegralLit, where we always convert to an- -- Integer for the highest accuracy.)- , fl_neg = r < 0- , fl_value = toRational r }--negateFractionalLit :: FractionalLit -> FractionalLit-negateFractionalLit (FL text neg value)- = case text of- SourceText ('-':src) -> FL (SourceText src) False value- SourceText src -> FL (SourceText ('-':src)) True value- NoSourceText -> FL NoSourceText (not neg) (negate value)--integralFractionalLit :: Bool -> Integer -> FractionalLit-integralFractionalLit neg i = FL { fl_text = SourceText (show i),- fl_neg = neg,- fl_value = fromInteger i }---- Comparison operations are needed when grouping literals--- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)--instance Eq IntegralLit where- (==) = (==) `on` il_value--instance Ord IntegralLit where- compare = compare `on` il_value--instance Outputable IntegralLit where- ppr (IL (SourceText src) _ _) = text src- ppr (IL NoSourceText _ value) = text (show value)--instance Eq FractionalLit where- (==) = (==) `on` fl_value--instance Ord FractionalLit where- compare = compare `on` fl_value--instance Outputable FractionalLit where- ppr f = pprWithSourceText (fl_text f) (rational (fl_value f)) {- ************************************************************************
+ compiler/GHC/Types/CompleteMatch.hs view
@@ -0,0 +1,17 @@+-- | COMPLETE signature+module GHC.Types.CompleteMatch+ ( CompleteMatch+ , CompleteMatches+ )+where++import GHC.Types.Unique.DSet+import GHC.Core.ConLike++-- | A list of conlikes which represents a complete pattern match.+-- These arise from @COMPLETE@ signatures.+-- See also Note [Implementation of COMPLETE pragmas].+type CompleteMatch = UniqDSet ConLike++type CompleteMatches = [CompleteMatch]+
compiler/GHC/Types/CostCentre.hs view
@@ -317,7 +317,7 @@ costCentreSrcSpan = cc_loc instance Binary CCFlavour where- put_ bh CafCC = do+ put_ bh CafCC = putByte bh 0 put_ bh (ExprCC i) = do putByte bh 1@@ -331,10 +331,10 @@ get bh = do h <- getByte bh case h of- 0 -> do return CafCC+ 0 -> return CafCC 1 -> ExprCC <$> get bh 2 -> DeclCC <$> get bh- _ -> HpcCC <$> get bh+ _ -> HpcCC <$> get bh instance Binary CostCentre where put_ bh (NormalCC aa ab ac _ad) = do
compiler/GHC/Types/Demand.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -5,9 +10,6 @@ \section[Demand]{@Demand@: A decoupled implementation of a demand domain} -} -{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Types.Demand ( StrDmd, UseDmd(..), Count, @@ -40,7 +42,7 @@ seqDemand, seqDemandList, seqDmdType, seqStrictSig, evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd,- splitDmdTy, splitFVs, deferAfterPreciseException,+ splitDmdTy, isWeakDmd, deferAfterPreciseException, postProcessUnsat, postProcessDmdType, splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds,@@ -794,22 +796,6 @@ cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u cleanUseDmd_maybe _ = Nothing -splitFVs :: Bool -- Thunk- -> DmdEnv -> (DmdEnv, DmdEnv)-splitFVs is_thunk rhs_fvs- | is_thunk = strictPairToTuple $- nonDetStrictFoldUFM_Directly add (emptyVarEnv :*: emptyVarEnv) rhs_fvs- -- It's OK to use a non-deterministic fold because we- -- immediately forget the ordering by putting the elements- -- in the envs again- | otherwise = partitionVarEnv isWeakDmd rhs_fvs- where- add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv :*: sig_fv)- | Lazy <- s = addToUFM_Directly lazy_fv uniq dmd :*: sig_fv- | otherwise = addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u })- :*:- addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs })- keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv -- (keepAliveDmdType dt vs) makes sure that the Ids in vs have -- /some/ usage in the returned demand types -- they are not Absent@@ -840,11 +826,6 @@ (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) _ -> Nothing -data StrictPair a b = !a :*: !b--strictPairToTuple :: StrictPair a b -> (a, b)-strictPairToTuple (x :*: y) = (x, y)- {- ********************************************************************* * * TypeShape and demand trimming@@ -1969,8 +1950,8 @@ -} instance Binary StrDmd where- put_ bh HyperStr = do putByte bh 0- put_ bh HeadStr = do putByte bh 1+ put_ bh HyperStr = putByte bh 0+ put_ bh HeadStr = putByte bh 1 put_ bh (SCall s) = do putByte bh 2 put_ bh s put_ bh (SProd sx) = do putByte bh 3@@ -1978,17 +1959,17 @@ get bh = do h <- getByte bh case h of- 0 -> do return HyperStr- 1 -> do return HeadStr+ 0 -> return HyperStr+ 1 -> return HeadStr 2 -> do s <- get bh return (SCall s) _ -> do sx <- get bh return (SProd sx) instance Binary ArgStr where- put_ bh Lazy = do+ put_ bh Lazy = putByte bh 0- put_ bh (Str s) = do+ put_ bh (Str s) = do putByte bh 1 put_ bh s @@ -2000,8 +1981,8 @@ return $ Str s instance Binary Count where- put_ bh One = do putByte bh 0- put_ bh Many = do putByte bh 1+ put_ bh One = putByte bh 0+ put_ bh Many = putByte bh 1 get bh = do h <- getByte bh case h of@@ -2009,9 +1990,9 @@ _ -> return Many instance Binary ArgUse where- put_ bh Abs = do+ put_ bh Abs = putByte bh 0- put_ bh (Use c u) = do+ put_ bh (Use c u) = do putByte bh 1 put_ bh c put_ bh u@@ -2020,16 +2001,14 @@ h <- getByte bh case h of 0 -> return Abs- _ -> do c <- get bh- u <- get bh- return $ Use c u+ _ -> Use <$> get bh <*> get bh instance Binary UseDmd where- put_ bh Used = do+ put_ bh Used = putByte bh 0- put_ bh UHead = do+ put_ bh UHead = putByte bh 1- put_ bh (UCall c u) = do+ put_ bh (UCall c u) = do putByte bh 2 put_ bh c put_ bh u@@ -2050,17 +2029,11 @@ instance (Binary s, Binary u) => Binary (JointDmd s u) where put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y- get bh = do- x <- get bh- y <- get bh- return $ JD { sd = x, ud = y }+ get bh = JD <$> get bh <*> get bh instance Binary StrictSig where- put_ bh (StrictSig aa) = do- put_ bh aa- get bh = do- aa <- get bh- return (StrictSig aa)+ put_ bh (StrictSig aa) = put_ bh aa+ get bh = StrictSig <$> get bh instance Binary DmdType where -- Ignore DmdEnv when spitting out the DmdType
+ compiler/GHC/Types/Error.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE LambdaCase #-}++module GHC.Types.Error+ ( Messages+ , WarningMessages+ , ErrorMessages+ , ErrMsg (..)+ , WarnMsg+ , ErrDoc (..)+ , MsgDoc+ , Severity (..)+ , unionMessages+ , errDoc+ , mapErrDoc+ , pprMessageBag+ , mkLocMessage+ , mkLocMessageAnn+ , getSeverityColour+ , getCaretDiagnostic+ , makeIntoWarning+ )+where++import GHC.Prelude++import GHC.Driver.Flags++import GHC.Data.Bag+import GHC.Utils.Outputable as Outputable+import qualified GHC.Utils.Ppr.Colour as Col+import GHC.Types.SrcLoc as SrcLoc+import GHC.Data.FastString (unpackFS)+import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)+import GHC.Utils.Json++import System.IO.Error ( catchIOError )++type Messages = (WarningMessages, ErrorMessages)+type WarningMessages = Bag WarnMsg+type ErrorMessages = Bag ErrMsg+type MsgDoc = SDoc+type WarnMsg = ErrMsg+++data ErrMsg = ErrMsg+ { errMsgSpan :: SrcSpan+ -- ^ The SrcSpan is used for sorting errors into line-number order+ , errMsgContext :: PrintUnqualified+ , errMsgDoc :: ErrDoc+ , errMsgShortString :: String+ -- ^ This has the same text as errDocImportant . errMsgDoc.+ , errMsgSeverity :: Severity+ , errMsgReason :: WarnReason+ }++-- | Categorise error msgs by their importance. This is so each section can+-- be rendered visually distinct. See Note [Error report] for where these come+-- from.+data ErrDoc = ErrDoc {+ -- | Primary error msg.+ errDocImportant :: [MsgDoc],+ -- | Context e.g. \"In the second argument of ...\".+ errDocContext :: [MsgDoc],+ -- | Supplementary information, e.g. \"Relevant bindings include ...\".+ errDocSupplementary :: [MsgDoc]+ }++unionMessages :: Messages -> Messages -> Messages+unionMessages (warns1, errs1) (warns2, errs2) =+ (warns1 `unionBags` warns2, errs1 `unionBags` errs2)++errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc+errDoc = ErrDoc++mapErrDoc :: (MsgDoc -> MsgDoc) -> ErrDoc -> ErrDoc+mapErrDoc f (ErrDoc a b c) = ErrDoc (map f a) (map f b) (map f c)++data Severity+ = SevOutput+ | SevFatal+ | SevInteractive++ | SevDump+ -- ^ Log message intended for compiler developers+ -- No file\/line\/column stuff++ | SevInfo+ -- ^ Log messages intended for end users.+ -- No file\/line\/column stuff.++ | SevWarning+ | SevError+ -- ^ SevWarning and SevError are used for warnings and errors+ -- o The message has a file\/line\/column heading,+ -- plus "warning:" or "error:",+ -- added by mkLocMessags+ -- o Output is intended for end users+ deriving Show+++instance ToJson Severity where+ json s = JSString (show s)++instance Show ErrMsg where+ show em = errMsgShortString em++pprMessageBag :: Bag MsgDoc -> SDoc+pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))++-- | Make an unannotated error message with location info.+mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc+mkLocMessage = mkLocMessageAnn Nothing++-- | Make a possibly annotated error message with location info.+mkLocMessageAnn+ :: Maybe String -- ^ optional annotation+ -> Severity -- ^ severity+ -> SrcSpan -- ^ location+ -> MsgDoc -- ^ message+ -> MsgDoc+ -- 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 "<no location info>".+mkLocMessageAnn ann severity locn msg+ = sdocOption sdocColScheme $ \col_scheme ->+ let locn' = sdocOption sdocErrorSpans $ \case+ True -> ppr locn+ False -> ppr (srcSpanStart locn)++ sevColour = getSeverityColour severity col_scheme++ -- Add optional information+ optAnn = case ann of+ Nothing -> text ""+ Just i -> text " [" <> coloured sevColour (text i) <> text "]"++ -- Add prefixes, like Foo.hs:34: warning:+ -- <the warning message>+ header = locn' <> colon <+>+ coloured sevColour sevText <> optAnn++ in coloured (Col.sMessage col_scheme)+ (hang (coloured (Col.sHeader col_scheme) header) 4+ msg)++ where+ sevText =+ case severity of+ SevWarning -> text "warning:"+ SevError -> text "error:"+ SevFatal -> text "fatal:"+ _ -> empty++getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour+getSeverityColour SevWarning = Col.sWarning+getSeverityColour SevError = Col.sError+getSeverityColour SevFatal = Col.sFatal+getSeverityColour _ = const mempty++getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc+getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty+getCaretDiagnostic severity (RealSrcSpan span _) =+ caretDiagnostic <$> getSrcLine (srcSpanFile span) row+ where+ getSrcLine fn i =+ getLine i (unpackFS fn)+ `catchIOError` \_ ->+ pure Nothing++ getLine i fn = do+ -- StringBuffer has advantages over readFile:+ -- (a) no lazy IO, otherwise IO exceptions may occur in pure code+ -- (b) always UTF-8, rather than some system-dependent encoding+ -- (Haskell source code must be UTF-8 anyway)+ content <- hGetStringBuffer fn+ case atLine i content of+ Just at_line -> pure $+ case lines (fix <$> lexemeToString at_line (len at_line)) of+ srcLine : _ -> Just srcLine+ _ -> Nothing+ _ -> pure Nothing++ -- allow user to visibly see that their code is incorrectly encoded+ -- (StringBuffer.nextChar uses \0 to represent undecodable characters)+ fix '\0' = '\xfffd'+ fix c = c++ row = srcSpanStartLine span+ rowStr = show row+ multiline = row /= srcSpanEndLine span++ caretDiagnostic Nothing = empty+ caretDiagnostic (Just srcLineWithNewline) =+ sdocOption sdocColScheme$ \col_scheme ->+ let sevColour = getSeverityColour severity col_scheme+ marginColour = Col.sMargin col_scheme+ in+ coloured marginColour (text marginSpace) <>+ text ("\n") <>+ coloured marginColour (text marginRow) <>+ text (" " ++ srcLinePre) <>+ coloured sevColour (text srcLineSpan) <>+ text (srcLinePost ++ "\n") <>+ coloured marginColour (text marginSpace) <>+ coloured sevColour (text (" " ++ caretLine))++ where++ -- expand tabs in a device-independent manner #13664+ expandTabs tabWidth i s =+ case s of+ "" -> ""+ '\t' : cs -> replicate effectiveWidth ' ' +++ expandTabs tabWidth (i + effectiveWidth) cs+ c : cs -> c : expandTabs tabWidth (i + 1) cs+ where effectiveWidth = tabWidth - i `mod` tabWidth++ srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline)++ start = srcSpanStartCol span - 1+ end | multiline = length srcLine+ | otherwise = srcSpanEndCol span - 1+ width = max 1 (end - start)++ marginWidth = length rowStr+ marginSpace = replicate marginWidth ' ' ++ " |"+ marginRow = rowStr ++ " |"++ (srcLinePre, srcLineRest) = splitAt start srcLine+ (srcLineSpan, srcLinePost) = splitAt width srcLineRest++ caretEllipsis | multiline = "..."+ | otherwise = ""+ caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis++makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg+makeIntoWarning reason err = err+ { errMsgSeverity = SevWarning+ , errMsgReason = reason }+
compiler/GHC/Types/FieldLabel.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE StandaloneDeriving #-}+ {- % % (c) Adam Gundry 2013-2015@@ -55,12 +59,6 @@ Of course, datatypes with no constructors cannot have any fields. -}--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE StandaloneDeriving #-} module GHC.Types.FieldLabel ( FieldLabelString
+ compiler/GHC/Types/Fixity.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Fixity+module GHC.Types.Fixity+ ( Fixity (..)+ , FixityDirection (..)+ , LexicalFixity (..)+ , maxPrecedence+ , minPrecedence+ , defaultFixity+ , negateFixity+ , funTyFixity+ , compareFixity+ )+where++import GHC.Prelude++import GHC.Types.SourceText++import GHC.Utils.Outputable+import GHC.Utils.Binary++import Data.Data hiding (Fixity, Prefix, Infix)++data Fixity = Fixity SourceText Int FixityDirection+ -- Note [Pragma source text]+ deriving Data++instance Outputable Fixity where+ ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec]++instance Eq Fixity where -- Used to determine if two fixities conflict+ (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2++instance Binary Fixity where+ put_ bh (Fixity src aa ab) = do+ put_ bh src+ put_ bh aa+ put_ bh ab+ get bh = do+ src <- get bh+ aa <- get bh+ ab <- get bh+ return (Fixity src aa ab)++------------------------+data FixityDirection+ = InfixL+ | InfixR+ | InfixN+ deriving (Eq, Data)++instance Outputable FixityDirection where+ ppr InfixL = text "infixl"+ ppr InfixR = text "infixr"+ ppr InfixN = text "infix"++instance Binary FixityDirection where+ put_ bh InfixL =+ putByte bh 0+ put_ bh InfixR =+ putByte bh 1+ put_ bh InfixN =+ putByte bh 2+ get bh = do+ h <- getByte bh+ case h of+ 0 -> return InfixL+ 1 -> return InfixR+ _ -> return InfixN++------------------------+maxPrecedence, minPrecedence :: Int+maxPrecedence = 9+minPrecedence = 0++defaultFixity :: Fixity+defaultFixity = Fixity NoSourceText maxPrecedence InfixL++negateFixity, funTyFixity :: Fixity+-- Wired-in fixities+negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate+funTyFixity = Fixity NoSourceText (-1) InfixR -- Fixity of '->', see #15235++{-+Consider++\begin{verbatim}+ a `op1` b `op2` c+\end{verbatim}+@(compareFixity op1 op2)@ tells which way to arrange application, or+whether there's an error.+-}++compareFixity :: Fixity -> Fixity+ -> (Bool, -- Error please+ Bool) -- Associate to the right: a op1 (b op2 c)+compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)+ = case prec1 `compare` prec2 of+ GT -> left+ LT -> right+ EQ -> case (dir1, dir2) of+ (InfixR, InfixR) -> right+ (InfixL, InfixL) -> left+ _ -> error_please+ where+ right = (False, True)+ left = (False, False)+ error_please = (True, False)++-- |Captures the fixity of declarations as they are parsed. This is not+-- necessarily the same as the fixity declaration, as the normal fixity may be+-- overridden using parens or backticks.+data LexicalFixity = Prefix | Infix deriving (Data,Eq)++instance Outputable LexicalFixity where+ ppr Prefix = text "Prefix"+ ppr Infix = text "Infix"
+ compiler/GHC/Types/Fixity/Env.hs view
@@ -0,0 +1,46 @@+module GHC.Types.Fixity.Env+ ( FixityEnv+ , FixItem (..)+ , emptyFixityEnv+ , lookupFixity+ , mkIfaceFixCache+ , emptyIfaceFixCache+ )+where++import GHC.Prelude++import GHC.Types.Fixity+import GHC.Types.Name+import GHC.Types.Name.Env++import GHC.Utils.Outputable++-- | Fixity environment mapping names to their fixities+type FixityEnv = NameEnv FixItem++-- | Fixity information for an 'Name'. We keep the OccName in the range+-- so that we can generate an interface from it+data FixItem = FixItem OccName Fixity++instance Outputable FixItem where+ ppr (FixItem occ fix) = ppr fix <+> ppr occ++emptyFixityEnv :: FixityEnv+emptyFixityEnv = emptyNameEnv++lookupFixity :: FixityEnv -> Name -> Fixity+lookupFixity env n = case lookupNameEnv env n of+ Just (FixItem _ fix) -> fix+ Nothing -> defaultFixity++-- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface'+mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity+mkIfaceFixCache pairs+ = \n -> lookupOccEnv env n+ where+ env = mkOccEnv pairs++emptyIfaceFixCache :: OccName -> Maybe Fixity+emptyIfaceFixCache _ = Nothing+
compiler/GHC/Types/ForeignCall.hs view
@@ -25,7 +25,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Unit.Module-import GHC.Types.Basic ( SourceText, pprWithSourceText )+import GHC.Types.SourceText ( SourceText, pprWithSourceText ) import Data.Char import Data.Data@@ -99,7 +99,7 @@ data CExportSpec = CExportStatic -- foreign export ccall foo :: ty SourceText -- of the CLabelString.- -- See note [Pragma source text] in GHC.Types.Basic+ -- See note [Pragma source text] in GHC.Types.SourceText CLabelString -- C Name of exported function CCallConv deriving Data@@ -117,7 +117,7 @@ -- An "unboxed" ccall# to named function in a particular package. = StaticTarget SourceText -- of the CLabelString.- -- See note [Pragma source text] in GHC.Types.Basic+ -- See note [Pragma source text] in GHC.Types.SourceText CLabelString -- C-land name of label. (Maybe Unit) -- What package the function is in.@@ -226,7 +226,7 @@ = text "__dyn_ccall" <> gc_suf <+> text "\"\"" -- The filename for a C header file--- Note [Pragma source text] in GHC.Types.Basic+-- Note [Pragma source text] in GHC.Types.SourceText data Header = Header SourceText FastString deriving (Eq, Data) @@ -240,7 +240,7 @@ -- 'GHC.Parser.Annotation.AnnClose' @'\#-}'@, -- For details on above see note [Api annotations] in "GHC.Parser.Annotation"-data CType = CType SourceText -- Note [Pragma source text] in GHC.Types.Basic+data CType = CType SourceText -- Note [Pragma source text] in GHC.Types.SourceText (Maybe Header) -- header to include for this type (SourceText,FastString) -- the type itself deriving (Eq, Data)@@ -266,18 +266,18 @@ get bh = do aa <- get bh; return (CCall aa) instance Binary Safety where- put_ bh PlaySafe = do+ put_ bh PlaySafe = putByte bh 0- put_ bh PlayInterruptible = do+ put_ bh PlayInterruptible = putByte bh 1- put_ bh PlayRisky = do+ put_ bh PlayRisky = putByte bh 2 get bh = do h <- getByte bh case h of- 0 -> do return PlaySafe- 1 -> do return PlayInterruptible- _ -> do return PlayRisky+ 0 -> return PlaySafe+ 1 -> return PlayInterruptible+ _ -> return PlayRisky instance Binary CExportSpec where put_ bh (CExportStatic ss aa ab) = do@@ -308,7 +308,7 @@ put_ bh aa put_ bh ab put_ bh ac- put_ bh DynamicTarget = do+ put_ bh DynamicTarget = putByte bh 1 get bh = do h <- getByte bh@@ -318,27 +318,27 @@ ab <- get bh ac <- get bh return (StaticTarget ss aa ab ac)- _ -> do return DynamicTarget+ _ -> return DynamicTarget instance Binary CCallConv where- put_ bh CCallConv = do+ put_ bh CCallConv = putByte bh 0- put_ bh StdCallConv = do+ put_ bh StdCallConv = putByte bh 1- put_ bh PrimCallConv = do+ put_ bh PrimCallConv = putByte bh 2- put_ bh CApiConv = do+ put_ bh CApiConv = putByte bh 3- put_ bh JavaScriptCallConv = do+ put_ bh JavaScriptCallConv = putByte bh 4 get bh = do h <- getByte bh case h of- 0 -> do return CCallConv- 1 -> do return StdCallConv- 2 -> do return PrimCallConv- 3 -> do return CApiConv- _ -> do return JavaScriptCallConv+ 0 -> return CCallConv+ 1 -> return StdCallConv+ 2 -> return PrimCallConv+ 3 -> return CApiConv+ _ -> return JavaScriptCallConv instance Binary CType where put_ bh (CType s mh fs) = do put_ bh s
+ compiler/GHC/Types/ForeignStubs.hs view
@@ -0,0 +1,25 @@+-- | Foreign export stubs+module GHC.Types.ForeignStubs+ ( ForeignStubs (..)+ , appendStubC+ )+where++import GHC.Utils.Outputable++-- | Foreign export stubs+data ForeignStubs+ = NoStubs+ -- ^ We don't have any stubs+ | ForeignStubs SDoc SDoc+ -- ^ There are some stubs. Parameters:+ --+ -- 1) Header file prototypes for+ -- "foreign exported" functions+ --+ -- 2) C stubs to use when calling+ -- "foreign exported" functions++appendStubC :: ForeignStubs -> SDoc -> ForeignStubs+appendStubC NoStubs c_code = ForeignStubs empty c_code+appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code)
+ compiler/GHC/Types/HpcInfo.hs view
@@ -0,0 +1,34 @@+-- | Haskell Program Coverage (HPC) support+module GHC.Types.HpcInfo+ ( HpcInfo (..)+ , AnyHpcUsage+ , emptyHpcInfo+ , isHpcUsed+ )+where++import GHC.Prelude++-- | Information about a modules use of Haskell Program Coverage+data HpcInfo+ = HpcInfo+ { hpcInfoTickCount :: Int+ , hpcInfoHash :: Int+ }+ | NoHpcInfo+ { hpcUsed :: AnyHpcUsage -- ^ Is hpc used anywhere on the module \*tree\*?+ }++-- | This is used to signal if one of my imports used HPC instrumentation+-- even if there is no module-local HPC usage+type AnyHpcUsage = Bool++emptyHpcInfo :: AnyHpcUsage -> HpcInfo+emptyHpcInfo = NoHpcInfo++-- | Find out if HPC is used by this module or any of the modules+-- it depends upon+isHpcUsed :: HpcInfo -> AnyHpcUsage+isHpcUsed (HpcInfo {}) = True+isHpcUsed (NoHpcInfo { hpcUsed = used }) = used+
compiler/GHC/Types/Id.hs view
@@ -46,6 +46,7 @@ -- ** Taking an Id apart idName, idType, idMult, idScaledType, idUnique, idInfo, idDetails, recordSelectorTyCon,+ recordSelectorTyCon_maybe, -- ** Modifying an Id setIdName, setIdUnique, GHC.Types.Id.setIdType, setIdMult,@@ -438,10 +439,15 @@ -- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise. recordSelectorTyCon :: Id -> RecSelParent recordSelectorTyCon id- = case Var.idDetails id of- RecSelId { sel_tycon = parent } -> parent+ = case recordSelectorTyCon_maybe id of+ Just parent -> parent _ -> panic "recordSelectorTyCon" +recordSelectorTyCon_maybe :: Id -> Maybe RecSelParent+recordSelectorTyCon_maybe id+ = case Var.idDetails id of+ RecSelId { sel_tycon = parent } -> Just parent+ _ -> Nothing isRecordSelector :: Id -> Bool isNaughtyRecordSelector :: Id -> Bool
compiler/GHC/Types/Id/Make.hs view
@@ -57,6 +57,7 @@ import GHC.Core.Unfold.Make import GHC.Core.SimpleOpt import GHC.Types.Literal+import GHC.Types.SourceText import GHC.Core.TyCon import GHC.Core.Class import GHC.Types.Name.Set@@ -68,6 +69,7 @@ import GHC.Types.Id.Info import GHC.Types.Demand import GHC.Types.Cpr+import GHC.Types.TyThing import GHC.Core import GHC.Types.Unique import GHC.Builtin.Uniques@@ -1564,7 +1566,7 @@ a) Its fixity is set in GHC.Iface.Load.ghcPrimIface b) It has quite a bit of desugaring magic.- See GHC.HsToCore.Utils Note [Desugaring seq (1)] and (2) and (3)+ See GHC.HsToCore.Utils Note [Desugaring seq] (1) and (2) and (3) c) There is some special rule handing: Note [User-defined RULES for seq] @@ -1748,7 +1750,7 @@ f (x `cast` co a) y The `co` coercion is the newtype-coercion extracted from the type-class.-The type class is obtain by looking at the type of wrap.+The type class is obtained by looking at the type of wrap. -------------------------------------------------------------
compiler/GHC/Types/Literal.hs view
@@ -36,7 +36,7 @@ , inCharRange , isZeroLit , litFitsInChar- , litValue, isLitValue, isLitValue_maybe, mapLitValue+ , litValue, mapLitValue -- ** Coercions , wordToIntLit, intToWordLit@@ -71,7 +71,6 @@ import Data.Int import Data.Word import Data.Char-import Data.Maybe ( isJust ) import Data.Data ( Data ) import Data.Proxy import Numeric ( fromRat )@@ -208,7 +207,7 @@ instance Binary Literal where put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa put_ bh (LitString ab) = do putByte bh 1; put_ bh ab- put_ bh (LitNullAddr) = do putByte bh 2+ put_ bh (LitNullAddr) = putByte bh 2 put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai put_ bh (LitLabel aj mb fod)@@ -220,7 +219,7 @@ = do putByte bh 6 put_ bh nt put_ bh i- put_ bh (LitRubbish) = do putByte bh 7+ put_ bh (LitRubbish) = putByte bh 7 get bh = do h <- getByte bh case h of@@ -230,8 +229,7 @@ 1 -> do ab <- get bh return (LitString ab)- 2 -> do- return (LitNullAddr)+ 2 -> return (LitNullAddr) 3 -> do ah <- get bh return (LitFloat ah)@@ -247,8 +245,7 @@ nt <- get bh i <- get bh return (LitNumber nt i)- _ -> do- return (LitRubbish)+ _ -> return (LitRubbish) instance Outputable Literal where ppr = pprLiteral id@@ -462,11 +459,6 @@ mapLitValue platform f (LitNumber nt i) = wrapLitNumber platform (LitNumber nt (f i)) mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) --- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',--- 'Int', 'Word', 'LitInteger' and 'LitNatural'.-isLitValue :: Literal -> Bool-isLitValue = isJust . isLitValue_maybe- {- Coercions ~~~~~~~~~@@ -646,6 +638,7 @@ -- 2. This would need to return a type application to a literal absentLiteralOf tc = lookupUFM absent_lits tc +-- We do not use TyConEnv here to avoid import cycles. absent_lits :: UniqFM TyCon Literal absent_lits = listToUFM_Directly -- Explicitly construct the mape from the known
+ compiler/GHC/Types/Meta.hs view
@@ -0,0 +1,53 @@+-- | Metaprogramming types+module GHC.Types.Meta+ ( MetaRequest(..)+ , MetaHook+ , MetaResult -- data constructors not exported to ensure correct response type+ , metaRequestE+ , metaRequestP+ , metaRequestT+ , metaRequestD+ , metaRequestAW+ )+where++import GHC.Prelude++import GHC.Serialized ( Serialized )++import GHC.Hs+++-- | The supported metaprogramming result types+data MetaRequest+ = MetaE (LHsExpr GhcPs -> MetaResult)+ | MetaP (LPat GhcPs -> MetaResult)+ | MetaT (LHsType GhcPs -> MetaResult)+ | MetaD ([LHsDecl GhcPs] -> MetaResult)+ | MetaAW (Serialized -> MetaResult)++-- | data constructors not exported to ensure correct result type+data MetaResult+ = MetaResE { unMetaResE :: LHsExpr GhcPs }+ | MetaResP { unMetaResP :: LPat GhcPs }+ | MetaResT { unMetaResT :: LHsType GhcPs }+ | MetaResD { unMetaResD :: [LHsDecl GhcPs] }+ | MetaResAW { unMetaResAW :: Serialized }++type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult++metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs)+metaRequestE h = fmap unMetaResE . h (MetaE MetaResE)++metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs)+metaRequestP h = fmap unMetaResP . h (MetaP MetaResP)++metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs)+metaRequestT h = fmap unMetaResT . h (MetaT MetaResT)++metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs]+metaRequestD h = fmap unMetaResD . h (MetaD MetaResD)++metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized+metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW)+
compiler/GHC/Types/Name.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -5,11 +9,6 @@ \section[Name]{@Name@: to transmit name info from renamer to typechecker} -} -{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternSynonyms #-}- -- | -- #name_types# -- GHC uses several kinds of name internally:@@ -82,7 +81,7 @@ import GHC.Prelude -import {-# SOURCE #-} GHC.Core.TyCo.Rep( TyThing )+import {-# SOURCE #-} GHC.Types.TyThing ( TyThing ) import GHC.Platform import GHC.Types.Name.Occurrence@@ -309,7 +308,7 @@ -- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come -- from the magic 'interactive' package; and all the details are kept in the -- TcLclEnv, TcGblEnv, NOT in the HPT or EPT.--- See Note [The interactive package] in "GHC.Driver.Types"+-- See Note [The interactive package] in "GHC.Runtime.Context" nameIsLocalOrFrom from name | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod@@ -625,7 +624,7 @@ pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc -- Print the "M." part of a name, based on whether it's in scope or not--- See Note [Printing original names] in GHC.Driver.Types+-- 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
compiler/GHC/Types/Name/Occurrence.hs view
@@ -52,6 +52,7 @@ mkDFunOcc, setOccNameSpace, demoteOccName,+ promoteOccName, HasOccName(..), -- ** Derived 'OccName's@@ -208,13 +209,21 @@ -- demoteNameSpace lowers the NameSpace if possible. We can not know -- in advance, since a TvName can appear in an HsTyVar.--- See Note [Demotion] in GHC.Rename.Env+-- See Note [Demotion] in GHC.Rename.Env. demoteNameSpace :: NameSpace -> Maybe NameSpace demoteNameSpace VarName = Nothing demoteNameSpace DataName = Nothing demoteNameSpace TvName = Nothing demoteNameSpace TcClsName = Just DataName +-- promoteNameSpace promotes the NameSpace as follows.+-- See Note [Promotion] in GHC.Rename.Env.+promoteNameSpace :: NameSpace -> Maybe NameSpace+promoteNameSpace DataName = Just TcClsName+promoteNameSpace VarName = Just TvName+promoteNameSpace TcClsName = Nothing+promoteNameSpace TvName = Nothing+ {- ************************************************************************ * *@@ -336,12 +345,19 @@ mkClsOccFS = mkOccNameFS clsName -- demoteOccName lowers the Namespace of OccName.--- see Note [Demotion]+-- See Note [Demotion] in GHC.Rename.Env. demoteOccName :: OccName -> Maybe OccName demoteOccName (OccName space name) = do space' <- demoteNameSpace space return $ OccName space' name +-- promoteOccName promotes the NameSpace of OccName.+-- See Note [Promotion] in GHC.Rename.Env.+promoteOccName :: OccName -> Maybe OccName+promoteOccName (OccName space name) = do+ space' <- promoteNameSpace space+ return $ OccName space' name+ -- Name spaces are related if there is a chance to mean the one when one writes -- the other, i.e. variables <-> data constructors and type variables <-> type constructors nameSpacesRelated :: NameSpace -> NameSpace -> Bool@@ -890,21 +906,21 @@ -} instance Binary NameSpace where- put_ bh VarName = do+ put_ bh VarName = putByte bh 0- put_ bh DataName = do+ put_ bh DataName = putByte bh 1- put_ bh TvName = do+ put_ bh TvName = putByte bh 2- put_ bh TcClsName = do+ put_ bh TcClsName = putByte bh 3 get bh = do h <- getByte bh case h of- 0 -> do return VarName- 1 -> do return DataName- 2 -> do return TvName- _ -> do return TcClsName+ 0 -> return VarName+ 1 -> return DataName+ 2 -> return TvName+ _ -> return TcClsName instance Binary OccName where put_ bh (OccName aa ab) = do
+ compiler/GHC/Types/Name/Ppr.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE CPP #-}++module GHC.Types.Name.Ppr+ ( mkPrintUnqualified+ , mkQualModule+ , mkQualPackage+ , pkgQual+ )+where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Unit+import GHC.Unit.State++import GHC.Core.TyCon++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+++{-+Note [Printing original names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Deciding how to print names is pretty tricky. We are given a name+P:M.T, where P is the package name, M is the defining module, and T is+the occurrence name, and we have to decide in which form to display+the name given a GlobalRdrEnv describing the current scope.++Ideally we want to display the name in the form in which it is in+scope. However, the name might not be in scope at all, and that's+where it gets tricky. Here are the cases:++ 1. T uniquely maps to P:M.T ---> "T" NameUnqual+ 2. There is an X for which X.T+ uniquely maps to P:M.T ---> "X.T" NameQual X+ 3. There is no binding for "M.T" ---> "M.T" NameNotInScope1+ 4. Otherwise ---> "P:M.T" NameNotInScope2++(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at+all. In these cases we still want to refer to the name as "M.T", *but*+"M.T" might mean something else in the current scope (e.g. if there's+an "import X as M"), so to avoid confusion we avoid using "M.T" if+there's already a binding for it. Instead we write P:M.T.++There's one further subtlety: in case (3), what if there are two+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+the (ppr mod) of case (3), in Name.pprModulePrefix++Note [Printing unit ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the old days, original names were tied to PackageIds, which directly+corresponded to the entities that users wrote in Cabal files, and were perfectly+suitable for printing when we need to disambiguate packages. However, with+instantiated units, the situation can be different: if the key is instantiated+with some holes, we should try to give the user some more useful information.+-}++-- | Creates some functions that work out the best ways to format+-- names for the user according to a set of heuristics.+mkPrintUnqualified :: UnitState -> HomeUnit -> GlobalRdrEnv -> PrintUnqualified+mkPrintUnqualified unit_state home_unit env+ = QueryQualify qual_name+ (mkQualModule unit_state home_unit)+ (mkQualPackage unit_state)+ where+ qual_name mod occ+ | [gre] <- unqual_gres+ , right_name gre+ = NameUnqual -- If there's a unique entity that's in scope+ -- unqualified with 'occ' AND that entity is+ -- the right one, then we can use the unqualified name++ | [] <- unqual_gres+ , any is_name forceUnqualNames+ , not (isDerivedOccName occ)+ = NameUnqual -- Don't qualify names that come from modules+ -- that come with GHC, often appear in error messages,+ -- but aren't typically in scope. Doing this does not+ -- cause ambiguity, and it reduces the amount of+ -- qualification in error messages thus improving+ -- readability.+ --+ -- A motivating example is 'Constraint'. It's often not+ -- in scope, but printing GHC.Prim.Constraint seems+ -- overkill.++ | [gre] <- qual_gres+ = NameQual (greQualModName gre)++ | null qual_gres+ = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env)+ then NameNotInScope1+ else NameNotInScope2++ | otherwise+ = NameNotInScope1 -- Can happen if 'f' is bound twice in the module+ -- Eg f = True; g = 0; f = False+ where+ is_name :: Name -> Bool+ is_name name = ASSERT2( isExternalName name, ppr name )+ nameModule name == mod && nameOccName name == occ++ forceUnqualNames :: [Name]+ forceUnqualNames =+ map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ]+ ++ [ eqTyConName ]++ right_name gre = nameModule_maybe (gre_name gre) == Just mod++ unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env+ qual_gres = filter right_name (lookupGlobalRdrEnv env occ)++ -- we can mention a module P:M without the P: qualifier iff+ -- "import M" would resolve unambiguously to P:M. (if P is the+ -- current package we can just assume it is unqualified).++-- | Creates a function for formatting modules based on two heuristics:+-- (1) if the module is the current module, don't qualify, and (2) if there+-- is only one exposed package which exports this module, don't qualify.+mkQualModule :: UnitState -> HomeUnit -> QueryQualifyModule+mkQualModule unit_state home_unit mod+ | isHomeModule home_unit mod = False++ | [(_, pkgconfig)] <- lookup,+ mkUnit pkgconfig == moduleUnit mod+ -- this says: we are given a module P:M, is there just one exposed package+ -- that exposes a module M, and is it package P?+ = False++ | otherwise = True+ where lookup = lookupModuleInAllUnits unit_state (moduleName mod)++-- | Creates a function for formatting packages based on two heuristics:+-- (1) don't qualify if the package in question is "main", and (2) only qualify+-- with a unit id if the package ID would be ambiguous.+mkQualPackage :: UnitState -> QueryQualifyPackage+mkQualPackage pkgs uid+ | uid == mainUnit || uid == interactiveUnit+ -- Skip the lookup if it's main, since it won't be in the package+ -- database!+ = False+ | Just pkgid <- mb_pkgid+ , searchPackageId pkgs pkgid `lengthIs` 1+ -- this says: we are given a package pkg-0.1@MMM, are there only one+ -- exposed packages whose package ID is pkg-0.1?+ = False+ | otherwise+ = True+ where mb_pkgid = fmap unitPackageId (lookupUnit pkgs uid)++-- | A function which only qualifies package names if necessary; but+-- qualifies all other identifiers.+pkgQual :: UnitState -> PrintUnqualified+pkgQual pkgs = alwaysQualify { queryQualifyPackage = mkQualPackage pkgs }
compiler/GHC/Types/Name/Reader.hs view
@@ -32,7 +32,7 @@ nameRdrName, getRdrName, -- ** Destruction- rdrNameOcc, rdrNameSpace, demoteRdrName,+ rdrNameOcc, rdrNameSpace, demoteRdrName, promoteRdrName, isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, @@ -65,7 +65,10 @@ importSpecLoc, importSpecModule, isExplicitItem, bestImport, -- * Utils for StarIsType- starInfo+ starInfo,++ -- * Utils+ opIsAt, ) where #include "GhclibHsVersions.h"@@ -179,13 +182,21 @@ rdrNameSpace = occNameSpace . rdrNameOcc -- demoteRdrName lowers the NameSpace of RdrName.--- see Note [Demotion] in GHC.Types.Name.Occurrence+-- See Note [Demotion] in GHC.Rename.Env demoteRdrName :: RdrName -> Maybe RdrName demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) demoteRdrName (Orig _ _) = Nothing demoteRdrName (Exact _) = Nothing +-- promoteRdrName promotes the NameSpace of RdrName.+-- See Note [Promotion] in GHC.Rename.Env.+promoteRdrName :: RdrName -> Maybe RdrName+promoteRdrName (Unqual occ) = fmap Unqual (promoteOccName occ)+promoteRdrName (Qual m occ) = fmap (Qual m) (promoteOccName occ)+promoteRdrName (Orig _ _) = Nothing+promoteRdrName (Exact _) = Nothing+ -- These two are the basic constructors mkRdrUnqual :: OccName -> RdrName mkRdrUnqual occ = Unqual occ@@ -948,18 +959,17 @@ -- see 'GHC.Tc.Gen.Export.exports_from_avail' pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres +-- | isBuiltInSyntax filter out names for built-in syntax They+-- just clutter up the environment (esp tuples), and the+-- parser will generate Exact RdrNames for them, so the+-- cluttered envt is no use. Really, it's only useful for+-- GHC.Base and GHC.Tuple. pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) pickBothGRE mod gre@(GRE { gre_name = n }) | isBuiltInSyntax n = Nothing | Just gre1 <- pickQualGRE mod gre , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) | otherwise = Nothing- where- -- isBuiltInSyntax filter out names for built-in syntax They- -- just clutter up the environment (esp tuples), and the- -- parser will generate Exact RdrNames for them, so the- -- cluttered envt is no use. Really, it's only useful for- -- GHC.Base and GHC.Tuple. -- Building GlobalRdrEnvs @@ -1050,7 +1060,7 @@ So when we add `x = True` we must not delete the `M.x` from the `GlobalRdrEnv`; rather we just want to make it "qualified only"; hence the `mk_fake-imp_spec` in `shadowName`. See also Note- [Interactively-bound Ids in GHCi] in GHC.Driver.Types+ [Interactively-bound Ids in GHCi] in GHC.Runtime.Context - Data types also have External Names, like Ghci4.T; but we still want 'T' to mean the newly-declared 'T', not an old one.@@ -1334,7 +1344,7 @@ -- (b) it is always in scope -- (c) it is a synonym for Data.Kind.Type ----- However, the user might not know that he's working on a module with+-- However, the user might not know that they are working on a module with -- NoStarIsType and write code that still assumes (a), (b), and (c), which -- actually do not hold in that module. --@@ -1402,3 +1412,7 @@ = let fs = occNameFS occName in fs == fsLit "*" || fs == fsLit "★" | otherwise = False++-- | Indicate if the given name is the "@" operator+opIsAt :: RdrName -> Bool+opIsAt e = e == mkUnqual varName (fsLit "@")
compiler/GHC/Types/RepType.hs view
@@ -30,6 +30,7 @@ import GHC.Builtin.Names import GHC.Core.Coercion import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk import GHC.Core.TyCo.Rep import GHC.Core.Type import GHC.Builtin.Types.Prim
+ compiler/GHC/Types/SafeHaskell.hs view
@@ -0,0 +1,86 @@+-- | This stuff here is related to supporting the Safe Haskell extension,+-- primarily about storing under what trust type a module has been compiled.+module GHC.Types.SafeHaskell+ ( IsSafeImport+ , SafeHaskellMode(..)+ , IfaceTrustInfo+ , getSafeMode+ , setSafeMode+ , noIfaceTrustInfo+ )+where++import GHC.Prelude++import GHC.Utils.Binary+import GHC.Utils.Outputable++import Data.Word+++-- | Is an import a safe import?+type IsSafeImport = Bool++-- | The various Safe Haskell modes+data SafeHaskellMode+ = Sf_None -- ^ inferred unsafe+ | Sf_Unsafe -- ^ declared and checked+ | Sf_Trustworthy -- ^ declared and checked+ | Sf_Safe -- ^ declared and checked+ | Sf_SafeInferred -- ^ inferred as safe+ | Sf_Ignore -- ^ @-fno-safe-haskell@ state+ deriving (Eq)++instance Show SafeHaskellMode where+ show Sf_None = "None"+ show Sf_Unsafe = "Unsafe"+ show Sf_Trustworthy = "Trustworthy"+ show Sf_Safe = "Safe"+ show Sf_SafeInferred = "Safe-Inferred"+ show Sf_Ignore = "Ignore"++instance Outputable SafeHaskellMode where+ ppr = text . show++-- | Safe Haskell information for 'ModIface'+-- Simply a wrapper around SafeHaskellMode to sepperate iface and flags+newtype IfaceTrustInfo = TrustInfo SafeHaskellMode++getSafeMode :: IfaceTrustInfo -> SafeHaskellMode+getSafeMode (TrustInfo x) = x++setSafeMode :: SafeHaskellMode -> IfaceTrustInfo+setSafeMode = TrustInfo++noIfaceTrustInfo :: IfaceTrustInfo+noIfaceTrustInfo = setSafeMode Sf_None++trustInfoToNum :: IfaceTrustInfo -> Word8+trustInfoToNum it+ = case getSafeMode it of+ Sf_None -> 0+ Sf_Unsafe -> 1+ Sf_Trustworthy -> 2+ Sf_Safe -> 3+ Sf_SafeInferred -> 4+ Sf_Ignore -> 0++numToTrustInfo :: Word8 -> IfaceTrustInfo+numToTrustInfo 0 = setSafeMode Sf_None+numToTrustInfo 1 = setSafeMode Sf_Unsafe+numToTrustInfo 2 = setSafeMode Sf_Trustworthy+numToTrustInfo 3 = setSafeMode Sf_Safe+numToTrustInfo 4 = setSafeMode Sf_SafeInferred+numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")"++instance Outputable IfaceTrustInfo where+ ppr (TrustInfo Sf_None) = text "none"+ ppr (TrustInfo Sf_Ignore) = text "none"+ ppr (TrustInfo Sf_Unsafe) = text "unsafe"+ ppr (TrustInfo Sf_Trustworthy) = text "trustworthy"+ ppr (TrustInfo Sf_Safe) = text "safe"+ ppr (TrustInfo Sf_SafeInferred) = text "safe-inferred"++instance Binary IfaceTrustInfo where+ put_ bh iftrust = putByte bh $ trustInfoToNum iftrust+ get bh = getByte bh >>= (return . numToTrustInfo)
+ compiler/GHC/Types/SourceError.hs view
@@ -0,0 +1,64 @@+-- | Source errors+module GHC.Types.SourceError+ ( SourceError (..)+ , mkSrcErr+ , srcErrorMessages+ , throwErrors+ , throwOneError+ , handleSourceError+ )+where++import GHC.Prelude+import GHC.Data.Bag+import GHC.Types.Error+import GHC.Utils.Monad+import GHC.Utils.Panic+import GHC.Utils.Exception++import Control.Monad.Catch as MC (MonadCatch, catch)++mkSrcErr :: ErrorMessages -> SourceError+mkSrcErr = SourceError++srcErrorMessages :: SourceError -> ErrorMessages+srcErrorMessages (SourceError msgs) = msgs++throwErrors :: MonadIO io => ErrorMessages -> io a+throwErrors = liftIO . throwIO . mkSrcErr++throwOneError :: MonadIO io => ErrMsg -> io a+throwOneError = throwErrors . unitBag++-- | A source error is an error that is caused by one or more errors in the+-- source code. A 'SourceError' is thrown by many functions in the+-- compilation pipeline. Inside GHC these errors are merely printed via+-- 'log_action', but API clients may treat them differently, for example,+-- insert them into a list box. If you want the default behaviour, use the+-- idiom:+--+-- > handleSourceError printExceptionAndWarnings $ do+-- > ... api calls that may fail ...+--+-- The 'SourceError's error messages can be accessed via 'srcErrorMessages'.+-- This list may be empty if the compiler failed due to @-Werror@+-- ('Opt_WarnIsError').+--+-- See 'printExceptionAndWarnings' for more information on what to take care+-- of when writing a custom error handler.+newtype SourceError = SourceError ErrorMessages++instance Show SourceError where+ show (SourceError msgs) = unlines . map show . bagToList $ msgs++instance Exception SourceError++-- | Perform the given action and call the exception handler if the action+-- throws a 'SourceError'. See 'SourceError' for more information.+handleSourceError :: (MonadCatch m) =>+ (SourceError -> m a) -- ^ exception handler+ -> m a -- ^ action to perform+ -> m a+handleSourceError handler act =+ MC.catch act (\(e :: SourceError) -> handler e)+
+ compiler/GHC/Types/SourceFile.hs view
@@ -0,0 +1,94 @@+module GHC.Types.SourceFile+ ( HscSource(..)+ , SourceModified (..)+ , isHsBootOrSig+ , isHsigFile+ , hscSourceString+ )+where++import GHC.Prelude+import GHC.Utils.Binary++-- Note [HscSource types]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- There are three types of source file for Haskell code:+--+-- * HsSrcFile is an ordinary hs file which contains code,+--+-- * HsBootFile is an hs-boot file, which is used to break+-- recursive module imports (there will always be an+-- HsSrcFile associated with it), and+--+-- * HsigFile is an hsig file, which contains only type+-- signatures and is used to specify signatures for+-- modules.+--+-- Syntactically, hs-boot files and hsig files are quite similar: they+-- only include type signatures and must be associated with an+-- actual HsSrcFile. isHsBootOrSig allows us to abstract over code+-- which is indifferent to which. However, there are some important+-- differences, mostly owing to the fact that hsigs are proper+-- modules (you `import Sig` directly) whereas HsBootFiles are+-- temporary placeholders (you `import {-# SOURCE #-} Mod).+-- When we finish compiling the true implementation of an hs-boot,+-- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the+-- other hand, is never replaced (in particular, we *cannot* use the+-- HomeModInfo of the original HsSrcFile backing the signature, since it+-- will export too many symbols.)+--+-- Additionally, while HsSrcFile is the only Haskell file+-- which has *code*, we do generate .o files for HsigFile, because+-- this is how the recompilation checker figures out if a file+-- needs to be recompiled. These are fake object files which+-- should NOT be linked against.++data HscSource+ = HsSrcFile -- ^ .hs file+ | HsBootFile -- ^ .hs-boot file+ | HsigFile -- ^ .hsig file+ deriving (Eq, Ord, Show)++instance Binary HscSource where+ put_ bh HsSrcFile = putByte bh 0+ put_ bh HsBootFile = putByte bh 1+ put_ bh HsigFile = putByte bh 2+ get bh = do+ h <- getByte bh+ case h of+ 0 -> return HsSrcFile+ 1 -> return HsBootFile+ _ -> return HsigFile++hscSourceString :: HscSource -> String+hscSourceString HsSrcFile = ""+hscSourceString HsBootFile = "[boot]"+hscSourceString HsigFile = "[sig]"++-- See Note [HscSource types]+isHsBootOrSig :: HscSource -> Bool+isHsBootOrSig HsBootFile = True+isHsBootOrSig HsigFile = True+isHsBootOrSig _ = False++isHsigFile :: HscSource -> Bool+isHsigFile HsigFile = True+isHsigFile _ = False++-- | Indicates whether a given module's source has been modified since it+-- was last compiled.+data SourceModified+ = SourceModified+ -- ^ the source has been modified+ | SourceUnmodified+ -- ^ the source has not been modified. Compilation may or may+ -- not be necessary, depending on whether any dependencies have+ -- changed since we last compiled.+ | SourceUnmodifiedAndStable+ -- ^ the source has not been modified, and furthermore all of+ -- its (transitive) dependencies are up to date; it definitely+ -- does not need to be recompiled. This is important for two+ -- reasons: (a) we can omit the version check in checkOldIface,+ -- and (b) if the module used TH splices we don't need to force+ -- recompilation.+
+ compiler/GHC/Types/SourceText.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Source text+--+-- Keeping Source Text for source to source conversions+--+module GHC.Types.SourceText+ ( SourceText (..)+ , pprWithSourceText++ -- * Literals+ , IntegralLit(..)+ , FractionalLit(..)+ , StringLiteral(..)+ , negateIntegralLit+ , negateFractionalLit+ , mkIntegralLit+ , mkFractionalLit+ , integralFractionalLit+ )+where++import GHC.Prelude++import GHC.Data.FastString++import GHC.Utils.Outputable+import GHC.Utils.Binary+import GHC.Utils.Panic++import Data.Function (on)+import Data.Data++{-+Note [Pragma source text]+~~~~~~~~~~~~~~~~~~~~~~~~~+The lexer does a case-insensitive match for pragmas, as well as+accepting both UK and US spelling variants.++So++ {-# SPECIALISE #-}+ {-# SPECIALIZE #-}+ {-# Specialize #-}++will all generate ITspec_prag token for the start of the pragma.++In order to be able to do source to source conversions, the original+source text for the token needs to be preserved, hence the+`SourceText` field.++So the lexer will then generate++ ITspec_prag "{ -# SPECIALISE"+ ITspec_prag "{ -# SPECIALIZE"+ ITspec_prag "{ -# Specialize"++for the cases above.+ [without the space between '{' and '-', otherwise this comment won't parse]+++Note [Literal source text]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The lexer/parser converts literals from their original source text+versions to an appropriate internal representation. This is a problem+for tools doing source to source conversions, so the original source+text is stored in literals where this can occur.++Motivating examples for HsLit++ 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##+ HsInteger 006 == 6++For OverLitVal++ HsIntegral 003 == 0x003+ HsIsString "\x41nd" == "And"+-}++ -- Note [Literal source text],[Pragma source text]+data SourceText+ = SourceText String+ | NoSourceText+ -- ^ For when code is generated, e.g. TH,+ -- deriving. The pretty printer will then make+ -- its own representation of the item.+ deriving (Data, Show, Eq )++instance Outputable SourceText where+ ppr (SourceText s) = text "SourceText" <+> text s+ ppr NoSourceText = text "NoSourceText"++instance Binary SourceText where+ put_ bh NoSourceText = putByte bh 0+ put_ bh (SourceText s) = do+ putByte bh 1+ put_ bh s++ get bh = do+ h <- getByte bh+ case h of+ 0 -> return NoSourceText+ 1 -> do+ s <- get bh+ return (SourceText s)+ _ -> panic $ "Binary SourceText:" ++ show h++-- | Special combinator for showing string literals.+pprWithSourceText :: SourceText -> SDoc -> SDoc+pprWithSourceText NoSourceText d = d+pprWithSourceText (SourceText src) _ = text src++------------------------------------------------+-- Literals+------------------------------------------------++-- | Integral Literal+--+-- Used (instead of Integer) to represent negative zegative zero which is+-- required for NegativeLiterals extension to correctly parse `-0::Double`+-- as negative zero. See also #13211.+data IntegralLit = IL+ { il_text :: SourceText+ , il_neg :: Bool -- See Note [Negative zero] in GHC.Rename.Pat+ , il_value :: Integer+ }+ deriving (Data, Show)++mkIntegralLit :: Integral a => a -> IntegralLit+mkIntegralLit i = IL { il_text = SourceText (show i_integer)+ , il_neg = i < 0+ , il_value = i_integer }+ where+ i_integer :: Integer+ i_integer = toInteger i++negateIntegralLit :: IntegralLit -> IntegralLit+negateIntegralLit (IL text neg value)+ = case text of+ SourceText ('-':src) -> IL (SourceText src) False (negate value)+ SourceText src -> IL (SourceText ('-':src)) True (negate value)+ NoSourceText -> IL NoSourceText (not neg) (negate value)++-- | Fractional Literal+--+-- Used (instead of Rational) to represent exactly the floating point literal that we+-- encountered in the user's source program. This allows us to pretty-print exactly what+-- the user wrote, which is important e.g. for floating point numbers that can't represented+-- as Doubles (we used to via Double for pretty-printing). See also #2245.+data FractionalLit = FL+ { fl_text :: SourceText -- ^ How the value was written in the source+ , fl_neg :: Bool -- ^ See Note [Negative zero] in GHC.Rename.Pat+ , fl_value :: Rational -- ^ Numeric value of the literal+ }+ deriving (Data, Show)+ -- The Show instance is required for the derived GHC.Parser.Lexer.Token instance when DEBUG is on++mkFractionalLit :: Real a => a -> FractionalLit+mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))+ -- Converting to a Double here may technically lose+ -- precision (see #15502). We could alternatively+ -- convert to a Rational for the most accuracy, but+ -- it would cause Floats and Doubles to be displayed+ -- strangely, so we opt not to do this. (In contrast+ -- to mkIntegralLit, where we always convert to an+ -- Integer for the highest accuracy.)+ , fl_neg = r < 0+ , fl_value = toRational r }++negateFractionalLit :: FractionalLit -> FractionalLit+negateFractionalLit (FL text neg value)+ = case text of+ SourceText ('-':src) -> FL (SourceText src) False value+ SourceText src -> FL (SourceText ('-':src)) True value+ NoSourceText -> FL NoSourceText (not neg) (negate value)++integralFractionalLit :: Bool -> Integer -> FractionalLit+integralFractionalLit neg i = FL { fl_text = SourceText (show i),+ fl_neg = neg,+ fl_value = fromInteger i }++-- Comparison operations are needed when grouping literals+-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)++instance Eq IntegralLit where+ (==) = (==) `on` il_value++instance Ord IntegralLit where+ compare = compare `on` il_value++instance Outputable IntegralLit where+ ppr (IL (SourceText src) _ _) = text src+ ppr (IL NoSourceText _ value) = text (show value)++instance Eq FractionalLit where+ (==) = (==) `on` fl_value++instance Ord FractionalLit where+ compare = compare `on` fl_value++instance Outputable FractionalLit where+ ppr f = pprWithSourceText (fl_text f) (rational (fl_value f))++-- | A String Literal in the source, including its original raw format for use by+-- source to source manipulation tools.+data StringLiteral = StringLiteral+ { sl_st :: SourceText, -- literal raw source.+ -- See not [Literal source text]+ sl_fs :: FastString -- literal string value+ } deriving Data++instance Eq StringLiteral where+ (StringLiteral _ a) == (StringLiteral _ b) = a == b++instance Outputable StringLiteral where+ ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)++instance Binary StringLiteral where+ put_ bh (StringLiteral st fs) = do+ put_ bh st+ put_ bh fs+ get bh = do+ st <- get bh+ fs <- get bh+ return (StringLiteral st fs)+
compiler/GHC/Types/SrcLoc.hs view
@@ -1,17 +1,11 @@--- (c) The University of Glasgow, 1992-2006- {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PatternSynonyms #-} +-- (c) The University of Glasgow, 1992-2006 -- | This module contains types that relate to the positions of things -- in source files, and allow tagging of those things with locations
+ compiler/GHC/Types/Target.hs view
@@ -0,0 +1,67 @@+module GHC.Types.Target+ ( Target(..)+ , TargetId(..)+ , InputFileBuffer+ , pprTarget+ , pprTargetId+ )+where++import GHC.Prelude+import GHC.Driver.Phases ( Phase )+import GHC.Unit+import GHC.Data.StringBuffer ( StringBuffer )+import GHC.Utils.Outputable++import Data.Time++-- | A compilation target.+--+-- A target may be supplied with the actual text of the+-- module. If so, use this instead of the file contents (this+-- is for use in an IDE where the file hasn't been saved by+-- the user yet).+data Target+ = Target {+ targetId :: TargetId, -- ^ module or filename+ targetAllowObjCode :: Bool, -- ^ object code allowed?+ targetContents :: Maybe (InputFileBuffer, UTCTime)+ -- ^ Optional in-memory buffer containing the source code GHC should+ -- use for this target instead of reading it from disk.+ --+ -- Since GHC version 8.10 modules which require preprocessors such as+ -- Literate Haskell or CPP to run are also supported.+ --+ -- If a corresponding source file does not exist on disk this will+ -- result in a 'SourceError' exception if @targetId = TargetModule _@+ -- is used. However together with @targetId = TargetFile _@ GHC will+ -- not complain about the file missing.+ }++data TargetId+ = TargetModule ModuleName+ -- ^ A module name: search for the file+ | TargetFile FilePath (Maybe Phase)+ -- ^ A filename: preprocess & parse it to find the module name.+ -- If specified, the Phase indicates how to compile this file+ -- (which phase to start from). Nothing indicates the starting phase+ -- should be determined from the suffix of the filename.+ deriving Eq++type InputFileBuffer = StringBuffer+++pprTarget :: Target -> SDoc+pprTarget (Target id obj _) =+ (if obj then empty else char '*') <> pprTargetId id++instance Outputable Target where+ ppr = pprTarget++pprTargetId :: TargetId -> SDoc+pprTargetId (TargetModule m) = ppr m+pprTargetId (TargetFile f _) = text f++instance Outputable TargetId where+ ppr = pprTargetId+
+ compiler/GHC/Types/TyThing.hs view
@@ -0,0 +1,316 @@+-- | A global typecheckable-thing, essentially anything that has a name.+module GHC.Types.TyThing+ ( TyThing (..)+ , MonadThings (..)+ , mkATyCon+ , mkAnId+ , pprShortTyThing+ , pprTyThingCategory+ , tyThingCategory+ , implicitTyThings+ , implicitConLikeThings+ , implicitClassThings+ , implicitTyConThings+ , implicitCoTyCon+ , isImplicitTyThing+ , tyThingParent_maybe+ , tyThingsTyCoVars+ , tyThingAvailInfo+ , tyThingTyCon+ , tyThingCoAxiom+ , tyThingDataCon+ , tyThingConLike+ , tyThingId+ )+where++import GHC.Prelude++import GHC.Types.Name+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Avail++import GHC.Core.Class+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Core.PatSyn+import GHC.Core.TyCo.FVs+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++import Control.Monad ( liftM )+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class++{-+Note [ATyCon for classes]+~~~~~~~~~~~~~~~~~~~~~~~~~+Both classes and type constructors are represented in the type environment+as ATyCon. You can tell the difference, and get to the class, with+ isClassTyCon :: TyCon -> Bool+ tyConClass_maybe :: TyCon -> Maybe Class+The Class and its associated TyCon have the same Name.+-}++-- | A global typecheckable-thing, essentially anything that has a name.+-- Not to be confused with a 'TcTyThing', which is also a typecheckable+-- thing but in the *local* context. See "GHC.Tc.Utils.Env" for how to retrieve+-- a 'TyThing' given a 'Name'.+data TyThing+ = AnId Id+ | AConLike ConLike+ | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes]+ | ACoAxiom (CoAxiom Branched)++instance Outputable TyThing where+ ppr = pprShortTyThing++instance NamedThing TyThing where -- Can't put this with the type+ getName (AnId id) = getName id -- decl, because the DataCon instance+ getName (ATyCon tc) = getName tc -- isn't visible there+ getName (ACoAxiom cc) = getName cc+ getName (AConLike cl) = conLikeName cl++mkATyCon :: TyCon -> TyThing+mkATyCon = ATyCon++mkAnId :: Id -> TyThing+mkAnId = AnId++pprShortTyThing :: TyThing -> SDoc+-- c.f. GHC.Types.TyThing.Ppr.pprTyThing, which prints all the details+pprShortTyThing thing+ = pprTyThingCategory thing <+> quotes (ppr (getName thing))++pprTyThingCategory :: TyThing -> SDoc+pprTyThingCategory = text . capitalise . tyThingCategory++tyThingCategory :: TyThing -> String+tyThingCategory (ATyCon tc)+ | isClassTyCon tc = "class"+ | otherwise = "type constructor"+tyThingCategory (ACoAxiom _) = "coercion axiom"+tyThingCategory (AnId _) = "identifier"+tyThingCategory (AConLike (RealDataCon _)) = "data constructor"+tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym"++++{-+Note [Implicit TyThings]+~~~~~~~~~~~~~~~~~~~~~~~~+ DEFINITION: An "implicit" TyThing is one that does not have its own+ IfaceDecl in an interface file. Instead, its binding in the type+ environment is created as part of typechecking the IfaceDecl for+ some other thing.++Examples:+ * All DataCons are implicit, because they are generated from the+ IfaceDecl for the data/newtype. Ditto class methods.++ * Record selectors are *not* implicit, because they get their own+ free-standing IfaceDecl.++ * Associated data/type families are implicit because they are+ included in the IfaceDecl of the parent class. (NB: the+ IfaceClass decl happens to use IfaceDecl recursively for the+ associated types, but that's irrelevant here.)++ * Dictionary function Ids are not implicit.++ * Axioms for newtypes are implicit (same as above), but axioms+ for data/type family instances are *not* implicit (like DFunIds).+-}++-- | Determine the 'TyThing's brought into scope by another 'TyThing'+-- /other/ than itself. For example, Id's don't have any implicit TyThings+-- as they just bring themselves into scope, but classes bring their+-- dictionary datatype, type constructor and some selector functions into+-- scope, just for a start!++-- N.B. the set of TyThings returned here *must* match the set of+-- names returned by 'GHC.Iface.Load.ifaceDeclImplicitBndrs', 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])+-- The order of the list does not matter.+implicitTyThings :: TyThing -> [TyThing]+implicitTyThings (AnId _) = []+implicitTyThings (ACoAxiom _cc) = []+implicitTyThings (ATyCon tc) = implicitTyConThings tc+implicitTyThings (AConLike cl) = implicitConLikeThings cl++implicitConLikeThings :: ConLike -> [TyThing]+implicitConLikeThings (RealDataCon dc)+ = dataConImplicitTyThings dc++implicitConLikeThings (PatSynCon {})+ = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher+ -- are not "implicit"; they are simply new top-level bindings,+ -- and they have their own declaration in an interface file+ -- Unless a record pat syn when there are implicit selectors+ -- They are still not included here as `implicitConLikeThings` is+ -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked+ -- by `tcTopValBinds`.++implicitClassThings :: Class -> [TyThing]+implicitClassThings cl+ = -- Does not include default methods, because those Ids may have+ -- their own pragmas, unfoldings etc, not derived from the Class object++ -- associated types+ -- No recursive call for the classATs, because they+ -- are only the family decls; they have no implicit things+ map ATyCon (classATs cl) ++++ -- superclass and operation selectors+ map AnId (classAllSelIds cl)++implicitTyConThings :: TyCon -> [TyThing]+implicitTyConThings tc+ = class_stuff +++ -- fields (names of selectors)++ -- (possibly) implicit newtype axioms+ -- or type family axioms+ implicitCoTyCon tc ++++ -- for each data constructor in order,+ -- the constructor, worker, and (possibly) wrapper+ [ thing | dc <- tyConDataCons tc+ , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ]+ -- NB. record selectors are *not* implicit, they have fully-fledged+ -- bindings that pass through the compilation pipeline as normal.+ where+ class_stuff = case tyConClass_maybe tc of+ Nothing -> []+ Just cl -> implicitClassThings cl++-- For newtypes and closed type families (only) add the implicit coercion tycon+implicitCoTyCon :: TyCon -> [TyThing]+implicitCoTyCon tc+ | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co]+ | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc+ = [ACoAxiom co]+ | otherwise = []++-- | Returns @True@ if there should be no interface-file declaration+-- for this thing on its own: either it is built-in, or it is part+-- of some other declaration, or it is generated implicitly by some+-- other declaration.+isImplicitTyThing :: TyThing -> Bool+isImplicitTyThing (AConLike cl) = case cl of+ RealDataCon {} -> True+ PatSynCon {} -> False+isImplicitTyThing (AnId id) = isImplicitId id+isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc+isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax++-- | tyThingParent_maybe x returns (Just p)+-- when pprTyThingInContext should print a declaration for p+-- (albeit with some "..." in it) when asked to show x+-- It returns the *immediate* parent. So a datacon returns its tycon+-- but the tycon could be the associated type of a class, so it in turn+-- might have a parent.+tyThingParent_maybe :: TyThing -> Maybe TyThing+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 (AnId id) = case idDetails id of+ RecSelId { sel_tycon = RecSelData tc } ->+ Just (ATyCon tc)+ ClassOpId cls ->+ Just (ATyCon (classTyCon cls))+ _other -> Nothing+tyThingParent_maybe _other = Nothing++tyThingsTyCoVars :: [TyThing] -> TyCoVarSet+tyThingsTyCoVars tts =+ unionVarSets $ map ttToVarSet tts+ where+ ttToVarSet (AnId id) = tyCoVarsOfType $ idType id+ ttToVarSet (AConLike cl) = case cl of+ RealDataCon dc -> tyCoVarsOfType $ dataConRepType dc+ PatSynCon{} -> emptyVarSet+ ttToVarSet (ATyCon tc)+ = case tyConClass_maybe tc of+ Just cls -> (mkVarSet . fst . classTvsFds) cls+ Nothing -> tyCoVarsOfType $ tyConKind tc+ ttToVarSet (ACoAxiom _) = emptyVarSet++-- | The Names that a TyThing should bring into scope. Used to build+-- the GlobalRdrEnv for the InteractiveContext.+tyThingAvailInfo :: TyThing -> [AvailInfo]+tyThingAvailInfo (ATyCon t)+ = case tyConClass_maybe t of+ Just c -> [AvailTC n (n : map getName (classMethods c)+ ++ map getName (classATs c))+ [] ]+ where n = getName c+ Nothing -> [AvailTC n (n : map getName dcs) flds]+ where n = getName t+ dcs = tyConDataCons t+ flds = tyConFieldLabels t+tyThingAvailInfo (AConLike (PatSynCon p))+ = map avail ((getName p) : map flSelector (patSynFieldLabels p))+tyThingAvailInfo t+ = [avail (getName t)]++-- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise+tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon+tyThingTyCon (ATyCon tc) = tc+tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other)++-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise+tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched+tyThingCoAxiom (ACoAxiom ax) = ax+tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (ppr other)++-- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise+tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon+tyThingDataCon (AConLike (RealDataCon dc)) = dc+tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other)++-- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing.+-- Panics otherwise+tyThingConLike :: HasDebugCallStack => TyThing -> ConLike+tyThingConLike (AConLike dc) = dc+tyThingConLike other = pprPanic "tyThingConLike" (ppr other)++-- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise+tyThingId :: HasDebugCallStack => TyThing -> Id+tyThingId (AnId id) = id+tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc+tyThingId other = pprPanic "tyThingId" (ppr other)++-- | Class that abstracts out the common ability of the monads in GHC+-- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides+-- a number of related convenience functions for accessing particular+-- kinds of 'TyThing'+class Monad m => MonadThings m where+ lookupThing :: Name -> m TyThing++ lookupId :: Name -> m Id+ lookupId = liftM tyThingId . lookupThing++ lookupDataCon :: Name -> m DataCon+ lookupDataCon = liftM tyThingDataCon . lookupThing++ lookupTyCon :: Name -> m TyCon+ lookupTyCon = liftM tyThingTyCon . lookupThing++-- Instance used in GHC.HsToCore.Quote+instance MonadThings m => MonadThings (ReaderT s m) where+ lookupThing = lift . lookupThing++
+ compiler/GHC/Types/TyThing.hs-boot view
@@ -0,0 +1,8 @@+module GHC.Types.TyThing where++import {-# SOURCE #-} GHC.Core.TyCon+import {-# SOURCE #-} GHC.Types.Var++data TyThing+mkATyCon :: TyCon -> TyThing+mkAnId :: Id -> TyThing
+ compiler/GHC/Types/TypeEnv.hs view
@@ -0,0 +1,95 @@+module GHC.Types.TypeEnv+ ( TypeEnv+ , emptyTypeEnv+ , lookupTypeEnv+ , mkTypeEnv+ , typeEnvFromEntities+ , mkTypeEnvWithImplicits+ , extendTypeEnv+ , extendTypeEnvList+ , extendTypeEnvWithIds+ , plusTypeEnv+ , typeEnvElts+ , typeEnvTyCons+ , typeEnvIds+ , typeEnvPatSyns+ , typeEnvDataCons+ , typeEnvCoAxioms+ , typeEnvClasses+ )+where++import GHC.Prelude++import GHC.Core.Class+import GHC.Core.Coercion.Axiom+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.FamInstEnv+import GHC.Core.PatSyn+import GHC.Core.TyCon++import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Var+import GHC.Types.TyThing++-- | A map from 'Name's to 'TyThing's, constructed by typechecking+-- local declarations or interface files+type TypeEnv = NameEnv TyThing++emptyTypeEnv :: TypeEnv+typeEnvElts :: TypeEnv -> [TyThing]+typeEnvTyCons :: TypeEnv -> [TyCon]+typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched]+typeEnvIds :: TypeEnv -> [Id]+typeEnvPatSyns :: TypeEnv -> [PatSyn]+typeEnvDataCons :: TypeEnv -> [DataCon]+typeEnvClasses :: TypeEnv -> [Class]+lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing++emptyTypeEnv = emptyNameEnv+typeEnvElts env = nameEnvElts env+typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env]+typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env]+typeEnvIds env = [id | AnId id <- typeEnvElts env]+typeEnvPatSyns env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env]+typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env]+typeEnvClasses env = [cl | tc <- typeEnvTyCons env,+ Just cl <- [tyConClass_maybe tc]]++mkTypeEnv :: [TyThing] -> TypeEnv+mkTypeEnv things = extendTypeEnvList emptyTypeEnv things++mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv+mkTypeEnvWithImplicits things =+ mkTypeEnv things+ `plusNameEnv`+ mkTypeEnv (concatMap implicitTyThings things)++typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv+typeEnvFromEntities ids tcs famInsts =+ mkTypeEnv ( map AnId ids+ ++ map ATyCon all_tcs+ ++ concatMap implicitTyConThings all_tcs+ ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts+ )+ where+ all_tcs = tcs ++ famInstsRepTyCons famInsts++lookupTypeEnv = lookupNameEnv++-- Extend the type environment+extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv+extendTypeEnv env thing = extendNameEnv env (getName thing) thing++extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv+extendTypeEnvList env things = foldl' extendTypeEnv env things++extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv+extendTypeEnvWithIds env ids+ = extendNameEnvList env [(getName id, AnId id) | id <- ids]++plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv+plusTypeEnv env1 env2 = plusNameEnv env1 env2+
compiler/GHC/Unit.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveFunctor #-} -- | Units are library components from Cabal packages compiled and installed in -- a database
+ compiler/GHC/Unit/External.hs view
@@ -0,0 +1,131 @@+module GHC.Unit.External+ ( ExternalPackageState (..)+ , EpsStats(..)+ , addEpsInStats+ , PackageTypeEnv+ , PackageIfaceTable+ , PackageInstEnv+ , PackageFamInstEnv+ , PackageRuleBase+ , PackageCompleteMatches+ , emptyPackageIfaceTable+ )+where++import GHC.Prelude++import GHC.Unit+import GHC.Unit.Module.ModIface++import GHC.Core ( RuleBase )+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv ( InstEnv )++import GHC.Types.Annotations ( AnnEnv )+import GHC.Types.CompleteMatch+import GHC.Types.TypeEnv+import GHC.Types.Unique.DSet+++type PackageTypeEnv = TypeEnv+type PackageRuleBase = RuleBase+type PackageInstEnv = InstEnv+type PackageFamInstEnv = FamInstEnv+type PackageAnnEnv = AnnEnv+type PackageCompleteMatches = CompleteMatches++-- | Helps us find information about modules in the imported packages+type PackageIfaceTable = ModuleEnv ModIface+ -- Domain = modules in the imported packages++-- | Constructs an empty PackageIfaceTable+emptyPackageIfaceTable :: PackageIfaceTable+emptyPackageIfaceTable = emptyModuleEnv+++-- | Information about other packages that we have slurped in by reading+-- their interface files+data ExternalPackageState+ = EPS {+ eps_is_boot :: !(ModuleNameEnv ModuleNameWithIsBoot),+ -- ^ In OneShot mode (only), home-package modules+ -- accumulate in the external package state, and are+ -- sucked in lazily. For these home-pkg modules+ -- (only) we need to record which are boot modules.+ -- We set this field after loading all the+ -- explicitly-imported interfaces, but before doing+ -- anything else+ --+ -- The 'ModuleName' part is not necessary, but it's useful for+ -- debug prints, and it's convenient because this field comes+ -- direct from 'GHC.Tc.Utils.imp_dep_mods'++ eps_PIT :: !PackageIfaceTable,+ -- ^ The 'ModIface's for modules in external packages+ -- whose interfaces we have opened.+ -- The declarations in these interface files are held in the+ -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules'+ -- fields of this record, not in the 'mi_decls' fields of the+ -- interface we have sucked in.+ --+ -- What /is/ in the PIT is:+ --+ -- * The Module+ --+ -- * Fingerprint info+ --+ -- * Its exports+ --+ -- * Fixities+ --+ -- * Deprecations and warnings++ eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName),+ -- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on+ -- the 'eps_PIT' for this information, EXCEPT that when+ -- we do dependency analysis, we need to look at the+ -- 'Dependencies' of our imports to determine what their+ -- precise free holes are ('moduleFreeHolesPrecise'). We+ -- don't want to repeatedly reread in the interface+ -- for every import, so cache it here. When the PIT+ -- gets filled in we can drop these entries.++ eps_PTE :: !PackageTypeEnv,+ -- ^ Result of typechecking all the external package+ -- interface files we have sucked in. The domain of+ -- the mapping is external-package modules++ eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated+ -- from all the external-package modules+ eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated+ -- from all the external-package modules+ eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' accumulated+ -- from all the external-package modules+ eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated+ -- from all the external-package modules+ eps_complete_matches :: !PackageCompleteMatches,+ -- ^ The total 'CompleteMatches' accumulated+ -- from all the external-package modules++ 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+ }++-- | Accumulated statistics about what we are putting into the 'ExternalPackageState'.+-- \"In\" means stuff that is just /read/ from interface files,+-- \"Out\" means actually sucked in and type-checked+data EpsStats = EpsStats { n_ifaces_in+ , n_decls_in, n_decls_out+ , n_rules_in, n_rules_out+ , n_insts_in, n_insts_out :: !Int }++addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats+-- ^ Add stats for one newly-read interface+addEpsInStats stats n_decls n_insts n_rules+ = stats { n_ifaces_in = n_ifaces_in stats + 1+ , n_decls_in = n_decls_in stats + n_decls+ , n_insts_in = n_insts_in stats + n_insts+ , n_rules_in = n_rules_in stats + n_rules }+
+ compiler/GHC/Unit/Finder/Types.hs view
@@ -0,0 +1,56 @@+module GHC.Unit.Finder.Types+ ( FinderCache+ , FindResult (..)+ , InstalledFindResult (..)+ )+where++import GHC.Prelude+import GHC.Unit+import GHC.Unit.State++-- | The 'FinderCache' maps modules to the result of+-- searching for that module. It records the results of searching for+-- modules along the search path. On @:load@, we flush the entire+-- contents of this cache.+--+type FinderCache = InstalledModuleEnv InstalledFindResult++data InstalledFindResult+ = InstalledFound ModLocation InstalledModule+ | InstalledNoPackage UnitId+ | InstalledNotFound [FilePath] (Maybe UnitId)++-- | The result of searching for an imported module.+--+-- NB: FindResult manages both user source-import lookups+-- (which can result in 'Module') as well as direct imports+-- for interfaces (which always result in 'InstalledModule').+data FindResult+ = Found ModLocation Module+ -- ^ The module was found+ | NoPackage Unit+ -- ^ The requested unit was not found+ | FoundMultiple [(Module, ModuleOrigin)]+ -- ^ _Error_: both in multiple packages++ -- | Not found+ | NotFound+ { fr_paths :: [FilePath] -- ^ Places where I looked++ , fr_pkg :: Maybe Unit -- ^ Just p => module is in this unit's+ -- manifest, but couldn't find the+ -- .hi file++ , fr_mods_hidden :: [Unit] -- ^ Module is in these units,+ -- but the *module* is hidden++ , fr_pkgs_hidden :: [Unit] -- ^ Module is in these units,+ -- but the *unit* is hidden++ -- | Module is in these units, but it is unusable+ , fr_unusables :: [(Unit, UnusableUnitReason)]++ , fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules+ }+
+ compiler/GHC/Unit/Home/ModInfo.hs view
@@ -0,0 +1,117 @@+-- | Info about modules in the "home" unit+module GHC.Unit.Home.ModInfo+ ( HomeModInfo (..)+ , HomePackageTable+ , emptyHomePackageTable+ , lookupHpt+ , eltsHpt+ , filterHpt+ , allHpt+ , mapHpt+ , delFromHpt+ , addToHpt+ , addListToHpt+ , lookupHptDirectly+ , lookupHptByModule+ , listToHpt+ , pprHPT+ )+where++import GHC.Prelude++import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module++import GHC.Runtime.Linker.Types ( Linkable(..) )++import GHC.Types.Unique+import GHC.Types.Unique.DFM++import GHC.Utils.Outputable++-- | Information about modules in the package being compiled+data HomeModInfo = HomeModInfo+ { hm_iface :: !ModIface+ -- ^ The basic loaded interface file: every loaded module has one of+ -- these, even if it is imported from another package++ , hm_details :: !ModDetails+ -- ^ Extra information that has been created from the 'ModIface' for+ -- the module, typically during typechecking++ , hm_linkable :: !(Maybe Linkable)+ -- ^ The actual artifact we would like to link to access things in+ -- this module.+ --+ -- 'hm_linkable' might be Nothing:+ --+ -- 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).+ }++-- | Helps us find information about modules in the home package+type HomePackageTable = DModuleNameEnv HomeModInfo+ -- Domain = modules in the home unit that have been fully compiled+ -- "home" unit id cached (implicit) here for convenience++-- | Constructs an empty HomePackageTable+emptyHomePackageTable :: HomePackageTable+emptyHomePackageTable = emptyUDFM++lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo+lookupHpt = lookupUDFM++lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo+lookupHptDirectly = lookupUDFM_Directly++eltsHpt :: HomePackageTable -> [HomeModInfo]+eltsHpt = eltsUDFM++filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable+filterHpt = filterUDFM++allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool+allHpt = allUDFM++mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable+mapHpt = mapUDFM++delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable+delFromHpt = delFromUDFM++addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable+addToHpt = addToUDFM++addListToHpt+ :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable+addListToHpt = addListToUDFM++listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable+listToHpt = listToUDFM++lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo+-- The HPT is indexed by ModuleName, not Module,+-- we must check for a hit on the right Module+lookupHptByModule hpt mod+ = case lookupHpt hpt (moduleName mod) of+ Just hm | mi_module (hm_iface hm) == mod -> Just hm+ _otherwise -> Nothing++pprHPT :: HomePackageTable -> SDoc+-- A bit arbitrary for now+pprHPT hpt = pprUDFM hpt $ \hms ->+ vcat [ hang (ppr (mi_module (hm_iface hm)))+ 2 (ppr (md_types (hm_details hm)))+ | hm <- hms ]+
compiler/GHC/Unit/Info.hs view
@@ -31,6 +31,7 @@ import Data.Bifunctor import GHC.Data.FastString+import qualified GHC.Data.ShortText as ST import GHC.Utils.Outputable import GHC.Unit.Module as Module import GHC.Types.Unique@@ -124,21 +125,21 @@ field "exposed-modules" (ppr unitExposedModules), field "hidden-modules" (fsep (map ppr unitHiddenModules)), field "trusted" (ppr unitIsTrusted),- field "import-dirs" (fsep (map text unitImportDirs)),- field "library-dirs" (fsep (map text unitLibraryDirs)),- field "dynamic-library-dirs" (fsep (map text unitLibraryDynDirs)),- field "hs-libraries" (fsep (map text unitLibraries)),- field "extra-libraries" (fsep (map text unitExtDepLibsSys)),- field "extra-ghci-libraries" (fsep (map text unitExtDepLibsGhc)),- field "include-dirs" (fsep (map text unitIncludeDirs)),- field "includes" (fsep (map text unitIncludes)),+ field "import-dirs" (fsep (map (text . ST.unpack) unitImportDirs)),+ field "library-dirs" (fsep (map (text . ST.unpack) unitLibraryDirs)),+ field "dynamic-library-dirs" (fsep (map (text . ST.unpack) unitLibraryDynDirs)),+ field "hs-libraries" (fsep (map (text . ST.unpack) unitLibraries)),+ field "extra-libraries" (fsep (map (text . ST.unpack) unitExtDepLibsSys)),+ field "extra-ghci-libraries" (fsep (map (text . ST.unpack) unitExtDepLibsGhc)),+ field "include-dirs" (fsep (map (text . ST.unpack) unitIncludeDirs)),+ field "includes" (fsep (map (text . ST.unpack) unitIncludes)), field "depends" (fsep (map ppr unitDepends)),- field "cc-options" (fsep (map text unitCcOptions)),- field "ld-options" (fsep (map text unitLinkerOptions)),- field "framework-dirs" (fsep (map text unitExtDepFrameworkDirs)),- field "frameworks" (fsep (map text unitExtDepFrameworks)),- field "haddock-interfaces" (fsep (map text unitHaddockInterfaces)),- field "haddock-html" (fsep (map text unitHaddockHTMLs))+ field "cc-options" (fsep (map (text . ST.unpack) unitCcOptions)),+ field "ld-options" (fsep (map (text . ST.unpack) unitLinkerOptions)),+ field "framework-dirs" (fsep (map (text . ST.unpack) unitExtDepFrameworkDirs)),+ field "frameworks" (fsep (map (text . ST.unpack) unitExtDepFrameworks)),+ field "haddock-interfaces" (fsep (map (text . ST.unpack) unitHaddockInterfaces)),+ field "haddock-html" (fsep (map (text . ST.unpack) unitHaddockHTMLs)) ] where field name body = text name <> colon <+> nest 4 body
compiler/GHC/Unit/Module.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+ {- (c) The University of Glasgow, 2004-2006 @@ -8,14 +13,6 @@ These are Uniquable, hence we can build Maps with Modules as the keys. -}--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeSynonymInstances #-} module GHC.Unit.Module ( module GHC.Unit.Types
+ compiler/GHC/Unit/Module/Deps.hs view
@@ -0,0 +1,195 @@+-- | Dependencies and Usage of a module+module GHC.Unit.Module.Deps+ ( Dependencies (..)+ , Usage (..)+ , noDependencies+ )+where++import GHC.Prelude++import GHC.Types.SafeHaskell+import GHC.Types.Name+import GHC.Unit.Module.Name+import GHC.Unit.Module++import GHC.Utils.Fingerprint+import GHC.Utils.Binary++-- | Dependency information about ALL modules and packages below this one+-- in the import hierarchy.+--+-- Invariant: the dependencies of a module @M@ never includes @M@.+--+-- Invariant: none of the lists contain duplicates.+data Dependencies = Deps+ { dep_mods :: [ModuleNameWithIsBoot]+ -- ^ All home-package modules transitively below this one+ -- I.e. modules that this one imports, or that are in the+ -- dep_mods of those directly-imported modules++ , dep_pkgs :: [(UnitId, Bool)]+ -- ^ All packages transitively below this module+ -- I.e. packages to which this module's direct imports belong,+ -- or that are in the dep_pkgs of those modules+ -- The bool indicates if the package is required to be+ -- trusted when the module is imported as a safe import+ -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names++ , dep_orphs :: [Module]+ -- ^ Transitive closure of orphan modules (whether+ -- home or external pkg).+ --+ -- (Possible optimization: don't include family+ -- instance orphans as they are anyway included in+ -- 'dep_finsts'. But then be careful about code+ -- which relies on dep_orphs having the complete list!)+ -- This does NOT include us, unlike 'imp_orphs'.++ , dep_finsts :: [Module]+ -- ^ Transitive closure of depended upon modules which+ -- contain family instances (whether home or external).+ -- This is used by 'checkFamInstConsistency'. This+ -- does NOT include us, unlike 'imp_finsts'. See Note+ -- [The type family instance consistency story].++ , dep_plgins :: [ModuleName]+ -- ^ All the plugins used while compiling this module.+ }+ deriving( Eq )+ -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints+ -- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies.++instance Binary Dependencies where+ put_ bh deps = do put_ bh (dep_mods deps)+ put_ bh (dep_pkgs deps)+ put_ bh (dep_orphs deps)+ put_ bh (dep_finsts deps)+ put_ bh (dep_plgins deps)++ get bh = do ms <- get bh+ ps <- get bh+ os <- get bh+ fis <- get bh+ pl <- get bh+ return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,+ dep_finsts = fis, dep_plgins = pl })++noDependencies :: Dependencies+noDependencies = Deps [] [] [] [] []++-- | Records modules for which changes may force recompilation of this module+-- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance+--+-- This differs from Dependencies. A module X may be in the dep_mods of this+-- module (via an import chain) but if we don't use anything from X it won't+-- appear in our Usage+data Usage+ -- | Module from another package+ = UsagePackageModule {+ usg_mod :: Module,+ -- ^ External package module depended on+ usg_mod_hash :: Fingerprint,+ -- ^ Cached module fingerprint+ usg_safe :: IsSafeImport+ -- ^ Was this module imported as a safe import+ }+ -- | Module from the current package+ | UsageHomeModule {+ usg_mod_name :: ModuleName,+ -- ^ Name of the module+ usg_mod_hash :: Fingerprint,+ -- ^ Cached module fingerprint+ usg_entities :: [(OccName,Fingerprint)],+ -- ^ Entities we depend on, sorted by occurrence name and fingerprinted.+ -- NB: usages are for parent names only, e.g. type constructors+ -- but not the associated data constructors.+ usg_exports :: Maybe Fingerprint,+ -- ^ Fingerprint for the export list of this module,+ -- if we directly imported it (and hence we depend on its export list)+ usg_safe :: IsSafeImport+ -- ^ Was this module imported as a safe import+ } -- ^ Module from the current package+ -- | A file upon which the module depends, e.g. a CPP #include, or using TH's+ -- 'addDependentFile'+ | UsageFile {+ usg_file_path :: FilePath,+ -- ^ External file dependency. From a CPP #include or TH+ -- addDependentFile. Should be absolute.+ usg_file_hash :: Fingerprint+ -- ^ 'Fingerprint' of the file contents.++ -- Note: We don't consider things like modification timestamps+ -- here, because there's no reason to recompile if the actual+ -- contents don't change. This previously lead to odd+ -- recompilation behaviors; see #8114+ }+ -- | A requirement which was merged into this one.+ | UsageMergedRequirement {+ usg_mod :: Module,+ usg_mod_hash :: Fingerprint+ }+ deriving( Eq )+ -- The export list field is (Just v) if we depend on the export list:+ -- i.e. we imported the module directly, whether or not we+ -- enumerated the things we imported, or just imported+ -- everything+ -- We need to recompile if M's exports change, because+ -- if the import was import M, we might now have a name clash+ -- in the importing module.+ -- if the import was import M(x) M might no longer export x+ -- The only way we don't depend on the export list is if we have+ -- import M()+ -- And of course, for modules that aren't imported directly we don't+ -- depend on their export lists++instance Binary Usage where+ put_ bh usg@UsagePackageModule{} = do+ putByte bh 0+ put_ bh (usg_mod usg)+ put_ bh (usg_mod_hash usg)+ put_ bh (usg_safe usg)++ put_ bh usg@UsageHomeModule{} = do+ putByte bh 1+ put_ bh (usg_mod_name usg)+ put_ bh (usg_mod_hash usg)+ put_ bh (usg_exports usg)+ put_ bh (usg_entities usg)+ put_ bh (usg_safe usg)++ put_ bh usg@UsageFile{} = do+ putByte bh 2+ put_ bh (usg_file_path usg)+ put_ bh (usg_file_hash usg)++ put_ bh usg@UsageMergedRequirement{} = do+ putByte bh 3+ put_ bh (usg_mod usg)+ put_ bh (usg_mod_hash usg)++ get bh = do+ h <- getByte bh+ case h of+ 0 -> do+ nm <- get bh+ mod <- get bh+ safe <- get bh+ return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }+ 1 -> do+ nm <- get bh+ mod <- get bh+ exps <- get bh+ ents <- get bh+ safe <- get bh+ return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,+ usg_exports = exps, usg_entities = ents, usg_safe = safe }+ 2 -> do+ fp <- get bh+ hash <- get bh+ return UsageFile { usg_file_path = fp, usg_file_hash = hash }+ 3 -> do+ mod <- get bh+ hash <- get bh+ return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash }+ i -> error ("Binary.get(Usage): " ++ show i)
+ compiler/GHC/Unit/Module/Graph.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE RecordWildCards #-}++module GHC.Unit.Module.Graph+ ( ModuleGraph+ , emptyMG+ , mkModuleGraph+ , extendMG+ , mapMG+ , mgModSummaries+ , mgElemModule+ , mgLookupModule+ , mgBootModules+ , needsTemplateHaskellOrQQ+ , isTemplateHaskellOrQQNonBoot+ )+where++import GHC.Prelude++import qualified GHC.LanguageExtensions as LangExt++import GHC.Driver.Session++import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Env+import GHC.Unit.Types+++-- | A ModuleGraph contains all the nodes from the home package (only).+-- There will be a node for each source module, plus a node for each hi-boot+-- module.+--+-- The graph is not necessarily stored in topologically-sorted order. Use+-- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.+data ModuleGraph = ModuleGraph+ { mg_mss :: [ModSummary]+ , mg_non_boot :: ModuleEnv ModSummary+ -- a map of all non-boot ModSummaries keyed by Modules+ , mg_boot :: ModuleSet+ -- a set of boot Modules+ , mg_needs_th_or_qq :: !Bool+ -- does any of the modules in mg_mss require TemplateHaskell or+ -- QuasiQuotes?+ }++-- | Determines whether a set of modules requires Template Haskell or+-- Quasi Quotes+--+-- Note that if the session's 'DynFlags' enabled Template Haskell when+-- 'depanal' was called, then each module in the returned module graph will+-- have Template Haskell enabled whether it is actually needed or not.+needsTemplateHaskellOrQQ :: ModuleGraph -> Bool+needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg++-- | Map a function 'f' over all the 'ModSummaries'.+-- To preserve invariants 'f' can't change the isBoot status.+mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph+mapMG f mg@ModuleGraph{..} = mg+ { mg_mss = map f mg_mss+ , mg_non_boot = mapModuleEnv f mg_non_boot+ }++mgBootModules :: ModuleGraph -> ModuleSet+mgBootModules ModuleGraph{..} = mg_boot++mgModSummaries :: ModuleGraph -> [ModSummary]+mgModSummaries = mg_mss++mgElemModule :: ModuleGraph -> Module -> Bool+mgElemModule ModuleGraph{..} m = elemModuleEnv m mg_non_boot++-- | Look up a ModSummary in the ModuleGraph+mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary+mgLookupModule ModuleGraph{..} m = lookupModuleEnv mg_non_boot m++emptyMG :: ModuleGraph+emptyMG = ModuleGraph [] emptyModuleEnv emptyModuleSet False++isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool+isTemplateHaskellOrQQNonBoot ms =+ (xopt LangExt.TemplateHaskell (ms_hspp_opts ms)+ || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) &&+ (isBootSummary ms == NotBoot)++-- | Add a ModSummary to ModuleGraph. Assumes that the new ModSummary is+-- not an element of the ModuleGraph.+extendMG :: ModuleGraph -> ModSummary -> ModuleGraph+extendMG ModuleGraph{..} ms = ModuleGraph+ { mg_mss = ms:mg_mss+ , mg_non_boot = case isBootSummary ms of+ IsBoot -> mg_non_boot+ NotBoot -> extendModuleEnv mg_non_boot (ms_mod ms) ms+ , mg_boot = case isBootSummary ms of+ NotBoot -> mg_boot+ IsBoot -> extendModuleSet mg_boot (ms_mod ms)+ , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms+ }++mkModuleGraph :: [ModSummary] -> ModuleGraph+mkModuleGraph = foldr (flip extendMG) emptyMG+
+ compiler/GHC/Unit/Module/Imported.hs view
@@ -0,0 +1,54 @@+module GHC.Unit.Module.Imported+ ( ImportedMods+ , ImportedBy (..)+ , ImportedModsVal (..)+ , importedByUser+ )+where++import GHC.Prelude++import GHC.Unit.Module++import GHC.Types.Name.Reader+import GHC.Types.SafeHaskell+import GHC.Types.SrcLoc++-- | Records the modules directly imported by a module for extracting e.g.+-- usage information, and also to give better error message+type ImportedMods = ModuleEnv [ImportedBy]++-- | If a module was "imported" by the user, we associate it with+-- more detailed usage information 'ImportedModsVal'; a module+-- imported by the system only gets used for usage information.+data ImportedBy+ = ImportedByUser ImportedModsVal+ | ImportedBySystem++importedByUser :: [ImportedBy] -> [ImportedModsVal]+importedByUser (ImportedByUser imv : bys) = imv : importedByUser bys+importedByUser (ImportedBySystem : bys) = importedByUser bys+importedByUser [] = []++data ImportedModsVal = ImportedModsVal+ { imv_name :: ModuleName+ -- ^ The name the module is imported with++ , imv_span :: SrcSpan+ -- ^ the source span of the whole import++ , imv_is_safe :: IsSafeImport+ -- ^ whether this is a safe import++ , imv_is_hiding :: Bool+ -- ^ whether this is an "hiding" import++ , imv_all_exports :: !GlobalRdrEnv+ -- ^ all the things the module could provide.+ --+ -- NB. BangPattern here: otherwise this leaks. (#15111)++ , imv_qualified :: Bool+ -- ^ whether this is a qualified import+ }+
+ compiler/GHC/Unit/Module/ModDetails.hs view
@@ -0,0 +1,51 @@+module GHC.Unit.Module.ModDetails+ ( ModDetails (..)+ , emptyModDetails+ )+where++import GHC.Core ( CoreRule )+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv ( ClsInst )++import GHC.Types.Avail+import GHC.Types.CompleteMatch+import GHC.Types.TypeEnv+import GHC.Types.Annotations ( Annotation )++-- | The 'ModDetails' is essentially a cache for information in the 'ModIface'+-- for home modules only. Information relating to packages will be loaded into+-- global environments in 'ExternalPackageState'.+data ModDetails = ModDetails+ { -- The next two fields are created by the typechecker+ md_exports :: [AvailInfo]+ , md_types :: !TypeEnv+ -- ^ Local type environment for this particular module+ -- Includes Ids, TyCons, PatSyns++ , md_insts :: ![ClsInst]+ -- ^ 'DFunId's for the instances in this module++ , md_fam_insts :: ![FamInst]+ , md_rules :: ![CoreRule]+ -- ^ Domain may include 'Id's from other modules++ , md_anns :: ![Annotation]+ -- ^ Annotations present in this module: currently+ -- they only annotate things also declared in this module++ , md_complete_matches :: [CompleteMatch]+ -- ^ Complete match pragmas for this module+ }++-- | Constructs an empty ModDetails+emptyModDetails :: ModDetails+emptyModDetails = ModDetails+ { md_types = emptyTypeEnv+ , md_exports = []+ , md_insts = []+ , md_rules = []+ , md_fam_insts = []+ , md_anns = []+ , md_complete_matches = []+ }
+ compiler/GHC/Unit/Module/ModGuts.hs view
@@ -0,0 +1,140 @@+module GHC.Unit.Module.ModGuts+ ( ModGuts (..)+ , CgGuts (..)+ )+where++import GHC.Prelude++import GHC.ByteCode.Types+import GHC.ForeignSrcLang++import GHC.Hs++import GHC.Unit+import GHC.Unit.Module.Deps+import GHC.Unit.Module.Warnings++import GHC.Core.InstEnv ( InstEnv, ClsInst )+import GHC.Core.FamInstEnv+import GHC.Core ( CoreProgram, CoreRule )+import GHC.Core.TyCon+import GHC.Core.PatSyn++import GHC.Runtime.Linker.Types ( SptEntry(..) )++import GHC.Types.Annotations ( Annotation )+import GHC.Types.Avail+import GHC.Types.CompleteMatch+import GHC.Types.Fixity.Env+import GHC.Types.ForeignStubs+import GHC.Types.HpcInfo+import GHC.Types.Name.Reader+import GHC.Types.SafeHaskell+import GHC.Types.SourceFile ( HscSource(..) )+import GHC.Types.SrcLoc+++-- | A ModGuts is carried through the compiler, accumulating stuff as it goes+-- There is only one ModGuts at any time, the one for the module+-- being compiled right now. Once it is compiled, a 'ModIface' and+-- 'ModDetails' are extracted and the ModGuts is discarded.+data ModGuts+ = ModGuts {+ mg_module :: !Module, -- ^ Module being compiled+ mg_hsc_src :: HscSource, -- ^ Whether it's an hs-boot module+ mg_loc :: SrcSpan, -- ^ For error messages from inner passes+ mg_exports :: ![AvailInfo], -- ^ What it exports+ mg_deps :: !Dependencies, -- ^ What it depends on, directly or+ -- otherwise+ mg_usages :: ![Usage], -- ^ What was used? Used for interfaces.++ mg_used_th :: !Bool, -- ^ Did we run a TH splice?+ mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment++ -- These fields all describe the things **declared in this module**+ mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module.+ -- Used for creating interface files.+ mg_tcs :: ![TyCon], -- ^ TyCons declared in this module+ -- (includes TyCons for classes)+ mg_insts :: ![ClsInst], -- ^ Class instances declared in this module+ mg_fam_insts :: ![FamInst],+ -- ^ Family instances declared in this module+ mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module+ mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains+ -- See Note [Overall plumbing for rules] in "GHC.Core.Rules"+ mg_binds :: !CoreProgram, -- ^ Bindings for this module+ mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module+ mg_foreign_files :: ![(ForeignSrcLang, FilePath)],+ -- ^ Files to be compiled with the C compiler+ mg_warns :: !Warnings, -- ^ Warnings declared in the module+ mg_anns :: [Annotation], -- ^ Annotations declared in this module+ mg_complete_matches :: [CompleteMatch], -- ^ Complete Matches+ mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module+ mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module++ -- The next two fields are unusual, because they give instance+ -- environments for *all* modules in the home package, including+ -- this module, rather than for *just* this module.+ -- Reason: when looking up an instance we don't want to have to+ -- look at each module in the home package in turn+ mg_inst_env :: InstEnv, -- ^ Class instance environment for+ -- /home-package/ modules (including this+ -- one); c.f. 'tcg_inst_env'+ mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance environment for+ -- /home-package/ modules (including this+ -- one); c.f. 'tcg_fam_inst_env'++ mg_safe_haskell :: SafeHaskellMode, -- ^ Safe Haskell mode+ mg_trust_pkg :: Bool, -- ^ Do we need to trust our+ -- own package for Safe Haskell?+ -- See Note [Trust Own Package]+ -- in "GHC.Rename.Names"++ mg_doc_hdr :: !(Maybe HsDocString), -- ^ Module header.+ mg_decl_docs :: !DeclDocMap, -- ^ Docs on declarations.+ mg_arg_docs :: !ArgDocMap -- ^ Docs on arguments.+ }++-- The ModGuts takes on several slightly different forms:+--+-- After simplification, the following fields change slightly:+-- mg_rules Orphan rules only (local ones now attached to binds)+-- mg_binds With rules attached++---------------------------------------------------------+-- The Tidy pass forks the information about this module:+-- * one lot goes to interface file generation (ModIface)+-- and later compilations (ModDetails)+-- * the other lot goes to code generation (CgGuts)++-- | A restricted form of 'ModGuts' for code generation purposes+data CgGuts+ = CgGuts {+ cg_module :: !Module,+ -- ^ Module being compiled++ cg_tycons :: [TyCon],+ -- ^ Algebraic data types (including ones that started+ -- life as classes); generate constructors and info+ -- tables. Includes newtypes, just for the benefit of+ -- External Core++ cg_binds :: CoreProgram,+ -- ^ The tidied main bindings, including+ -- previously-implicit bindings for record and class+ -- selectors, and data constructor wrappers. But *not*+ -- data constructor workers; reason: we regard them+ -- as part of the code-gen of tycons++ cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs+ cg_foreign_files :: ![(ForeignSrcLang, FilePath)],+ cg_dep_pkgs :: ![UnitId], -- ^ Dependent packages, used to+ -- generate #includes for C code gen+ cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information+ cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints+ cg_spt_entries :: [SptEntry]+ -- ^ Static pointer table entries for static forms defined in+ -- the module.+ -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable"+ }
+ compiler/GHC/Unit/Module/ModIface.hs view
@@ -0,0 +1,535 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module GHC.Unit.Module.ModIface+ ( ModIface+ , ModIface_ (..)+ , PartialModIface+ , ModIfaceBackend (..)+ , IfaceDeclExts+ , IfaceBackendExts+ , IfaceExport+ , WhetherHasOrphans+ , WhetherHasFamInst+ , mi_boot+ , mi_fix+ , mi_semantic_module+ , mi_free_holes+ , renameFreeHoles+ , emptyPartialModIface+ , emptyFullModIface+ , mkIfaceHashCache+ , emptyIfaceHashCache+ )+where++import GHC.Prelude++import GHC.Hs++import GHC.Iface.Syntax+import GHC.Iface.Ext.Fields++import GHC.Unit+import GHC.Unit.Module.Deps+import GHC.Unit.Module.Warnings++import GHC.Types.Avail+import GHC.Types.Fixity+import GHC.Types.Fixity.Env+import GHC.Types.HpcInfo+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Types.SafeHaskell+import GHC.Types.SourceFile+import GHC.Types.Unique.DSet+import GHC.Types.Unique.FM++import GHC.Data.Maybe++import GHC.Utils.Fingerprint+import GHC.Utils.Binary++import Control.DeepSeq++{- Note [Interface file stages]+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Interface files have two possible stages.++* A partial stage built from the result of the core pipeline.+* A fully instantiated form. Which also includes fingerprints and+ potentially information provided by backends.++We can build a full interface file two ways:+* Directly from a partial one:+ Then we omit backend information and mostly compute fingerprints.+* From a partial one + information produced by a backend.+ Then we store the provided information and fingerprint both.+-}++type PartialModIface = ModIface_ 'ModIfaceCore+type ModIface = ModIface_ 'ModIfaceFinal++-- | Extends a PartialModIface with information which is either:+-- * Computed after codegen+-- * Or computed just before writing the iface to disk. (Hashes)+-- In order to fully instantiate it.+data ModIfaceBackend = ModIfaceBackend+ { mi_iface_hash :: !Fingerprint+ -- ^ Hash of the whole interface+ , mi_mod_hash :: !Fingerprint+ -- ^ Hash of the ABI only+ , mi_flag_hash :: !Fingerprint+ -- ^ Hash of the important flags used when compiling the module, excluding+ -- optimisation flags+ , mi_opt_hash :: !Fingerprint+ -- ^ Hash of optimisation flags+ , mi_hpc_hash :: !Fingerprint+ -- ^ Hash of hpc flags+ , mi_plugin_hash :: !Fingerprint+ -- ^ Hash of plugins+ , mi_orphan :: !WhetherHasOrphans+ -- ^ Whether this module has orphans+ , mi_finsts :: !WhetherHasFamInst+ -- ^ Whether this module has family instances. See Note [The type family+ -- instance consistency story].+ , mi_exp_hash :: !Fingerprint+ -- ^ Hash of export list+ , mi_orphan_hash :: !Fingerprint+ -- ^ Hash for orphan rules, class and family instances combined++ -- Cached environments for easy lookup. These are computed (lazily) from+ -- other fields and are not put into the interface file.+ -- Not really produced by the backend but there is no need to create them+ -- any earlier.+ , mi_warn_fn :: !(OccName -> Maybe WarningTxt)+ -- ^ Cached lookup for 'mi_warns'+ , mi_fix_fn :: !(OccName -> Maybe Fixity)+ -- ^ Cached lookup for 'mi_fixities'+ , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint))+ -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that+ -- the thing isn't in decls. It's useful to know that when seeing if we are+ -- up to date wrt. the old interface. The 'OccName' is the parent of the+ -- name, if it has one.+ }++data ModIfacePhase+ = ModIfaceCore+ -- ^ Partial interface built based on output of core pipeline.+ | ModIfaceFinal++-- | Selects a IfaceDecl representation.+-- For fully instantiated interfaces we also maintain+-- a fingerprint, which is used for recompilation checks.+type family IfaceDeclExts (phase :: ModIfacePhase) where+ IfaceDeclExts 'ModIfaceCore = IfaceDecl+ IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl)++type family IfaceBackendExts (phase :: ModIfacePhase) where+ IfaceBackendExts 'ModIfaceCore = ()+ IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend++++-- | A 'ModIface' plus a 'ModDetails' summarises everything we know+-- about a compiled module. The 'ModIface' is the stuff *before* linking,+-- and can be written out to an interface file. The 'ModDetails is after+-- linking and can be completely recovered from just the 'ModIface'.+--+-- When we read an interface file, we also construct a 'ModIface' from it,+-- except that we explicitly make the 'mi_decls' and a few other fields empty;+-- as when reading we consolidate the declarations etc. into a number of indexed+-- maps and environments in the 'ExternalPackageState'.+data ModIface_ (phase :: ModIfacePhase)+ = ModIface {+ mi_module :: !Module, -- ^ Name of the module we are for+ mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod?++ mi_hsc_src :: !HscSource, -- ^ Boot? Signature?++ mi_deps :: Dependencies,+ -- ^ The dependencies of the module. This is+ -- consulted for directly-imported modules, but not+ -- for anything else (hence lazy)++ mi_usages :: [Usage],+ -- ^ Usages; kept sorted so that it's easy to decide+ -- whether to write a new iface file (changing usages+ -- doesn't affect the hash of this module)+ -- NOT STRICT! we read this field lazily from the interface file+ -- It is *only* consulted by the recompilation checker++ mi_exports :: ![IfaceExport],+ -- ^ Exports+ -- Kept sorted by (mod,occ), to make version comparisons easier+ -- Records the modules that are the declaration points for things+ -- exported by this module, and the 'OccName's of those things+++ mi_used_th :: !Bool,+ -- ^ Module required TH splices when it was compiled.+ -- This disables recompilation avoidance (see #481).++ mi_fixities :: [(OccName,Fixity)],+ -- ^ Fixities+ -- NOT STRICT! we read this field lazily from the interface file++ mi_warns :: Warnings,+ -- ^ Warnings+ -- NOT STRICT! we read this field lazily from the interface file++ mi_anns :: [IfaceAnnotation],+ -- ^ Annotations+ -- NOT STRICT! we read this field lazily from the interface file+++ mi_decls :: [IfaceDeclExts phase],+ -- ^ Type, class and variable declarations+ -- The hash of an Id changes if its fixity or deprecations change+ -- (as well as its type of course)+ -- Ditto data constructors, class operations, except that+ -- the hash of the parent class/tycon changes++ mi_globals :: !(Maybe GlobalRdrEnv),+ -- ^ Binds all the things defined at the top level in+ -- the /original source/ code for this module. which+ -- is NOT the same as mi_exports, nor mi_decls (which+ -- may contains declarations for things not actually+ -- defined by the user). Used for GHCi and for inspecting+ -- the contents of modules via the GHC API only.+ --+ -- (We need the source file to figure out the+ -- top-level environment, if we didn't compile this module+ -- from source then this field contains @Nothing@).+ --+ -- Strictly speaking this field should live in the+ -- 'HomeModInfo', but that leads to more plumbing.++ -- Instance declarations and rules+ mi_insts :: [IfaceClsInst], -- ^ Sorted class instance+ mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances+ mi_rules :: [IfaceRule], -- ^ Sorted rules++ mi_hpc :: !AnyHpcUsage,+ -- ^ True if this program uses Hpc at any point in the program.++ mi_trust :: !IfaceTrustInfo,+ -- ^ Safe Haskell Trust information for this module.++ mi_trust_pkg :: !Bool,+ -- ^ Do we require the package this module resides in be trusted+ -- to trust this module? This is used for the situation where a+ -- module is Safe (so doesn't require the package be trusted+ -- itself) but imports some trustworthy modules from its own+ -- package (which does require its own package be trusted).+ -- See Note [Trust Own Package] in GHC.Rename.Names+ mi_complete_matches :: [IfaceCompleteMatch],++ mi_doc_hdr :: Maybe HsDocString,+ -- ^ Module header.++ mi_decl_docs :: DeclDocMap,+ -- ^ Docs on declarations.++ mi_arg_docs :: ArgDocMap,+ -- ^ Docs on arguments.++ mi_final_exts :: !(IfaceBackendExts phase),+ -- ^ Either `()` or `ModIfaceBackend` for+ -- a fully instantiated interface.++ mi_ext_fields :: ExtensibleFields+ -- ^ Additional optional fields, where the Map key represents+ -- the field name, resulting in a (size, serialized data) pair.+ -- Because the data is intended to be serialized through the+ -- internal `Binary` class (increasing compatibility with types+ -- using `Name` and `FastString`, such as HIE), this format is+ -- chosen over `ByteString`s.+ }++-- | Old-style accessor for whether or not the ModIface came from an hs-boot+-- file.+mi_boot :: ModIface -> IsBootInterface+mi_boot iface = if mi_hsc_src iface == HsBootFile+ then IsBoot+ else NotBoot++-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be+-- found, 'defaultFixity' is returned instead.+mi_fix :: ModIface -> OccName -> Fixity+mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity++-- | The semantic module for this interface; e.g., if it's a interface+-- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module'+-- will be @<A>@.+mi_semantic_module :: ModIface_ a -> Module+mi_semantic_module iface = case mi_sig_of iface of+ Nothing -> mi_module iface+ Just mod -> mod++-- | The "precise" free holes, e.g., the signatures that this+-- 'ModIface' depends on.+mi_free_holes :: ModIface -> UniqDSet ModuleName+mi_free_holes iface =+ case getModuleInstantiation (mi_module iface) of+ (_, Just indef)+ -- A mini-hack: we rely on the fact that 'renameFreeHoles'+ -- drops things that aren't holes.+ -> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef))+ _ -> emptyUniqDSet+ where+ cands = map gwib_mod $ dep_mods $ mi_deps iface++-- | Given a set of free holes, and a unit identifier, rename+-- the free holes according to the instantiation of the unit+-- identifier. For example, if we have A and B free, and+-- our unit identity is @p[A=<C>,B=impl:B]@, the renamed free+-- holes are just C.+renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName+renameFreeHoles fhs insts =+ unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs))+ where+ hmap = listToUFM insts+ lookup_impl mod_name+ | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod+ -- It wasn't actually a hole+ | otherwise = emptyUniqDSet+++instance Binary ModIface where+ put_ bh (ModIface {+ mi_module = mod,+ mi_sig_of = sig_of,+ mi_hsc_src = hsc_src,+ mi_deps = deps,+ mi_usages = usages,+ mi_exports = exports,+ mi_used_th = used_th,+ mi_fixities = fixities,+ mi_warns = warns,+ mi_anns = anns,+ mi_decls = decls,+ mi_insts = insts,+ mi_fam_insts = fam_insts,+ mi_rules = rules,+ mi_hpc = hpc_info,+ mi_trust = trust,+ mi_trust_pkg = trust_pkg,+ mi_complete_matches = complete_matches,+ mi_doc_hdr = doc_hdr,+ mi_decl_docs = decl_docs,+ mi_arg_docs = arg_docs,+ mi_ext_fields = _ext_fields, -- Don't `put_` this in the instance so we+ -- can deal with it's pointer in the header+ -- when we write the actual file+ mi_final_exts = ModIfaceBackend {+ mi_iface_hash = iface_hash,+ mi_mod_hash = mod_hash,+ mi_flag_hash = flag_hash,+ mi_opt_hash = opt_hash,+ mi_hpc_hash = hpc_hash,+ mi_plugin_hash = plugin_hash,+ mi_orphan = orphan,+ mi_finsts = hasFamInsts,+ mi_exp_hash = exp_hash,+ mi_orphan_hash = orphan_hash+ }}) = do+ put_ bh mod+ put_ bh sig_of+ put_ bh hsc_src+ put_ bh iface_hash+ put_ bh mod_hash+ put_ bh flag_hash+ put_ bh opt_hash+ put_ bh hpc_hash+ put_ bh plugin_hash+ put_ bh orphan+ put_ bh hasFamInsts+ lazyPut bh deps+ lazyPut bh usages+ put_ bh exports+ put_ bh exp_hash+ put_ bh used_th+ put_ bh fixities+ lazyPut bh warns+ lazyPut bh anns+ put_ bh decls+ put_ bh insts+ put_ bh fam_insts+ lazyPut bh rules+ put_ bh orphan_hash+ put_ bh hpc_info+ put_ bh trust+ put_ bh trust_pkg+ put_ bh complete_matches+ lazyPut bh doc_hdr+ lazyPut bh decl_docs+ lazyPut bh arg_docs++ get bh = do+ mod <- get bh+ sig_of <- get bh+ hsc_src <- get bh+ iface_hash <- get bh+ mod_hash <- get bh+ flag_hash <- get bh+ opt_hash <- get bh+ hpc_hash <- get bh+ plugin_hash <- get bh+ orphan <- get bh+ hasFamInsts <- get bh+ deps <- lazyGet bh+ usages <- {-# SCC "bin_usages" #-} lazyGet bh+ exports <- {-# SCC "bin_exports" #-} get bh+ exp_hash <- get bh+ used_th <- get bh+ fixities <- {-# SCC "bin_fixities" #-} get bh+ warns <- {-# SCC "bin_warns" #-} lazyGet bh+ anns <- {-# SCC "bin_anns" #-} lazyGet bh+ decls <- {-# SCC "bin_tycldecls" #-} get bh+ insts <- {-# SCC "bin_insts" #-} get bh+ fam_insts <- {-# SCC "bin_fam_insts" #-} get bh+ rules <- {-# SCC "bin_rules" #-} lazyGet bh+ orphan_hash <- get bh+ hpc_info <- get bh+ trust <- get bh+ trust_pkg <- get bh+ complete_matches <- get bh+ doc_hdr <- lazyGet bh+ decl_docs <- lazyGet bh+ arg_docs <- lazyGet bh+ return (ModIface {+ mi_module = mod,+ mi_sig_of = sig_of,+ mi_hsc_src = hsc_src,+ mi_deps = deps,+ mi_usages = usages,+ mi_exports = exports,+ mi_used_th = used_th,+ mi_anns = anns,+ mi_fixities = fixities,+ mi_warns = warns,+ mi_decls = decls,+ mi_globals = Nothing,+ mi_insts = insts,+ mi_fam_insts = fam_insts,+ mi_rules = rules,+ mi_hpc = hpc_info,+ mi_trust = trust,+ mi_trust_pkg = trust_pkg,+ -- And build the cached values+ mi_complete_matches = complete_matches,+ mi_doc_hdr = doc_hdr,+ mi_decl_docs = decl_docs,+ mi_arg_docs = arg_docs,+ mi_ext_fields = emptyExtensibleFields, -- placeholder because this is dealt+ -- with specially when the file is read+ mi_final_exts = ModIfaceBackend {+ mi_iface_hash = iface_hash,+ mi_mod_hash = mod_hash,+ mi_flag_hash = flag_hash,+ mi_opt_hash = opt_hash,+ mi_hpc_hash = hpc_hash,+ mi_plugin_hash = plugin_hash,+ mi_orphan = orphan,+ mi_finsts = hasFamInsts,+ mi_exp_hash = exp_hash,+ mi_orphan_hash = orphan_hash,+ mi_warn_fn = mkIfaceWarnCache warns,+ mi_fix_fn = mkIfaceFixCache fixities,+ mi_hash_fn = mkIfaceHashCache decls+ }})++-- | The original names declared of a certain module that are exported+type IfaceExport = AvailInfo++emptyPartialModIface :: Module -> PartialModIface+emptyPartialModIface mod+ = ModIface { mi_module = mod,+ mi_sig_of = Nothing,+ mi_hsc_src = HsSrcFile,+ mi_deps = noDependencies,+ mi_usages = [],+ mi_exports = [],+ mi_used_th = False,+ mi_fixities = [],+ mi_warns = NoWarnings,+ mi_anns = [],+ mi_insts = [],+ mi_fam_insts = [],+ mi_rules = [],+ mi_decls = [],+ mi_globals = Nothing,+ mi_hpc = False,+ mi_trust = noIfaceTrustInfo,+ mi_trust_pkg = False,+ mi_complete_matches = [],+ mi_doc_hdr = Nothing,+ mi_decl_docs = emptyDeclDocMap,+ mi_arg_docs = emptyArgDocMap,+ mi_final_exts = (),+ mi_ext_fields = emptyExtensibleFields+ }++emptyFullModIface :: Module -> ModIface+emptyFullModIface mod =+ (emptyPartialModIface mod)+ { mi_decls = []+ , mi_final_exts = ModIfaceBackend+ { mi_iface_hash = fingerprint0,+ mi_mod_hash = fingerprint0,+ mi_flag_hash = fingerprint0,+ mi_opt_hash = fingerprint0,+ mi_hpc_hash = fingerprint0,+ mi_plugin_hash = fingerprint0,+ mi_orphan = False,+ mi_finsts = False,+ mi_exp_hash = fingerprint0,+ mi_orphan_hash = fingerprint0,+ mi_warn_fn = emptyIfaceWarnCache,+ mi_fix_fn = emptyIfaceFixCache,+ mi_hash_fn = emptyIfaceHashCache } }++-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'+mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]+ -> (OccName -> Maybe (OccName, Fingerprint))+mkIfaceHashCache pairs+ = \occ -> lookupOccEnv env occ+ where+ env = foldl' add_decl emptyOccEnv pairs+ add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d)+ where+ add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash)++emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)+emptyIfaceHashCache _occ = Nothing++-- Take care, this instance only forces to the degree necessary to+-- avoid major space leaks.+instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where+ rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12+ f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) =+ rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq`+ f9 `seq` rnf f10 `seq` rnf f11 `seq` 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+ `seq` rnf f24++-- | Records whether a module has orphans. An \"orphan\" is one of:+--+-- * An instance declaration in a module other than the definition+-- module for one of the type constructors or classes in the instance head+--+-- * A rewrite rule in a module other than the one defining+-- the function in the head of the rule+--+type WhetherHasOrphans = Bool++-- | Does this module define family instances?+type WhetherHasFamInst = Bool+++
+ compiler/GHC/Unit/Module/ModSummary.hs view
@@ -0,0 +1,190 @@+-- | A ModSummary is a node in the compilation manager's dependency graph+-- (ModuleGraph)+module GHC.Unit.Module.ModSummary+ ( ModSummary (..)+ , ms_installed_mod+ , ms_mod_name+ , ms_imps+ , ms_home_allimps+ , ms_home_srcimps+ , ms_home_imps+ , msHiFilePath+ , msHsFilePath+ , msObjFilePath+ , msDynObjFilePath+ , isBootSummary+ , showModMsg+ , findTarget+ )+where++import GHC.Prelude++import GHC.Hs++import GHC.Driver.Ppr+import GHC.Driver.Session+import GHC.Driver.Backend++import GHC.Unit.Types+import GHC.Unit.Module++import GHC.Types.SourceFile ( HscSource(..), hscSourceString )+import GHC.Types.SrcLoc+import GHC.Types.Target++import GHC.Data.Maybe+import GHC.Data.FastString+import GHC.Data.StringBuffer ( StringBuffer )++import GHC.Utils.Outputable++import Data.Time+import System.FilePath++-- | A single node in a 'ModuleGraph'. The nodes of the module graph+-- are one of:+--+-- * A regular Haskell source module+-- * A hi-boot source module+--+data ModSummary+ = ModSummary {+ ms_mod :: Module,+ -- ^ Identity of the module+ ms_hsc_src :: HscSource,+ -- ^ The module source either plain Haskell or hs-boot+ ms_location :: ModLocation,+ -- ^ Location of the various files belonging to the module+ ms_hs_date :: UTCTime,+ -- ^ Timestamp of source file+ ms_obj_date :: Maybe UTCTime,+ -- ^ Timestamp of object, if we have one+ ms_iface_date :: Maybe UTCTime,+ -- ^ Timestamp of hi file, if we *only* are typechecking (it is+ -- 'Nothing' otherwise.+ -- See Note [Recompilation checking in -fno-code mode] and #9243+ ms_hie_date :: Maybe UTCTime,+ -- ^ Timestamp of hie file, if we have one+ ms_srcimps :: [(Maybe FastString, Located ModuleName)],+ -- ^ Source imports of the module+ ms_textual_imps :: [(Maybe FastString, Located ModuleName)],+ -- ^ Non-source imports of the module from the module *text*+ 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.+ ms_hspp_file :: FilePath,+ -- ^ Filename of preprocessed source file+ ms_hspp_opts :: DynFlags,+ -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@+ -- pragmas in the modules source code+ ms_hspp_buf :: Maybe StringBuffer+ -- ^ The actual preprocessed source, if we have it+ }++ms_installed_mod :: ModSummary -> InstalledModule+ms_installed_mod = fst . getModuleInstantiation . ms_mod++ms_mod_name :: ModSummary -> ModuleName+ms_mod_name = moduleName . ms_mod++ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]+ms_imps ms =+ ms_textual_imps ms +++ map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms))+ where+ mk_additional_import mod_nm = (Nothing, noLoc mod_nm)++home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]+home_imps imps = [ lmodname | (mb_pkg, lmodname) <- imps,+ isLocal mb_pkg ]+ where isLocal Nothing = True+ isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special+ isLocal _ = False++ms_home_allimps :: ModSummary -> [ModuleName]+ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)++-- | Like 'ms_home_imps', but for SOURCE imports.+ms_home_srcimps :: ModSummary -> [Located ModuleName]+ms_home_srcimps = home_imps . ms_srcimps++-- | All of the (possibly) home module imports from a+-- 'ModSummary'; that is to say, each of these module names+-- could be a home import if an appropriately named file+-- existed. (This is in contrast to package qualified+-- imports, which are guaranteed not to be home imports.)+ms_home_imps :: ModSummary -> [Located ModuleName]+ms_home_imps = home_imps . ms_imps++-- The ModLocation contains both the original source filename and the+-- filename of the cleaned-up source file after all preprocessing has been+-- done. The point is that the summariser will have to cpp/unlit/whatever+-- all files anyway, and there's no point in doing this twice -- just+-- park the result in a temp file, put the name of it in the location,+-- and let @compile@ read from that file on the way back up.++-- The ModLocation is stable over successive up-sweeps in GHCi, wheres+-- the ms_hs_date and imports can, of course, change++msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath+msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms))+msHiFilePath ms = ml_hi_file (ms_location ms)+msObjFilePath ms = ml_obj_file (ms_location ms)++msDynObjFilePath :: ModSummary -> DynFlags -> FilePath+msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms)++-- | Did this 'ModSummary' originate from a hs-boot file?+isBootSummary :: ModSummary -> IsBootInterface+isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot++instance Outputable ModSummary where+ ppr ms+ = sep [text "ModSummary {",+ nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),+ text "ms_mod =" <+> ppr (ms_mod ms)+ <> text (hscSourceString (ms_hsc_src ms)) <> comma,+ text "ms_textual_imps =" <+> ppr (ms_textual_imps ms),+ text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),+ char '}'+ ]++showModMsg :: DynFlags -> Bool -> ModSummary -> SDoc+showModMsg dflags recomp mod_summary =+ if gopt Opt_HideSourcePaths dflags+ then text mod_str+ else hsep $+ [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')+ , char '('+ , text (op $ msHsFilePath mod_summary) <> char ','+ ] +++ if gopt Opt_BuildDynamicToo dflags+ then [ text obj_file <> char ','+ , text dyn_file+ , char ')'+ ]+ else [ text obj_file, char ')' ]+ where+ op = normalise+ mod = moduleName (ms_mod mod_summary)+ mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)+ dyn_file = op $ msDynObjFilePath mod_summary dflags+ obj_file = case backend dflags of+ Interpreter | recomp -> "interpreted"+ NoBackend -> "nothing"+ _ -> (op $ msObjFilePath mod_summary)++findTarget :: ModSummary -> [Target] -> Maybe Target+findTarget ms ts =+ case filter (matches ms) ts of+ [] -> Nothing+ (t:_) -> Just t+ where+ summary `matches` Target (TargetModule m) _ _+ = ms_mod_name summary == m+ summary `matches` Target (TargetFile f _) _ _+ | Just f' <- ml_hs_file (ms_location summary)+ = f == f'+ _ `matches` _+ = False
+ compiler/GHC/Unit/Module/Status.hs view
@@ -0,0 +1,46 @@+module GHC.Unit.Module.Status+ ( HscStatus (..)+ )+where++import GHC.Prelude++import GHC.Driver.Session++import GHC.Unit+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails++import GHC.Utils.Fingerprint++-- | Status of a module compilation to machine code+data HscStatus+ -- | Nothing to do.+ = HscNotGeneratingCode ModIface ModDetails+ -- | Nothing to do because code already exists.+ | HscUpToDate ModIface ModDetails+ -- | Update boot file result.+ | HscUpdateBoot ModIface ModDetails+ -- | Generate signature file (backpack)+ | HscUpdateSig ModIface ModDetails+ -- | Recompile this module.+ | HscRecomp+ { hscs_guts :: CgGuts+ -- ^ Information for the code generator.+ , hscs_mod_location :: !ModLocation+ -- ^ Module info+ , hscs_mod_details :: !ModDetails+ , hscs_partial_iface :: !PartialModIface+ -- ^ Partial interface+ , hscs_old_iface_hash :: !(Maybe Fingerprint)+ -- ^ Old interface hash for this compilation, if an old interface file+ -- exists. Pass to `hscMaybeWriteIface` when writing the interface to+ -- avoid updating the existing interface when the interface isn't+ -- changed.+ , hscs_iface_dflags :: !DynFlags+ -- ^ Generate final iface using this DynFlags.+ -- FIXME (osa): I don't understand why this is necessary, but I spent+ -- almost two days trying to figure this out and I couldn't .. perhaps+ -- someone who understands this code better will remove this later.+ }
+ compiler/GHC/Unit/Module/Warnings.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Warnings for a module+module GHC.Unit.Module.Warnings+ ( Warnings (..)+ , WarningTxt (..)+ , pprWarningTxtForMsg+ , mkIfaceWarnCache+ , emptyIfaceWarnCache+ , plusWarns+ )+where++import GHC.Prelude++import GHC.Types.SourceText+import GHC.Types.Name.Occurrence+import GHC.Types.SrcLoc++import GHC.Utils.Outputable+import GHC.Utils.Binary++import Data.Data++-- | Warning Text+--+-- reason/explanation from a WARNING or DEPRECATED pragma+data WarningTxt+ = WarningTxt+ (Located SourceText)+ [Located StringLiteral]+ | DeprecatedTxt+ (Located SourceText)+ [Located StringLiteral]+ deriving (Eq, Data)++instance Outputable WarningTxt where+ ppr (WarningTxt lsrc ws)+ = case unLoc lsrc of+ NoSourceText -> pp_ws ws+ SourceText src -> text src <+> pp_ws ws <+> text "#-}"++ ppr (DeprecatedTxt lsrc ds)+ = case unLoc lsrc of+ NoSourceText -> pp_ws ds+ SourceText src -> text src <+> pp_ws ds <+> text "#-}"++instance Binary WarningTxt where+ put_ bh (WarningTxt s w) = do+ putByte bh 0+ put_ bh s+ put_ bh w+ put_ bh (DeprecatedTxt s d) = do+ putByte bh 1+ put_ bh s+ put_ bh d++ get bh = do+ h <- getByte bh+ case h of+ 0 -> do s <- get bh+ w <- get bh+ return (WarningTxt s w)+ _ -> do s <- get bh+ d <- get bh+ return (DeprecatedTxt s d)+++pp_ws :: [Located StringLiteral] -> SDoc+pp_ws [l] = ppr $ unLoc l+pp_ws ws+ = text "["+ <+> vcat (punctuate comma (map (ppr . unLoc) ws))+ <+> text "]"+++pprWarningTxtForMsg :: WarningTxt -> SDoc+pprWarningTxtForMsg (WarningTxt _ ws)+ = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))+pprWarningTxtForMsg (DeprecatedTxt _ ds)+ = text "Deprecated:" <+>+ doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))+++-- | Warning information for a module+data Warnings+ = NoWarnings -- ^ Nothing deprecated+ | WarnAll WarningTxt -- ^ Whole module deprecated+ | WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated++ -- Only an OccName is needed because+ -- (1) a deprecation always applies to a binding+ -- defined in the module in which the deprecation appears.+ -- (2) deprecations are only reported outside the defining module.+ -- this is important because, otherwise, if we saw something like+ --+ -- {-# DEPRECATED f "" #-}+ -- f = ...+ -- h = f+ -- g = let f = undefined in f+ --+ -- we'd need more information than an OccName to know to say something+ -- about the use of f in h but not the use of the locally bound f in g+ --+ -- however, because we only report about deprecations from the outside,+ -- and a module can only export one value called f,+ -- an OccName suffices.+ --+ -- this is in contrast with fixity declarations, where we need to map+ -- a Name to its fixity declaration.+ deriving( Eq )++instance Binary Warnings where+ put_ bh NoWarnings = putByte bh 0+ put_ bh (WarnAll t) = do+ putByte bh 1+ put_ bh t+ put_ bh (WarnSome ts) = do+ putByte bh 2+ put_ bh ts++ get bh = do+ h <- getByte bh+ case h of+ 0 -> return NoWarnings+ 1 -> do aa <- get bh+ return (WarnAll aa)+ _ -> do aa <- get bh+ return (WarnSome aa)++-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'+mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt+mkIfaceWarnCache NoWarnings = \_ -> Nothing+mkIfaceWarnCache (WarnAll t) = \_ -> Just t+mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs)++emptyIfaceWarnCache :: OccName -> Maybe WarningTxt+emptyIfaceWarnCache _ = Nothing++plusWarns :: Warnings -> Warnings -> Warnings+plusWarns d NoWarnings = d+plusWarns NoWarnings d = d+plusWarns _ (WarnAll t) = WarnAll t+plusWarns (WarnAll t) _ = WarnAll t+plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2)+
compiler/GHC/Unit/State.hs view
@@ -99,6 +99,7 @@ import System.Environment ( getEnv ) import GHC.Data.FastString+import qualified GHC.Data.ShortText as ST import GHC.Utils.Error ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, withTiming, DumpFormat (..) ) import GHC.Utils.Exception@@ -714,7 +715,7 @@ <+> text conf_dir <> text ", treating" <+> text "package database as empty" return []- else do+ else throwGhcExceptionIO $ InstallationError $ "there is no package.cache in " ++ conf_dir ++ " even though package database is not empty"@@ -749,7 +750,7 @@ -> UnitInfo -> UnitInfo mungeUnitInfo top_dir pkgroot = mungeDynLibFields- . mungeUnitInfoPaths top_dir pkgroot+ . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot) mungeDynLibFields :: UnitInfo -> UnitInfo mungeDynLibFields pkg =@@ -1797,7 +1798,7 @@ collectIncludeDirs `fmap` getPreloadUnitsAnd ctx unit_state home_unit pkgs collectIncludeDirs :: [UnitInfo] -> [FilePath]-collectIncludeDirs ps = ordNub (filter notNull (concatMap unitIncludeDirs ps))+collectIncludeDirs ps = map ST.unpack $ ordNub (filter (not . ST.null) (concatMap unitIncludeDirs ps)) -- | Find all the library paths in these and the preload packages getUnitLibraryPath :: SDocContext -> UnitState -> HomeUnit -> Ways -> [UnitId] -> IO [String]@@ -1822,8 +1823,8 @@ collectLinkOpts dflags ps = ( concatMap (map ("-l" ++) . packageHsLibs dflags) ps,- concatMap (map ("-l" ++) . unitExtDepLibsSys) ps,- concatMap unitLinkerOptions ps+ concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps,+ concatMap (map ST.unpack . unitLinkerOptions) ps ) collectArchives :: DynFlags -> UnitInfo -> IO [FilePath] collectArchives dflags pc =@@ -1831,7 +1832,7 @@ | searchPath <- searchPaths , lib <- libs ] where searchPaths = ordNub . filter notNull . libraryDirsForWay (ways dflags) $ pc- libs = packageHsLibs dflags pc ++ unitExtDepLibsSys pc+ libs = packageHsLibs dflags pc ++ (map ST.unpack $ unitExtDepLibsSys pc) getLibs :: DynFlags -> [UnitId] -> IO [(String,String)] getLibs dflags pkgs = do@@ -1846,7 +1847,7 @@ filterM (doesFileExist . fst) candidates packageHsLibs :: DynFlags -> UnitInfo -> [String]-packageHsLibs dflags p = map (mkDynName . addSuffix) (unitLibraries p)+packageHsLibs dflags p = map (mkDynName . addSuffix . ST.unpack) (unitLibraries p) where ways0 = ways dflags @@ -1856,11 +1857,11 @@ -- debug and profiled RTSs include support for -eventlog ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1- = Set.filter (/= WayEventLog) ways1+ = Set.filter (/= WayTracing) ways1 | otherwise = ways1 - tag = waysTag (Set.filter (not . wayRTSOnly) ways2)+ tag = waysTag (fullWays ways2) rts_tag = waysTag ways2 mkDynName x@@ -1895,27 +1896,27 @@ -- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. libraryDirsForWay :: Ways -> UnitInfo -> [String]-libraryDirsForWay ws- | WayDyn `elem` ws = unitLibraryDynDirs- | otherwise = unitLibraryDirs+libraryDirsForWay ws ui+ | WayDyn `elem` ws = map ST.unpack $ unitLibraryDynDirs ui+ | otherwise = map ST.unpack $ unitLibraryDirs ui -- | Find all the C-compiler options in these and the preload packages getUnitExtraCcOpts :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String] getUnitExtraCcOpts ctx unit_state home_unit pkgs = do ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs- return (concatMap unitCcOptions ps)+ return $ map ST.unpack (concatMap unitCcOptions ps) -- | Find all the package framework paths in these and the preload packages getUnitFrameworkPath :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String] getUnitFrameworkPath ctx unit_state home_unit pkgs = do ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs- return (ordNub (filter notNull (concatMap unitExtDepFrameworkDirs ps)))+ return $ map ST.unpack (ordNub (filter (not . ST.null) (concatMap unitExtDepFrameworkDirs ps))) -- | Find all the package frameworks in these and the preload packages getUnitFrameworks :: SDocContext -> UnitState -> HomeUnit -> [UnitId] -> IO [String] getUnitFrameworks ctx unit_state home_unit pkgs = do ps <- getPreloadUnitsAnd ctx unit_state home_unit pkgs- return (concatMap unitExtDepFrameworks ps)+ return $ map ST.unpack (concatMap unitExtDepFrameworks ps) -- ----------------------------------------------------------------------------- -- Package Utils
compiler/GHC/Unit/Types.hs view
@@ -349,7 +349,7 @@ put_ bh (VirtUnit indef_uid) = do putByte bh 1 put_ bh indef_uid- put_ bh HoleUnit = do+ put_ bh HoleUnit = putByte bh 2 get bh = do b <- getByte bh case b of
compiler/GHC/Utils/Binary.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -77,7 +76,6 @@ import GHC.Types.Unique.FM import GHC.Data.FastMutInt import GHC.Utils.Fingerprint-import GHC.Types.Basic import GHC.Types.SrcLoc import Control.DeepSeq@@ -90,16 +88,11 @@ import Data.Char ( ord, chr ) import Data.Time import Data.List (unfoldr)-import Type.Reflection-import Type.Reflection.Unsafe-import Data.Kind (Type)-import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) import Control.Monad ( when, (<$!>), unless ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) import GHC.Real ( Ratio(..) )-import GHC.Serialized type BinArray = ForeignPtr Word8 @@ -870,185 +863,8 @@ put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32) get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) --- -------------------------------------------------------------------------------- Instances for Data.Typeable stuff -instance Binary TyCon where- put_ bh tc = do- put_ bh (tyConPackage tc)- put_ bh (tyConModule tc)- put_ bh (tyConName tc)- put_ bh (tyConKindArgs tc)- put_ bh (tyConKindRep tc)- get bh =- mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh -instance Binary VecCount where- put_ bh = putByte bh . fromIntegral . fromEnum- get bh = toEnum . fromIntegral <$> getByte bh--instance Binary VecElem where- put_ bh = putByte bh . fromIntegral . fromEnum- get bh = toEnum . fromIntegral <$> getByte bh--instance Binary RuntimeRep where- put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b- put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps- put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps- put_ bh LiftedRep = putByte bh 3- put_ bh UnliftedRep = putByte bh 4- put_ bh IntRep = putByte bh 5- put_ bh WordRep = putByte bh 6- put_ bh Int64Rep = putByte bh 7- put_ bh Word64Rep = putByte bh 8- put_ bh AddrRep = putByte bh 9- put_ bh FloatRep = putByte bh 10- put_ bh DoubleRep = putByte bh 11- put_ bh Int8Rep = putByte bh 12- put_ bh Word8Rep = putByte bh 13- put_ bh Int16Rep = putByte bh 14- put_ bh Word16Rep = putByte bh 15-#if __GLASGOW_HASKELL__ >= 809- put_ bh Int32Rep = putByte bh 16- put_ bh Word32Rep = putByte bh 17-#endif-- get bh = do- tag <- getByte bh- case tag of- 0 -> VecRep <$> get bh <*> get bh- 1 -> TupleRep <$> get bh- 2 -> SumRep <$> get bh- 3 -> pure LiftedRep- 4 -> pure UnliftedRep- 5 -> pure IntRep- 6 -> pure WordRep- 7 -> pure Int64Rep- 8 -> pure Word64Rep- 9 -> pure AddrRep- 10 -> pure FloatRep- 11 -> pure DoubleRep- 12 -> pure Int8Rep- 13 -> pure Word8Rep- 14 -> pure Int16Rep- 15 -> pure Word16Rep-#if __GLASGOW_HASKELL__ >= 809- 16 -> pure Int32Rep- 17 -> pure Word32Rep-#endif- _ -> fail "Binary.putRuntimeRep: invalid tag"--instance Binary KindRep where- put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k- put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr- put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b- put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b- put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r- put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r-- get bh = do- tag <- getByte bh- case tag of- 0 -> KindRepTyConApp <$> get bh <*> get bh- 1 -> KindRepVar <$> get bh- 2 -> KindRepApp <$> get bh <*> get bh- 3 -> KindRepFun <$> get bh <*> get bh- 4 -> KindRepTYPE <$> get bh- 5 -> KindRepTypeLit <$> get bh <*> get bh- _ -> fail "Binary.putKindRep: invalid tag"--instance Binary TypeLitSort where- put_ bh TypeLitSymbol = putByte bh 0- put_ bh TypeLitNat = putByte bh 1- get bh = do- tag <- getByte bh- case tag of- 0 -> pure TypeLitSymbol- 1 -> pure TypeLitNat- _ -> fail "Binary.putTypeLitSort: invalid tag"--putTypeRep :: BinHandle -> TypeRep a -> IO ()--- Special handling for TYPE, (->), and RuntimeRep due to recursive kind--- relations.--- See Note [Mutually recursive representations of primitive types]-putTypeRep bh rep- | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)- = put_ bh (0 :: Word8)-putTypeRep bh (Con' con ks) = do- put_ bh (1 :: Word8)- put_ bh con- put_ bh ks-putTypeRep bh (App f x) = do- put_ bh (2 :: Word8)- putTypeRep bh f- putTypeRep bh x-putTypeRep bh (Fun arg res) = do- put_ bh (3 :: Word8)- putTypeRep bh arg- putTypeRep bh res--getSomeTypeRep :: BinHandle -> IO SomeTypeRep-getSomeTypeRep bh = do- tag <- get bh :: IO Word8- case tag of- 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)- 1 -> do con <- get bh :: IO TyCon- ks <- get bh :: IO [SomeTypeRep]- return $ SomeTypeRep $ mkTrCon con ks-- 2 -> do SomeTypeRep f <- getSomeTypeRep bh- SomeTypeRep x <- getSomeTypeRep bh- case typeRepKind f of- Fun arg res ->- case arg `eqTypeRep` typeRepKind x of- Just HRefl ->- case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of- Just HRefl -> return $ SomeTypeRep $ mkTrApp f x- _ -> failure "Kind mismatch in type application" []- _ -> failure "Kind mismatch in type application"- [ " Found argument of kind: " ++ show (typeRepKind x)- , " Where the constructor: " ++ show f- , " Expects kind: " ++ show arg- ]- _ -> failure "Applied non-arrow"- [ " Applied type: " ++ show f- , " To argument: " ++ show x- ]- 3 -> do SomeTypeRep arg <- getSomeTypeRep bh- SomeTypeRep res <- getSomeTypeRep bh- if- | App argkcon _ <- typeRepKind arg- , App reskcon _ <- typeRepKind res- , Just HRefl <- argkcon `eqTypeRep` tYPErep- , Just HRefl <- reskcon `eqTypeRep` tYPErep- -> return $ SomeTypeRep $ Fun arg res- | otherwise -> failure "Kind mismatch" []- _ -> failure "Invalid SomeTypeRep" []- where- tYPErep :: TypeRep TYPE- tYPErep = typeRep-- failure description info =- fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]- ++ map (" "++) info--instance Typeable a => Binary (TypeRep (a :: k)) where- put_ = putTypeRep- get bh = do- SomeTypeRep rep <- getSomeTypeRep bh- case rep `eqTypeRep` expected of- Just HRefl -> pure rep- Nothing -> fail $ unlines- [ "Binary: Type mismatch"- , " Deserialized type: " ++ show rep- , " Expected type: " ++ show expected- ]- where expected = typeRep :: TypeRep a--instance Binary SomeTypeRep where- put_ bh (SomeTypeRep rep) = putTypeRep bh rep- get = getSomeTypeRep- -- ----------------------------------------------------------------------------- -- Lazy reading/writing @@ -1212,207 +1028,10 @@ deriving instance Binary NonDetFastString deriving instance Binary LexicalFastString --- Here to avoid loop-instance Binary LeftOrRight where- put_ bh CLeft = putByte bh 0- put_ bh CRight = putByte bh 1-- get bh = do { h <- getByte bh- ; case h of- 0 -> return CLeft- _ -> return CRight }--instance Binary PromotionFlag where- put_ bh NotPromoted = putByte bh 0- put_ bh IsPromoted = putByte bh 1-- get bh = do- n <- getByte bh- case n of- 0 -> return NotPromoted- 1 -> return IsPromoted- _ -> fail "Binary(IsPromoted): fail)"- instance Binary Fingerprint where put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) -instance Binary FunctionOrData where- put_ bh IsFunction = putByte bh 0- put_ bh IsData = putByte bh 1- get bh = do- h <- getByte bh- case h of- 0 -> return IsFunction- 1 -> return IsData- _ -> panic "Binary FunctionOrData"--instance Binary TupleSort where- put_ bh BoxedTuple = putByte bh 0- put_ bh UnboxedTuple = putByte bh 1- put_ bh ConstraintTuple = putByte bh 2- get bh = do- h <- getByte bh- case h of- 0 -> do return BoxedTuple- 1 -> do return UnboxedTuple- _ -> do return ConstraintTuple--instance Binary Activation where- put_ bh NeverActive = do- putByte bh 0- put_ bh FinalActive = do- putByte bh 1- put_ bh AlwaysActive = do- putByte bh 2- put_ bh (ActiveBefore src aa) = do- putByte bh 3- put_ bh src- put_ bh aa- put_ bh (ActiveAfter src ab) = do- putByte bh 4- put_ bh src- put_ bh ab- get bh = do- h <- getByte bh- case h of- 0 -> do return NeverActive- 1 -> do return FinalActive- 2 -> do return AlwaysActive- 3 -> do src <- get bh- aa <- get bh- return (ActiveBefore src aa)- _ -> do src <- get bh- ab <- get bh- return (ActiveAfter src ab)--instance Binary InlinePragma where- put_ bh (InlinePragma s a b c d) = do- put_ bh s- put_ bh a- put_ bh b- put_ bh c- put_ bh d-- get bh = do- s <- get bh- a <- get bh- b <- get bh- c <- get bh- d <- get bh- return (InlinePragma s a b c d)--instance Binary RuleMatchInfo where- put_ bh FunLike = putByte bh 0- put_ bh ConLike = putByte bh 1- get bh = do- h <- getByte bh- if h == 1 then return ConLike- else return FunLike--instance Binary InlineSpec where- put_ bh NoUserInline = putByte bh 0- put_ bh Inline = putByte bh 1- put_ bh Inlinable = putByte bh 2- put_ bh NoInline = putByte bh 3-- get bh = do h <- getByte bh- case h of- 0 -> return NoUserInline- 1 -> return Inline- 2 -> return Inlinable- _ -> return NoInline--instance Binary RecFlag where- put_ bh Recursive = do- putByte bh 0- put_ bh NonRecursive = do- putByte bh 1- get bh = do- h <- getByte bh- case h of- 0 -> do return Recursive- _ -> do return NonRecursive--instance Binary OverlapMode where- put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s- put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s- put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s- put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s- put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s- get bh = do- h <- getByte bh- case h of- 0 -> (get bh) >>= \s -> return $ NoOverlap s- 1 -> (get bh) >>= \s -> return $ Overlaps s- 2 -> (get bh) >>= \s -> return $ Incoherent s- 3 -> (get bh) >>= \s -> return $ Overlapping s- 4 -> (get bh) >>= \s -> return $ Overlappable s- _ -> panic ("get OverlapMode" ++ show h)---instance Binary OverlapFlag where- put_ bh flag = do put_ bh (overlapMode flag)- put_ bh (isSafeOverlap flag)- get bh = do- h <- get bh- b <- get bh- return OverlapFlag { overlapMode = h, isSafeOverlap = b }--instance Binary FixityDirection where- put_ bh InfixL = do- putByte bh 0- put_ bh InfixR = do- putByte bh 1- put_ bh InfixN = do- putByte bh 2- get bh = do- h <- getByte bh- case h of- 0 -> do return InfixL- 1 -> do return InfixR- _ -> do return InfixN--instance Binary Fixity where- put_ bh (Fixity src aa ab) = do- put_ bh src- put_ bh aa- put_ bh ab- get bh = do- src <- get bh- aa <- get bh- ab <- get bh- return (Fixity src aa ab)--instance Binary WarningTxt where- put_ bh (WarningTxt s w) = do- putByte bh 0- put_ bh s- put_ bh w- put_ bh (DeprecatedTxt s d) = do- putByte bh 1- put_ bh s- put_ bh d-- get bh = do- h <- getByte bh- case h of- 0 -> do s <- get bh- w <- get bh- return (WarningTxt s w)- _ -> do s <- get bh- d <- get bh- return (DeprecatedTxt s d)--instance Binary StringLiteral where- put_ bh (StringLiteral st fs) = do- put_ bh st- put_ bh fs- get bh = do- st <- get bh- fs <- get bh- return (StringLiteral st fs)- instance Binary a => Binary (Located a) where put_ bh (L l x) = do put_ bh l@@ -1488,27 +1107,3 @@ return (RealSrcSpan ss sb) _ -> do s <- get bh return (UnhelpfulSpan s)--instance Binary Serialized where- put_ bh (Serialized the_type bytes) = do- put_ bh the_type- put_ bh bytes- get bh = do- the_type <- get bh- bytes <- get bh- return (Serialized the_type bytes)--instance Binary SourceText where- put_ bh NoSourceText = putByte bh 0- put_ bh (SourceText s) = do- putByte bh 1- put_ bh s-- get bh = do- h <- getByte bh- case h of- 0 -> return NoSourceText- 1 -> do- s <- get bh- return (SourceText s)- _ -> panic $ "Binary SourceText:" ++ show h
+ compiler/GHC/Utils/Binary/Typeable.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE GADTs #-}++{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Orphan Binary instances for Data.Typeable stuff+module GHC.Utils.Binary.Typeable+ ( getSomeTypeRep+ )+where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Utils.Binary++import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..))+import GHC.Serialized++import Foreign+import Type.Reflection+import Type.Reflection.Unsafe+import Data.Kind (Type)+++instance Binary TyCon where+ put_ bh tc = do+ put_ bh (tyConPackage tc)+ put_ bh (tyConModule tc)+ put_ bh (tyConName tc)+ put_ bh (tyConKindArgs tc)+ put_ bh (tyConKindRep tc)+ get bh =+ mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh++getSomeTypeRep :: BinHandle -> IO SomeTypeRep+getSomeTypeRep bh = do+ tag <- get bh :: IO Word8+ case tag of+ 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)+ 1 -> do con <- get bh :: IO TyCon+ ks <- get bh :: IO [SomeTypeRep]+ return $ SomeTypeRep $ mkTrCon con ks++ 2 -> do SomeTypeRep f <- getSomeTypeRep bh+ SomeTypeRep x <- getSomeTypeRep bh+ case typeRepKind f of+ Fun arg res ->+ case arg `eqTypeRep` typeRepKind x of+ Just HRefl ->+ case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of+ Just HRefl -> return $ SomeTypeRep $ mkTrApp f x+ _ -> failure "Kind mismatch in type application" []+ _ -> failure "Kind mismatch in type application"+ [ " Found argument of kind: " ++ show (typeRepKind x)+ , " Where the constructor: " ++ show f+ , " Expects kind: " ++ show arg+ ]+ _ -> failure "Applied non-arrow"+ [ " Applied type: " ++ show f+ , " To argument: " ++ show x+ ]+ 3 -> do SomeTypeRep arg <- getSomeTypeRep bh+ SomeTypeRep res <- getSomeTypeRep bh+ if+ | App argkcon _ <- typeRepKind arg+ , App reskcon _ <- typeRepKind res+ , Just HRefl <- argkcon `eqTypeRep` tYPErep+ , Just HRefl <- reskcon `eqTypeRep` tYPErep+ -> return $ SomeTypeRep $ Fun arg res+ | otherwise -> failure "Kind mismatch" []+ _ -> failure "Invalid SomeTypeRep" []+ where+ tYPErep :: TypeRep TYPE+ tYPErep = typeRep++ failure description info =+ fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]+ ++ map (" "++) info++instance Binary SomeTypeRep where+ put_ bh (SomeTypeRep rep) = putTypeRep bh rep+ get = getSomeTypeRep++instance Typeable a => Binary (TypeRep (a :: k)) where+ put_ = putTypeRep+ get bh = do+ SomeTypeRep rep <- getSomeTypeRep bh+ case rep `eqTypeRep` expected of+ Just HRefl -> pure rep+ Nothing -> fail $ unlines+ [ "Binary: Type mismatch"+ , " Deserialized type: " ++ show rep+ , " Expected type: " ++ show expected+ ]+ where expected = typeRep :: TypeRep a+++instance Binary VecCount where+ put_ bh = putByte bh . fromIntegral . fromEnum+ get bh = toEnum . fromIntegral <$> getByte bh++instance Binary VecElem where+ put_ bh = putByte bh . fromIntegral . fromEnum+ get bh = toEnum . fromIntegral <$> getByte bh++instance Binary RuntimeRep where+ put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b+ put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps+ put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps+ put_ bh LiftedRep = putByte bh 3+ put_ bh UnliftedRep = putByte bh 4+ put_ bh IntRep = putByte bh 5+ put_ bh WordRep = putByte bh 6+ put_ bh Int64Rep = putByte bh 7+ put_ bh Word64Rep = putByte bh 8+ put_ bh AddrRep = putByte bh 9+ put_ bh FloatRep = putByte bh 10+ put_ bh DoubleRep = putByte bh 11+ put_ bh Int8Rep = putByte bh 12+ put_ bh Word8Rep = putByte bh 13+ put_ bh Int16Rep = putByte bh 14+ put_ bh Word16Rep = putByte bh 15+#if __GLASGOW_HASKELL__ >= 809+ put_ bh Int32Rep = putByte bh 16+ put_ bh Word32Rep = putByte bh 17+#endif++ get bh = do+ tag <- getByte bh+ case tag of+ 0 -> VecRep <$> get bh <*> get bh+ 1 -> TupleRep <$> get bh+ 2 -> SumRep <$> get bh+ 3 -> pure LiftedRep+ 4 -> pure UnliftedRep+ 5 -> pure IntRep+ 6 -> pure WordRep+ 7 -> pure Int64Rep+ 8 -> pure Word64Rep+ 9 -> pure AddrRep+ 10 -> pure FloatRep+ 11 -> pure DoubleRep+ 12 -> pure Int8Rep+ 13 -> pure Word8Rep+ 14 -> pure Int16Rep+ 15 -> pure Word16Rep+#if __GLASGOW_HASKELL__ >= 809+ 16 -> pure Int32Rep+ 17 -> pure Word32Rep+#endif+ _ -> fail "Binary.putRuntimeRep: invalid tag"++instance Binary KindRep where+ put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k+ put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr+ put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b+ put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b+ put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r+ put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r++ get bh = do+ tag <- getByte bh+ case tag of+ 0 -> KindRepTyConApp <$> get bh <*> get bh+ 1 -> KindRepVar <$> get bh+ 2 -> KindRepApp <$> get bh <*> get bh+ 3 -> KindRepFun <$> get bh <*> get bh+ 4 -> KindRepTYPE <$> get bh+ 5 -> KindRepTypeLit <$> get bh <*> get bh+ _ -> fail "Binary.putKindRep: invalid tag"++instance Binary TypeLitSort where+ put_ bh TypeLitSymbol = putByte bh 0+ put_ bh TypeLitNat = putByte bh 1+ get bh = do+ tag <- getByte bh+ case tag of+ 0 -> pure TypeLitSymbol+ 1 -> pure TypeLitNat+ _ -> fail "Binary.putTypeLitSort: invalid tag"++putTypeRep :: BinHandle -> TypeRep a -> IO ()+-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind+-- relations.+-- See Note [Mutually recursive representations of primitive types]+putTypeRep bh rep+ | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)+ = put_ bh (0 :: Word8)+putTypeRep bh (Con' con ks) = do+ put_ bh (1 :: Word8)+ put_ bh con+ put_ bh ks+putTypeRep bh (App f x) = do+ put_ bh (2 :: Word8)+ putTypeRep bh f+ putTypeRep bh x+putTypeRep bh (Fun arg res) = do+ put_ bh (3 :: Word8)+ putTypeRep bh arg+ putTypeRep bh res++instance Binary Serialized where+ put_ bh (Serialized the_type bytes) = do+ put_ bh the_type+ put_ bh bytes+ get bh = do+ the_type <- get bh+ bytes <- get bh+ return (Serialized the_type bytes)+
− compiler/GHC/Utils/Encoding.hs
@@ -1,526 +0,0 @@-{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}-{-# OPTIONS_GHC -O2 #-}--- We always optimise this, otherwise performance of a non-optimised--- compiler is severely affected---- ----------------------------------------------------------------------------------- (c) The University of Glasgow, 1997-2006------ Character encodings------ -------------------------------------------------------------------------------module GHC.Utils.Encoding (- -- * UTF-8- utf8DecodeCharAddr#,- utf8PrevChar,- utf8CharStart,- utf8DecodeChar,- utf8DecodeByteString,- utf8DecodeShortByteString,- utf8CompareShortByteString,- utf8DecodeStringLazy,- utf8EncodeChar,- utf8EncodeString,- utf8EncodeShortByteString,- utf8EncodedLength,- countUTF8Chars,-- -- * Z-encoding- zEncodeString,- zDecodeString,-- -- * Base62-encoding- toBase62,- toBase62Padded- ) where--import GHC.Prelude--import Foreign-import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)-import Data.Char-import qualified Data.Char as Char-import Numeric-import GHC.IO-import GHC.ST--import Data.ByteString (ByteString)-import qualified Data.ByteString.Internal as BS-import Data.ByteString.Short.Internal (ShortByteString(..))--import GHC.Exts---- -------------------------------------------------------------------------------- UTF-8---- We can't write the decoder as efficiently as we'd like without--- resorting to unboxed extensions, unfortunately. I tried to write--- an IO version of this function, but GHC can't eliminate boxed--- results from an IO-returning function.------ We assume we can ignore overflow when parsing a multibyte character here.--- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences--- before decoding them (see "GHC.Data.StringBuffer").--{-# INLINE utf8DecodeChar# #-}-utf8DecodeChar# :: (Int# -> Word#) -> (# Char#, Int# #)-utf8DecodeChar# indexWord8# =- let !ch0 = word2Int# (indexWord8# 0#) in- case () of- _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #)-- | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) ->- let !ch1 = word2Int# (indexWord8# 1#) in- if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else- (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +#- (ch1 -# 0x80#)),- 2# #)-- | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) ->- let !ch1 = word2Int# (indexWord8# 1#) in- if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else- let !ch2 = word2Int# (indexWord8# 2#) in- if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else- (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +#- ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +#- (ch2 -# 0x80#)),- 3# #)-- | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) ->- let !ch1 = word2Int# (indexWord8# 1#) in- if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else- let !ch2 = word2Int# (indexWord8# 2#) in- if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else- let !ch3 = word2Int# (indexWord8# 3#) in- if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else- (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +#- ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +#- ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +#- (ch3 -# 0x80#)),- 4# #)-- | otherwise -> fail 1#- where- -- all invalid sequences end up here:- fail :: Int# -> (# Char#, Int# #)- fail nBytes# = (# '\0'#, nBytes# #)- -- '\xFFFD' would be the usual replacement character, but- -- that's a valid symbol in Haskell, so will result in a- -- confusing parse error later on. Instead we use '\0' which- -- will signal a lexer error immediately.--utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #)-utf8DecodeCharAddr# a# off# =- utf8DecodeChar# (\i# -> indexWord8OffAddr# a# (i# +# off#))--utf8DecodeCharByteArray# :: ByteArray# -> Int# -> (# Char#, Int# #)-utf8DecodeCharByteArray# ba# off# =- utf8DecodeChar# (\i# -> indexWord8Array# ba# (i# +# off#))--utf8DecodeChar :: Ptr Word8 -> (Char, Int)-utf8DecodeChar !(Ptr a#) =- case utf8DecodeCharAddr# a# 0# of- (# c#, nBytes# #) -> ( C# c#, I# nBytes# )---- UTF-8 is cleverly designed so that we can always figure out where--- the start of the current character is, given any position in a--- stream. This function finds the start of the previous character,--- assuming there *is* a previous character.-utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8)-utf8PrevChar p = utf8CharStart (p `plusPtr` (-1))--utf8CharStart :: Ptr Word8 -> IO (Ptr Word8)-utf8CharStart p = go p- where go p = do w <- peek p- if w >= 0x80 && w < 0xC0- then go (p `plusPtr` (-1))- else return p--{-# INLINE utf8DecodeLazy# #-}-utf8DecodeLazy# :: (IO ()) -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char]-utf8DecodeLazy# retain decodeChar# len#- = unpack 0#- where- unpack i#- | isTrue# (i# >=# len#) = retain >> return []- | otherwise =- case decodeChar# i# of- (# c#, nBytes# #) -> do- rest <- unsafeDupableInterleaveIO $ unpack (i# +# nBytes#)- return (C# c# : rest)--utf8DecodeByteString :: ByteString -> [Char]-utf8DecodeByteString (BS.PS fptr offset len)- = utf8DecodeStringLazy fptr offset len--utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char]-utf8DecodeStringLazy fp offset (I# len#)- = unsafeDupablePerformIO $ do- let !(Ptr a#) = unsafeForeignPtrToPtr fp `plusPtr` offset- utf8DecodeLazy# (touchForeignPtr fp) (utf8DecodeCharAddr# a#) len#--- Note that since utf8DecodeLazy# returns a thunk the lifetime of the--- ForeignPtr actually needs to be longer than the lexical lifetime--- withForeignPtr would provide here. That's why we use touchForeignPtr to--- keep the fp alive until the last character has actually been decoded.--utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering-utf8CompareShortByteString (SBS a1) (SBS a2) = go 0# 0#- -- UTF-8 has the property that sorting by bytes values also sorts by- -- code-points.- -- BUT we use "Modified UTF-8" which encodes \0 as 0xC080 so this property- -- doesn't hold and we must explicitly check this case here.- -- Note that decoding every code point would also work but it would be much- -- more costly.- where- !sz1 = sizeofByteArray# a1- !sz2 = sizeofByteArray# a2- go off1 off2- | isTrue# ((off1 >=# sz1) `andI#` (off2 >=# sz2)) = EQ- | isTrue# (off1 >=# sz1) = LT- | isTrue# (off2 >=# sz2) = GT- | otherwise =- let !b1_1 = indexWord8Array# a1 off1- !b2_1 = indexWord8Array# a2 off2- in case b1_1 of- 0xC0## -> case b2_1 of- 0xC0## -> go (off1 +# 1#) (off2 +# 1#)- _ -> case indexWord8Array# a1 (off1 +# 1#) of- 0x80## -> LT- _ -> go (off1 +# 1#) (off2 +# 1#)- _ -> case b2_1 of- 0xC0## -> case indexWord8Array# a2 (off2 +# 1#) of- 0x80## -> GT- _ -> go (off1 +# 1#) (off2 +# 1#)- _ | isTrue# (b1_1 `gtWord#` b2_1) -> GT- | isTrue# (b1_1 `ltWord#` b2_1) -> LT- | otherwise -> go (off1 +# 1#) (off2 +# 1#)--utf8DecodeShortByteString :: ShortByteString -> [Char]-utf8DecodeShortByteString (SBS ba#)- = unsafeDupablePerformIO $- let len# = sizeofByteArray# ba# in- utf8DecodeLazy# (return ()) (utf8DecodeCharByteArray# ba#) len#--countUTF8Chars :: ShortByteString -> IO Int-countUTF8Chars (SBS ba) = go 0# 0#- where- len# = sizeofByteArray# ba- go i# n#- | isTrue# (i# >=# len#) =- return (I# n#)- | otherwise = do- case utf8DecodeCharByteArray# ba i# of- (# _, nBytes# #) -> go (i# +# nBytes#) (n# +# 1#)--{-# INLINE utf8EncodeChar #-}-utf8EncodeChar :: (Int# -> Word# -> State# s -> State# s)- -> Char -> ST s Int-utf8EncodeChar write# c =- let x = ord c in- case () of- _ | x > 0 && x <= 0x007f -> do- write 0 x- return 1- -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we- -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8).- | x <= 0x07ff -> do- write 0 (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))- write 1 (0x80 .|. (x .&. 0x3F))- return 2- | x <= 0xffff -> do- write 0 (0xE0 .|. (x `shiftR` 12) .&. 0x0F)- write 1 (0x80 .|. (x `shiftR` 6) .&. 0x3F)- write 2 (0x80 .|. (x .&. 0x3F))- return 3- | otherwise -> do- write 0 (0xF0 .|. (x `shiftR` 18))- write 1 (0x80 .|. ((x `shiftR` 12) .&. 0x3F))- write 2 (0x80 .|. ((x `shiftR` 6) .&. 0x3F))- write 3 (0x80 .|. (x .&. 0x3F))- return 4- where- {-# INLINE write #-}- write (I# off#) (I# c#) = ST $ \s ->- case write# off# (int2Word# c#) s of- s -> (# s, () #)--utf8EncodeString :: Ptr Word8 -> String -> IO ()-utf8EncodeString (Ptr a#) str = go a# str- where go !_ [] = return ()- go a# (c:cs) = do- I# off# <- stToIO $ utf8EncodeChar (writeWord8OffAddr# a#) c- go (a# `plusAddr#` off#) cs--utf8EncodeShortByteString :: String -> IO ShortByteString-utf8EncodeShortByteString str = IO $ \s ->- case utf8EncodedLength str of { I# len# ->- case newByteArray# len# s of { (# s, mba# #) ->- case go mba# 0# str of { ST f_go ->- case f_go s of { (# s, () #) ->- case unsafeFreezeByteArray# mba# s of { (# s, ba# #) ->- (# s, SBS ba# #) }}}}}- where- go _ _ [] = return ()- go mba# i# (c:cs) = do- I# off# <- utf8EncodeChar (\j# -> writeWord8Array# mba# (i# +# j#)) c- go mba# (i# +# off#) cs--utf8EncodedLength :: String -> Int-utf8EncodedLength str = go 0 str- where go !n [] = n- go n (c:cs)- | ord c > 0 && ord c <= 0x007f = go (n+1) cs- | ord c <= 0x07ff = go (n+2) cs- | ord c <= 0xffff = go (n+3) cs- | otherwise = go (n+4) cs---- -------------------------------------------------------------------------------- Note [Z-Encoding]--- ~~~~~~~~~~~~~~~~~--{--This is the main name-encoding and decoding function. It encodes any-string into a string that is acceptable as a C name. This is done-right before we emit a symbol name into the compiled C or asm code.-Z-encoding of strings is cached in the FastString interface, so we-never encode the same string more than once.--The basic encoding scheme is this.--* Tuples (,,,) are coded as Z3T--* Alphabetic characters (upper and lower) and digits- all translate to themselves;- except 'Z', which translates to 'ZZ'- and 'z', which translates to 'zz'- We need both so that we can preserve the variable/tycon distinction--* Most other printable characters translate to 'zx' or 'Zx' for some- alphabetic character x--* The others translate as 'znnnU' where 'nnn' is the decimal number- of the character-- Before After- --------------------------- Trak Trak- foo_wib foozuwib- > zg- >1 zg1- foo# foozh- foo## foozhzh- foo##1 foozhzh1- fooZ fooZZ- :+ ZCzp- () Z0T 0-tuple- (,,,,) Z5T 5-tuple- (# #) Z1H unboxed 1-tuple (note the space)- (#,,,,#) Z5H unboxed 5-tuple- (NB: There is no Z1T nor Z0H.)--}--type UserString = String -- As the user typed it-type EncodedString = String -- Encoded form---zEncodeString :: UserString -> EncodedString-zEncodeString cs = case maybe_tuple cs of- Just n -> n -- Tuples go to Z2T etc- Nothing -> go cs- where- go [] = []- go (c:cs) = encode_digit_ch c ++ go' cs- go' [] = []- go' (c:cs) = encode_ch c ++ go' cs--unencodedChar :: Char -> Bool -- True for chars that don't need encoding-unencodedChar 'Z' = False-unencodedChar 'z' = False-unencodedChar c = c >= 'a' && c <= 'z'- || c >= 'A' && c <= 'Z'- || c >= '0' && c <= '9'---- If a digit is at the start of a symbol then we need to encode it.--- Otherwise package names like 9pH-0.1 give linker errors.-encode_digit_ch :: Char -> EncodedString-encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c-encode_digit_ch c | otherwise = encode_ch c--encode_ch :: Char -> EncodedString-encode_ch c | unencodedChar c = [c] -- Common case first---- Constructors-encode_ch '(' = "ZL" -- Needed for things like (,), and (->)-encode_ch ')' = "ZR" -- For symmetry with (-encode_ch '[' = "ZM"-encode_ch ']' = "ZN"-encode_ch ':' = "ZC"-encode_ch 'Z' = "ZZ"---- Variables-encode_ch 'z' = "zz"-encode_ch '&' = "za"-encode_ch '|' = "zb"-encode_ch '^' = "zc"-encode_ch '$' = "zd"-encode_ch '=' = "ze"-encode_ch '>' = "zg"-encode_ch '#' = "zh"-encode_ch '.' = "zi"-encode_ch '<' = "zl"-encode_ch '-' = "zm"-encode_ch '!' = "zn"-encode_ch '+' = "zp"-encode_ch '\'' = "zq"-encode_ch '\\' = "zr"-encode_ch '/' = "zs"-encode_ch '*' = "zt"-encode_ch '_' = "zu"-encode_ch '%' = "zv"-encode_ch c = encode_as_unicode_char c--encode_as_unicode_char :: Char -> EncodedString-encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str- else '0':hex_str- where hex_str = showHex (ord c) "U"- -- ToDo: we could improve the encoding here in various ways.- -- eg. strings of unicode characters come out as 'z1234Uz5678U', we- -- could remove the 'U' in the middle (the 'z' works as a separator).--zDecodeString :: EncodedString -> UserString-zDecodeString [] = []-zDecodeString ('Z' : d : rest)- | isDigit d = decode_tuple d rest- | otherwise = decode_upper d : zDecodeString rest-zDecodeString ('z' : d : rest)- | isDigit d = decode_num_esc d rest- | otherwise = decode_lower d : zDecodeString rest-zDecodeString (c : rest) = c : zDecodeString rest--decode_upper, decode_lower :: Char -> Char--decode_upper 'L' = '('-decode_upper 'R' = ')'-decode_upper 'M' = '['-decode_upper 'N' = ']'-decode_upper 'C' = ':'-decode_upper 'Z' = 'Z'-decode_upper ch = {-pprTrace "decode_upper" (char ch)-} ch--decode_lower 'z' = 'z'-decode_lower 'a' = '&'-decode_lower 'b' = '|'-decode_lower 'c' = '^'-decode_lower 'd' = '$'-decode_lower 'e' = '='-decode_lower 'g' = '>'-decode_lower 'h' = '#'-decode_lower 'i' = '.'-decode_lower 'l' = '<'-decode_lower 'm' = '-'-decode_lower 'n' = '!'-decode_lower 'p' = '+'-decode_lower 'q' = '\''-decode_lower 'r' = '\\'-decode_lower 's' = '/'-decode_lower 't' = '*'-decode_lower 'u' = '_'-decode_lower 'v' = '%'-decode_lower ch = {-pprTrace "decode_lower" (char ch)-} ch---- Characters not having a specific code are coded as z224U (in hex)-decode_num_esc :: Char -> EncodedString -> UserString-decode_num_esc d rest- = go (digitToInt d) rest- where- go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest- go n ('U' : rest) = chr n : zDecodeString rest- go n other = error ("decode_num_esc: " ++ show n ++ ' ':other)--decode_tuple :: Char -> EncodedString -> UserString-decode_tuple d rest- = go (digitToInt d) rest- where- -- NB. recurse back to zDecodeString after decoding the tuple, because- -- the tuple might be embedded in a longer name.- go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest- go 0 ('T':rest) = "()" ++ zDecodeString rest- go n ('T':rest) = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest- go 1 ('H':rest) = "(# #)" ++ zDecodeString rest- go n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest- go n other = error ("decode_tuple: " ++ show n ++ ' ':other)--{--Tuples are encoded as- Z3T or Z3H-for 3-tuples or unboxed 3-tuples respectively. No other encoding starts- Z<digit>--* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple)- There are no unboxed 0-tuples.--* "()" is the tycon for a boxed 0-tuple.- There are no boxed 1-tuples.--}--maybe_tuple :: UserString -> Maybe EncodedString--maybe_tuple "(# #)" = Just("Z1H")-maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of- (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")- _ -> Nothing-maybe_tuple "()" = Just("Z0T")-maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of- (n, ')' : _) -> Just ('Z' : shows (n+1) "T")- _ -> Nothing-maybe_tuple _ = Nothing--count_commas :: Int -> String -> (Int, String)-count_commas n (',' : cs) = count_commas (n+1) cs-count_commas n cs = (n,cs)---{--************************************************************************-* *- Base 62-* *-************************************************************************--Note [Base 62 encoding 128-bit integers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Instead of base-62 encoding a single 128-bit integer-(ceil(21.49) characters), we'll base-62 a pair of 64-bit integers-(2 * ceil(10.75) characters). Luckily for us, it's the same number of-characters!--}------------------------------------------------------------------------------- Base 62---- The base-62 code is based off of 'locators'--- ((c) Operational Dynamics Consulting, BSD3 licensed)---- | Size of a 64-bit word when written as a base-62 string-word64Base62Len :: Int-word64Base62Len = 11---- | Converts a 64-bit word into a base-62 string-toBase62Padded :: Word64 -> String-toBase62Padded w = pad ++ str- where- pad = replicate len '0'- len = word64Base62Len - length str -- 11 == ceil(64 / lg 62)- str = toBase62 w--toBase62 :: Word64 -> String-toBase62 w = showIntAtBase 62 represent w ""- where- represent :: Int -> Char- represent x- | x < 10 = Char.chr (48 + x)- | x < 36 = Char.chr (65 + x - 10)- | x < 62 = Char.chr (97 + x - 36)- | otherwise = error "represent (base 62): impossible!"
compiler/GHC/Utils/Error.hs view
@@ -1,28 +1,25 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+ {- (c) The AQUA Project, Glasgow University, 1994-1998 \section[ErrsUtils]{Utilities for error reporting} -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE LambdaCase #-}- module GHC.Utils.Error ( -- * Basic types Validity(..), andValid, allValid, isValid, getInvalids, orValid, Severity(..), -- * Messages- ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,- ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,+ ErrMsg(..),+ ErrDoc(..), errDoc, mapErrDoc, WarnMsg, MsgDoc, Messages, ErrorMessages, WarningMessages, unionMessages,- errMsgSpan, errMsgContext, errorsFound, isEmptyMessages, isWarnMsgFatal, warningsToMessages,@@ -60,24 +57,27 @@ debugTraceMsg, ghcExit, prettyPrintGhcErrors,- traceCmd+ traceCmd,++ -- * Compilation errors and warnings+ printOrThrowWarnings, handleFlagWarnings, shouldPrintWarning ) where #include "GhclibHsVersions.h" import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Ppr+import qualified GHC.Driver.CmdLine as CmdLine+ import GHC.Data.Bag import GHC.Utils.Exception import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import qualified GHC.Utils.Ppr.Colour as Col+import GHC.Types.SourceError+import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Data.FastString (unpackFS)-import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)-import GHC.Utils.Json import System.Directory import System.Exit ( ExitCode(..), exitWith )@@ -93,12 +93,9 @@ import Control.Monad.IO.Class import Control.Monad.Catch as MC (handle) import System.IO-import System.IO.Error ( catchIOError ) import GHC.Conc ( getAllocationCounter ) import System.CPUTime ---------------------------type MsgDoc = SDoc ------------------------- data Validity@@ -126,214 +123,6 @@ orValid _ v = v -- -------------------------------------------------------------------------------- Basic error messages: just render a message with a source location.--type Messages = (WarningMessages, ErrorMessages)-type WarningMessages = Bag WarnMsg-type ErrorMessages = Bag ErrMsg--unionMessages :: Messages -> Messages -> Messages-unionMessages (warns1, errs1) (warns2, errs2) =- (warns1 `unionBags` warns2, errs1 `unionBags` errs2)--data ErrMsg = ErrMsg {- errMsgSpan :: SrcSpan,- errMsgContext :: PrintUnqualified,- errMsgDoc :: ErrDoc,- -- | This has the same text as errDocImportant . errMsgDoc.- errMsgShortString :: String,- errMsgSeverity :: Severity,- errMsgReason :: WarnReason- }- -- The SrcSpan is used for sorting errors into line-number order----- | Categorise error msgs by their importance. This is so each section can--- be rendered visually distinct. See Note [Error report] for where these come--- from.-data ErrDoc = ErrDoc {- -- | Primary error msg.- errDocImportant :: [MsgDoc],- -- | Context e.g. \"In the second argument of ...\".- errDocContext :: [MsgDoc],- -- | Supplementary information, e.g. \"Relevant bindings include ...\".- errDocSupplementary :: [MsgDoc]- }--errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc-errDoc = ErrDoc--mapErrDoc :: (MsgDoc -> MsgDoc) -> ErrDoc -> ErrDoc-mapErrDoc f (ErrDoc a b c) = ErrDoc (map f a) (map f b) (map f c)--type WarnMsg = ErrMsg--data Severity- = SevOutput- | SevFatal- | SevInteractive-- | SevDump- -- ^ Log message intended for compiler developers- -- No file\/line\/column stuff-- | SevInfo- -- ^ Log messages intended for end users.- -- No file\/line\/column stuff.-- | SevWarning- | SevError- -- ^ SevWarning and SevError are used for warnings and errors- -- o The message has a file\/line\/column heading,- -- plus "warning:" or "error:",- -- added by mkLocMessags- -- o Output is intended for end users- deriving Show---instance ToJson Severity where- json s = JSString (show s)---instance Show ErrMsg where- show em = errMsgShortString em--pprMessageBag :: Bag MsgDoc -> SDoc-pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))---- | Make an unannotated error message with location info.-mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc-mkLocMessage = mkLocMessageAnn Nothing---- | Make a possibly annotated error message with location info.-mkLocMessageAnn- :: Maybe String -- ^ optional annotation- -> Severity -- ^ severity- -> SrcSpan -- ^ location- -> MsgDoc -- ^ message- -> MsgDoc- -- 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 "<no location info>".-mkLocMessageAnn ann severity locn msg- = sdocOption sdocColScheme $ \col_scheme ->- let locn' = sdocOption sdocErrorSpans $ \case- True -> ppr locn- False -> ppr (srcSpanStart locn)-- sevColour = getSeverityColour severity col_scheme-- -- Add optional information- optAnn = case ann of- Nothing -> text ""- Just i -> text " [" <> coloured sevColour (text i) <> text "]"-- -- Add prefixes, like Foo.hs:34: warning:- -- <the warning message>- header = locn' <> colon <+>- coloured sevColour sevText <> optAnn-- in coloured (Col.sMessage col_scheme)- (hang (coloured (Col.sHeader col_scheme) header) 4- msg)-- where- sevText =- case severity of- SevWarning -> text "warning:"- SevError -> text "error:"- SevFatal -> text "fatal:"- _ -> empty--getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour-getSeverityColour SevWarning = Col.sWarning-getSeverityColour SevError = Col.sError-getSeverityColour SevFatal = Col.sFatal-getSeverityColour _ = const mempty--getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc-getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty-getCaretDiagnostic severity (RealSrcSpan span _) = do- caretDiagnostic <$> getSrcLine (srcSpanFile span) row-- where- getSrcLine fn i =- getLine i (unpackFS fn)- `catchIOError` \_ ->- pure Nothing-- getLine i fn = do- -- StringBuffer has advantages over readFile:- -- (a) no lazy IO, otherwise IO exceptions may occur in pure code- -- (b) always UTF-8, rather than some system-dependent encoding- -- (Haskell source code must be UTF-8 anyway)- content <- hGetStringBuffer fn- case atLine i content of- Just at_line -> pure $- case lines (fix <$> lexemeToString at_line (len at_line)) of- srcLine : _ -> Just srcLine- _ -> Nothing- _ -> pure Nothing-- -- allow user to visibly see that their code is incorrectly encoded- -- (StringBuffer.nextChar uses \0 to represent undecodable characters)- fix '\0' = '\xfffd'- fix c = c-- row = srcSpanStartLine span- rowStr = show row- multiline = row /= srcSpanEndLine span-- caretDiagnostic Nothing = empty- caretDiagnostic (Just srcLineWithNewline) =- sdocOption sdocColScheme$ \col_scheme ->- let sevColour = getSeverityColour severity col_scheme- marginColour = Col.sMargin col_scheme- in- coloured marginColour (text marginSpace) <>- text ("\n") <>- coloured marginColour (text marginRow) <>- text (" " ++ srcLinePre) <>- coloured sevColour (text srcLineSpan) <>- text (srcLinePost ++ "\n") <>- coloured marginColour (text marginSpace) <>- coloured sevColour (text (" " ++ caretLine))-- where-- -- expand tabs in a device-independent manner #13664- expandTabs tabWidth i s =- case s of- "" -> ""- '\t' : cs -> replicate effectiveWidth ' ' ++- expandTabs tabWidth (i + effectiveWidth) cs- c : cs -> c : expandTabs tabWidth (i + 1) cs- where effectiveWidth = tabWidth - i `mod` tabWidth-- srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline)-- start = srcSpanStartCol span - 1- end | multiline = length srcLine- | otherwise = srcSpanEndCol span - 1- width = max 1 (end - start)-- marginWidth = length rowStr- marginSpace = replicate marginWidth ' ' ++ " |"- marginRow = rowStr ++ " |"-- (srcLinePre, srcLineRest) = splitAt start srcLine- (srcLineSpan, srcLinePost) = splitAt width srcLineRest-- caretEllipsis | multiline = "..."- | otherwise = ""- caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis--makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg-makeIntoWarning reason err = err- { errMsgSeverity = SevWarning- , errMsgReason = reason }---- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg@@ -742,42 +531,42 @@ -> m a -- ^ The body of the phase to be timed -> m a withTiming' dflags what force_result prtimings action- = do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags- then do whenPrintTimings $- logInfo dflags $ withPprStyle defaultUserStyle $- text "***" <+> what <> colon- let ctx = initDefaultSDocContext dflags- eventBegins ctx what- alloc0 <- liftIO getAllocationCounter- start <- liftIO getCPUTime- !r <- action- () <- pure $ force_result r- eventEnds ctx what- end <- liftIO getCPUTime- alloc1 <- liftIO getAllocationCounter- -- recall that allocation counter counts down- let alloc = alloc0 - alloc1- time = realToFrac (end - start) * 1e-9+ = if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags+ then do whenPrintTimings $+ logInfo dflags $ withPprStyle defaultUserStyle $+ text "***" <+> what <> colon+ let ctx = initDefaultSDocContext dflags+ eventBegins ctx what+ alloc0 <- liftIO getAllocationCounter+ start <- liftIO getCPUTime+ !r <- action+ () <- pure $ force_result r+ eventEnds ctx what+ end <- liftIO getCPUTime+ alloc1 <- liftIO getAllocationCounter+ -- recall that allocation counter counts down+ let alloc = alloc0 - alloc1+ time = realToFrac (end - start) * 1e-9 - when (verbosity dflags >= 2 && prtimings == PrintTimings)- $ liftIO $ logInfo dflags $ withPprStyle defaultUserStyle- (text "!!!" <+> what <> colon <+> text "finished in"- <+> doublePrec 2 time- <+> text "milliseconds"- <> comma- <+> text "allocated"- <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)- <+> text "megabytes")+ when (verbosity dflags >= 2 && prtimings == PrintTimings)+ $ liftIO $ logInfo dflags $ withPprStyle defaultUserStyle+ (text "!!!" <+> what <> colon <+> text "finished in"+ <+> doublePrec 2 time+ <+> text "milliseconds"+ <> comma+ <+> text "allocated"+ <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)+ <+> text "megabytes") - whenPrintTimings $- dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText- $ text $ showSDocOneLine ctx- $ hsep [ what <> colon- , text "alloc=" <> ppr alloc- , text "time=" <> doublePrec 3 time- ]- pure r- else action+ whenPrintTimings $+ dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText+ $ text $ showSDocOneLine ctx+ $ hsep [ what <> colon+ , text "alloc=" <> ppr alloc+ , text "time=" <> doublePrec 3 time+ ]+ pure r+ else action where whenPrintTimings = liftIO . when (prtimings == PrintTimings) eventBegins ctx w = do@@ -982,8 +771,8 @@ -- | Default action for 'dumpAction' hook defaultDumpAction :: DumpAction-defaultDumpAction dflags sty dumpOpt title _fmt doc = do- dumpSDocWithStyle sty dflags dumpOpt title doc+defaultDumpAction dflags sty dumpOpt title _fmt doc =+ dumpSDocWithStyle sty dflags dumpOpt title doc -- | Default action for 'traceAction' hook defaultTraceAction :: TraceAction@@ -996,3 +785,44 @@ -- | Helper for `trace_action` traceAction :: TraceAction traceAction dflags = trace_action dflags dflags++handleFlagWarnings :: DynFlags -> [CmdLine.Warn] -> IO ()+handleFlagWarnings dflags warns = do+ let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason) warns++ -- It would be nicer if warns :: [Located MsgDoc], but that+ -- has circular import problems.+ bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)+ | CmdLine.Warn _ (L loc warn) <- warns' ]++ printOrThrowWarnings dflags bag++-- Given a warn reason, check to see if it's associated -W opt is enabled+shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool+shouldPrintWarning dflags CmdLine.ReasonDeprecatedFlag+ = wopt Opt_WarnDeprecatedFlags dflags+shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag+ = wopt Opt_WarnUnrecognisedWarningFlags dflags+shouldPrintWarning _ _+ = True+++-- | Given a bag of warnings, turn them into an exception if+-- -Werror is enabled, or print them out otherwise.+printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()+printOrThrowWarnings dflags warns = do+ let (make_error, warns') =+ mapAccumBagL+ (\make_err warn ->+ case isWarnMsgFatal dflags warn of+ Nothing ->+ (make_err, warn)+ Just err_reason ->+ (True, warn{ errMsgSeverity = SevError+ , errMsgReason = ErrReason err_reason+ }))+ False warns+ if make_error+ then throwIO (mkSrcErr warns')+ else printBagOfErrors dflags warns+
compiler/GHC/Utils/Error.hs-boot view
@@ -4,8 +4,6 @@ import GHC.Prelude import GHC.Utils.Outputable (SDoc, PprStyle )-import GHC.Types.SrcLoc (SrcSpan)-import GHC.Utils.Json import {-# SOURCE #-} GHC.Driver.Session ( DynFlags ) type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String@@ -29,22 +27,5 @@ | FormatLLVM | FormatText -data Severity- = SevOutput- | SevFatal- | SevInteractive- | SevDump- | SevInfo- | SevWarning- | SevError---type MsgDoc = SDoc--mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc-mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc-getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc defaultDumpAction :: DumpAction defaultTraceAction :: TraceAction--instance ToJson Severity
compiler/GHC/Utils/Exception.hs view
@@ -3,14 +3,13 @@ module GHC.Utils.Exception (- module Control.Exception,+ module CE, module GHC.Utils.Exception ) where import GHC.Prelude -import Control.Exception import Control.Exception as CE import Control.Monad.IO.Class import Control.Monad.Catch
compiler/GHC/Utils/GlobalVars.hs view
@@ -95,7 +95,7 @@ global a = unsafePerformIO (newIORef a) consIORef :: IORef [a] -> a -> IO ()-consIORef var x = do+consIORef var x = atomicModifyIORef' var (\xs -> (x:xs,())) globalM :: IO a -> IORef a
compiler/GHC/Utils/Misc.hs view
@@ -1281,7 +1281,7 @@ -- check existence & modification time at the same time modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime)-modificationTimeIfExists f = do+modificationTimeIfExists f = (do t <- getModificationUTCTime f; return (Just t)) `catchIO` \e -> if isDoesNotExistError e then return Nothing
compiler/GHC/Utils/Outputable.hs view
@@ -198,7 +198,7 @@ -- the component id to disambiguate it. type QueryQualifyPackage = Unit -> Bool --- See Note [Printing original names] in GHC.Driver.Types+-- See Note [Printing original names] in GHC.Types.Name.Ppr data QualifyName -- Given P:M.T = NameUnqual -- It's in scope unqualified as "T" -- OR nothing called "T" is in scope@@ -677,7 +677,7 @@ rbrace = docToSDoc $ Pretty.rbrace mulArrow :: SDoc -> SDoc-mulArrow d = text "#" <+> d <+> arrow+mulArrow d = text "%" <> d <+> arrow forAllLit :: SDoc@@ -1045,12 +1045,6 @@ -- See Note [The OutputableP class] class OutputableP env a where pdoc :: env -> a -> SDoc- pdocPrec :: Rational -> env -> a -> SDoc- -- 0 binds least tightly- -- We use Rational because there is always a- -- Rational between any other two Rationals- pdoc = pdocPrec 0- pdocPrec _ = pdoc -- | Wrapper for types having a Outputable instance when an OutputableP instance -- is required.@@ -1293,8 +1287,8 @@ -- > speakN 5 = text "five" -- > speakN 10 = text "10" speakN :: Int -> SDoc-speakN 0 = text "none" -- E.g. "he has none"-speakN 1 = text "one" -- E.g. "he has one"+speakN 0 = text "none" -- E.g. "they have none"+speakN 1 = text "one" -- E.g. "they have one" speakN 2 = text "two" speakN 3 = text "three" speakN 4 = text "four"
ghc-lib-parser.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-parser-version: 0.20201001+version: 0.20201101 license: BSD3 license-file: LICENSE category: Development@@ -135,7 +135,6 @@ libraries/ghc-boot libraries/ghc-heap libraries/ghci- compiler/. compiler autogen-modules: GHC.Parser.Lexer@@ -193,6 +192,8 @@ GHC.Core.TyCo.Subst GHC.Core.TyCo.Tidy GHC.Core.TyCon+ GHC.Core.TyCon.Env+ GHC.Core.TyCon.RecWalk GHC.Core.Type GHC.Core.Unfold GHC.Core.Unfold.Make@@ -213,6 +214,7 @@ GHC.Data.Maybe GHC.Data.OrdList GHC.Data.Pair+ GHC.Data.ShortText GHC.Data.Stream GHC.Data.StringBuffer GHC.Data.TrieMap@@ -220,6 +222,7 @@ GHC.Driver.Backpack.Syntax GHC.Driver.CmdLine GHC.Driver.Config+ GHC.Driver.Env GHC.Driver.Flags GHC.Driver.Hooks GHC.Driver.Monad@@ -228,7 +231,6 @@ GHC.Driver.Plugins GHC.Driver.Ppr GHC.Driver.Session- GHC.Driver.Types GHC.Exts.Heap GHC.Exts.Heap.ClosureTypes GHC.Exts.Heap.Closures@@ -252,6 +254,7 @@ GHC.Hs.Pat GHC.Hs.Type GHC.Hs.Utils+ GHC.Iface.Ext.Fields GHC.Iface.Recomp.Binary GHC.Iface.Syntax GHC.Iface.Type@@ -261,10 +264,13 @@ GHC.Parser GHC.Parser.Annotation GHC.Parser.CharClass+ GHC.Parser.Errors+ GHC.Parser.Errors.Ppr GHC.Parser.Header GHC.Parser.Lexer GHC.Parser.PostProcess GHC.Parser.PostProcess.Haddock+ GHC.Parser.Types GHC.Platform GHC.Platform.ARM GHC.Platform.ARM64@@ -282,6 +288,7 @@ GHC.Platform.X86 GHC.Platform.X86_64 GHC.Prelude+ GHC.Runtime.Context GHC.Runtime.Eval.Types GHC.Runtime.Heap.Layout GHC.Runtime.Interpreter.Types@@ -304,24 +311,39 @@ GHC.Types.Annotations GHC.Types.Avail GHC.Types.Basic+ GHC.Types.CompleteMatch GHC.Types.CostCentre GHC.Types.CostCentre.State GHC.Types.Cpr GHC.Types.Demand+ GHC.Types.Error GHC.Types.FieldLabel+ GHC.Types.Fixity+ GHC.Types.Fixity.Env GHC.Types.ForeignCall+ GHC.Types.ForeignStubs+ GHC.Types.HpcInfo GHC.Types.Id GHC.Types.Id.Info GHC.Types.Id.Make GHC.Types.Literal+ GHC.Types.Meta GHC.Types.Name GHC.Types.Name.Cache GHC.Types.Name.Env GHC.Types.Name.Occurrence+ GHC.Types.Name.Ppr GHC.Types.Name.Reader GHC.Types.Name.Set GHC.Types.RepType+ GHC.Types.SafeHaskell+ GHC.Types.SourceError+ GHC.Types.SourceFile+ GHC.Types.SourceText GHC.Types.SrcLoc+ GHC.Types.Target+ GHC.Types.TyThing+ GHC.Types.TypeEnv GHC.Types.Unique GHC.Types.Unique.DFM GHC.Types.Unique.DSet@@ -334,17 +356,30 @@ GHC.UniqueSubdir GHC.Unit GHC.Unit.Database+ GHC.Unit.External+ GHC.Unit.Finder.Types GHC.Unit.Home+ GHC.Unit.Home.ModInfo GHC.Unit.Info GHC.Unit.Module+ GHC.Unit.Module.Deps GHC.Unit.Module.Env+ GHC.Unit.Module.Graph+ GHC.Unit.Module.Imported GHC.Unit.Module.Location+ GHC.Unit.Module.ModDetails+ GHC.Unit.Module.ModGuts+ GHC.Unit.Module.ModIface+ GHC.Unit.Module.ModSummary GHC.Unit.Module.Name+ GHC.Unit.Module.Status+ GHC.Unit.Module.Warnings GHC.Unit.Parser GHC.Unit.Ppr GHC.Unit.State GHC.Unit.Types GHC.Utils.Binary+ GHC.Utils.Binary.Typeable GHC.Utils.BufHandle GHC.Utils.CliOption GHC.Utils.Encoding
ghc-lib/stage0/compiler/build/GHC/Parser.hs view
@@ -37,58 +37,49 @@ -- base import Control.Monad ( unless, liftM, when, (<=<) ) import GHC.Exts-import Data.Char import Data.Maybe ( maybeToList )-import Control.Monad ( mplus )-import Control.Applicative ((<$)) import qualified Prelude -- for happy-generated code --- compiler+import GHC.Prelude+ import GHC.Hs -import GHC.Driver.Phases ( HscSource(..) )-import GHC.Driver.Types ( IsBootInterface(..), WarningTxt(..) )-import GHC.Driver.Session import GHC.Driver.Backpack.Syntax+ import GHC.Unit.Info+import GHC.Unit.Module+import GHC.Unit.Module.Warnings --- compiler/utils import GHC.Data.OrdList-import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue )+import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula, mkTrue ) import GHC.Data.FastString-import GHC.Data.Maybe ( isJust, orElse )+import GHC.Data.Maybe ( orElse )+ import GHC.Utils.Outputable import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )-import GHC.Prelude --- compiler/basicTypes import GHC.Types.Name.Reader-import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName,- occNameFS, startsWithUnderscore )-import GHC.Core.DataCon ( DataCon, dataConName )+import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS ) import GHC.Types.SrcLoc-import GHC.Unit.Module import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Types.ForeignCall-import GHC.Hs.Doc+import GHC.Types.SourceFile+import GHC.Types.SourceText -import GHC.Core.Type ( unrestrictedFunTyCon, Mult(..), Specificity(..) )+import GHC.Core.Type ( unrestrictedFunTyCon, Specificity(..) ) import GHC.Core.Class ( FunDep )+import GHC.Core.DataCon ( DataCon, dataConName ) --- compiler/parser import GHC.Parser.PostProcess import GHC.Parser.PostProcess.Haddock import GHC.Parser.Lexer import GHC.Parser.Annotation--import GHC.Tc.Types.Evidence ( emptyTcEvBinds )+import GHC.Parser.Errors --- compiler/prelude-import GHC.Builtin.Types.Prim ( eqPrimTyCon ) import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, unboxedUnitTyCon, unboxedUnitDataCon,- listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR,- manyDataConTyCon)+ listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR) import qualified Data.Array as Happy_Data_Array import qualified Data.Bits as Bits import qualified GHC.Exts as Happy_GHC_Exts@@ -1120,8 +1111,8 @@ happyOut156 :: (HappyAbsSyn ) -> HappyWrap156 happyOut156 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut156 #-}-newtype HappyWrap157 = HappyWrap157 (Located (HsArrow GhcPs))-happyIn157 :: (Located (HsArrow GhcPs)) -> (HappyAbsSyn )+newtype HappyWrap157 = HappyWrap157 (Located (IsUnicodeSyntax -> (HsArrow GhcPs, AddAnn)))+happyIn157 :: (Located (IsUnicodeSyntax -> (HsArrow GhcPs, AddAnn))) -> (HappyAbsSyn ) happyIn157 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap157 x) {-# INLINE happyIn157 #-} happyOut157 :: (HappyAbsSyn ) -> HappyWrap157@@ -1311,8 +1302,8 @@ happyOut183 :: (HappyAbsSyn ) -> HappyWrap183 happyOut183 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut183 #-}-newtype HappyWrap184 = HappyWrap184 (Located (Located RdrName, HsConDeclDetails GhcPs))-happyIn184 :: (Located (Located RdrName, HsConDeclDetails GhcPs)) -> (HappyAbsSyn )+newtype HappyWrap184 = HappyWrap184 (Located (Located RdrName, HsConDeclH98Details GhcPs))+happyIn184 :: (Located (Located RdrName, HsConDeclH98Details GhcPs)) -> (HappyAbsSyn ) happyIn184 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap184 x) {-# INLINE happyIn184 #-} happyOut184 :: (HappyAbsSyn ) -> HappyWrap184@@ -3331,7 +3322,7 @@ = 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 (getLoc happy_var_1) $ text "Expected a hyphen"+ else do { addError $ Error ErrExpectedHyphen [] (getLoc happy_var_1) ; return [] })}) ) (\r -> happyReturn (happyIn26 r)) @@ -4211,10 +4202,7 @@ = happyThen ((case happyOutTok happy_x_1 of { happy_var_1 -> ( do { let { pkgFS = getSTRING happy_var_1 } ; unless (looksLikePackageName (unpackFS pkgFS)) $- addError (getLoc happy_var_1) $ vcat [- text "Parse error" <> colon <+> quotes (ppr pkgFS),- text "Version number or non-alphanumeric" <+>- text "character in package name"]+ addError $ Error (ErrInvalidPackageName pkgFS) [] (getLoc happy_var_1) ; return ([mj AnnPackageName happy_var_1], Just (StringLiteral (getSTRINGs happy_var_1) pkgFS)) })}) ) (\r -> happyReturn (happyIn65 r)) @@ -6157,7 +6145,7 @@ = 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 (getLoc happy_var_1) $ text "Invalid rule activation marker"+ else do { addError $ Error ErrInvalidRuleActivationMarker [] (getLoc happy_var_1) ; return [] })}) ) (\r -> happyReturn (happyIn130 r)) @@ -6860,8 +6848,8 @@ = happyThen ((case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut154 happy_x_3 of { (HappyWrap154 happy_var_3) -> - ( ams happy_var_1 [mu AnnRarrow happy_var_2] -- See note [GADT decl discards annotations]- >> ams (sLL happy_var_1 happy_var_3 $ HsFunTy noExtField HsUnrestrictedArrow happy_var_1 happy_var_3)+ ( ams happy_var_1 [mu AnnRarrow happy_var_2] -- See Note [GADT decl discards annotations]+ >> ams (sLL happy_var_1 happy_var_3 $ HsFunTy noExtField (HsUnrestrictedArrow (toUnicode happy_var_2)) happy_var_1 happy_var_3) [mu AnnRarrow happy_var_2])}}}) ) (\r -> happyReturn (happyIn156 r)) @@ -6876,9 +6864,11 @@ case happyOut157 happy_x_2 of { (HappyWrap157 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut154 happy_x_4 of { (HappyWrap154 happy_var_4) -> - ( hintLinear (getLoc happy_var_2) >>- ams (sLL happy_var_1 happy_var_4 $ HsFunTy noExtField (unLoc happy_var_2) happy_var_1 happy_var_4)- [mu AnnRarrow happy_var_3])}}}})+ ( hintLinear (getLoc happy_var_2)+ >> let (arr, ann) = (unLoc happy_var_2) (toUnicode happy_var_3)+ in (ams happy_var_1 [ann,mu AnnRarrow happy_var_3] -- See Note [GADT decl discards annotations]+ >> ams (sLL happy_var_1 happy_var_4 $ HsFunTy noExtField arr happy_var_1 happy_var_4)+ [ann,mu AnnRarrow happy_var_3]))}}}}) ) (\r -> happyReturn (happyIn156 r)) happyReduce_360 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -6890,8 +6880,9 @@ = happyThen ((case happyOut158 happy_x_1 of { (HappyWrap158 happy_var_1) -> case happyOutTok happy_x_2 of { happy_var_2 -> case happyOut154 happy_x_3 of { (HappyWrap154 happy_var_3) -> - ( hintLinear (getLoc happy_var_2) >>- ams (sLL happy_var_1 happy_var_3 $ HsFunTy noExtField HsLinearArrow happy_var_1 happy_var_3)+ ( hintLinear (getLoc happy_var_2)+ >> ams happy_var_1 [mu AnnLollyU happy_var_2] -- See Note [GADT decl discards annotations]+ >> ams (sLL happy_var_1 happy_var_3 $ HsFunTy noExtField (HsLinearArrow UnicodeSyntax) happy_var_1 happy_var_3) [mu AnnLollyU happy_var_2])}}}) ) (\r -> happyReturn (happyIn156 r)) @@ -6902,7 +6893,7 @@ = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOut163 happy_x_2 of { (HappyWrap163 happy_var_2) -> happyIn157- (sLL happy_var_1 happy_var_2 (mkMultTy happy_var_2)+ (sLL happy_var_1 happy_var_2 (\u -> mkMultTy u happy_var_1 happy_var_2) )}} happyReduce_362 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -7638,9 +7629,9 @@ = happyThen ((case happyOut267 happy_x_2 of { (HappyWrap267 happy_var_2) -> case happyOutTok happy_x_3 of { happy_var_3 -> case happyOut148 happy_x_4 of { (HappyWrap148 happy_var_4) -> - ( do { decl <- mkGadtDecl (unLoc happy_var_2) happy_var_4+ ( do { (decl, anns) <- mkGadtDecl (unLoc happy_var_2) happy_var_4 ; ams (sLL happy_var_2 happy_var_4 decl)- [mu AnnDcolon happy_var_3] })}}})+ (mu AnnDcolon happy_var_3:anns) })}}}) ) (\r -> happyReturn (happyIn179 r)) happyReduce_430 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )@@ -8150,7 +8141,7 @@ case happyOutTok happy_x_6 of { happy_var_6 -> ( ams ( let inl_prag = mkInlinePragma (getSPEC_PRAGs happy_var_1)- (NoUserInline, FunLike) (snd happy_var_2)+ (NoUserInlinePrag, FunLike) (snd happy_var_2) in sLL happy_var_1 happy_var_6 $ SigD noExtField (SpecSig noExtField happy_var_3 (fromOL happy_var_5) inl_prag)) (mo happy_var_1:mu AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)))}}}}}}) ) (\r -> happyReturn (happyIn197 r))@@ -9882,7 +9873,7 @@ happyRest) tk = happyThen ((case happyOut201 happy_x_1 of { (HappyWrap201 happy_var_1) -> ( -- See Note [Parser-Validator Hint] in GHC.Parser.PostProcess- checkPattern_msg (text "Possibly caused by a missing 'do'?")+ checkPattern_hints [SuggestMissingDo] (unECP happy_var_1))}) ) (\r -> happyReturn (happyIn240 r)) @@ -11915,10 +11906,9 @@ getSCC :: Located Token -> P FastString getSCC lt = do let s = getSTRING lt- err = "Spaces are not allowed in SCCs" -- We probably actually want to be more restrictive than this if ' ' `elem` unpackFS s- then addFatalError (getLoc lt) (text err)+ then addFatalError $ Error ErrSpaceInSCC [] (getLoc lt) else return s -- Utilities for combining source spans@@ -12003,8 +11993,7 @@ hintLinear :: MonadP m => SrcSpan -> m () hintLinear span = do linearEnabled <- getBit LinearTypesBit- unless linearEnabled $ addError span $- text "Enable LinearTypes to allow linear functions"+ unless linearEnabled $ addError $ Error ErrLinearFunction [] span -- Does this look like (a %m)? looksLikeMult :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> Bool@@ -12023,22 +12012,14 @@ hintMultiWayIf :: SrcSpan -> P () hintMultiWayIf span = do mwiEnabled <- getBit MultiWayIfBit- unless mwiEnabled $ addError span $- text "Multi-way if-expressions need MultiWayIf turned on"+ unless mwiEnabled $ addError $ Error ErrMultiWayIf [] span -- Hint about explicit-forall hintExplicitForall :: Located Token -> P () hintExplicitForall tok = do forall <- getBit ExplicitForallBit rulePrag <- getBit InRulePragBit- unless (forall || rulePrag) $ addError (getLoc tok) $ vcat- [ text "Illegal symbol" <+> quotes forallSymDoc <+> text "in type"- , text "Perhaps you intended to use RankNTypes or a similar language"- , text "extension to enable explicit-forall syntax:" <+>- forallSymDoc <+> text "<tvs>. <type>"- ]- where- forallSymDoc = text (forallSym (isUnicode tok))+ unless (forall || rulePrag) $ addError $ Error (ErrExplicitForall (isUnicode tok)) [] (getLoc tok) -- Hint about qualified-do hintQualifiedDo :: Located Token -> P ()@@ -12046,10 +12027,7 @@ qualifiedDo <- getBit QualifiedDoBit case maybeQDoDoc of Just qdoDoc | not qualifiedDo ->- addError (getLoc tok) $ vcat- [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block"- , text "Perhaps you intended to use QualifiedDo"- ]+ addError $ Error (ErrIllegalQualifiedDo qdoDoc) [] (getLoc tok) _ -> return () where maybeQDoDoc = case unLoc tok of@@ -12063,17 +12041,7 @@ reportEmptyDoubleQuotes :: SrcSpan -> P a reportEmptyDoubleQuotes span = do thQuotes <- getBit ThQuotesBit- if thQuotes- then addFatalError span $ vcat- [ text "Parser error on `''`"- , text "Character literals may not be empty"- , text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"- , text "but the type variable or constructor is missing"- ]- else addFatalError span $ vcat- [ text "Parser error on `''`"- , text "Character literals may not be empty"- ]+ addFatalError $ Error (ErrEmptyDoubleQuotes thQuotes) [] span {- %************************************************************************@@ -12103,6 +12071,9 @@ -- 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 :: Located a -> SrcSpan gl = getLoc
ghc-lib/stage0/compiler/build/GHC/Parser/Lexer.hs view
@@ -14,11 +14,9 @@ ParserOpts(..), mkParserOpts, PState (..), initParserState, initPragState, P(..), ParseResult(..),- appendWarning,- appendError, allocateComments, MonadP(..),- getRealSrcLoc, getPState, withHomeUnitId,+ getRealSrcLoc, getPState, failMsgP, failLocMsgP, srcParseFail, getErrorMessages, getMessages, popContext, pushModuleContext, setLastToken, setSrcLoc,@@ -27,10 +25,10 @@ ExtBits(..), xtest, xunset, xset, lexTokenStream,- AddAnn(..),mkParensApiAnn, addAnnsAt, commentToAnnotation, HdkComment(..),+ warnopt, ) where import GHC.Prelude@@ -65,19 +63,17 @@ import GHC.Data.Maybe import GHC.Data.OrdList import GHC.Utils.Misc ( readRational, readHexRational )-import GHC.Utils.Error-import GHC.Driver.Session as DynFlags import GHC.Types.SrcLoc-import GHC.Unit-import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..),- IntegralLit(..), FractionalLit(..),- SourceText(..) )+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 #if __GLASGOW_HASKELL__ >= 603 #include "ghcconfig.h"@@ -595,7 +591,7 @@ , (0,alex_action_116) ] -{-# LINE 675 "compiler/GHC/Parser/Lexer.x" #-}+{-# LINE 671 "compiler/GHC/Parser/Lexer.x" #-} -- -----------------------------------------------------------------------------@@ -1010,7 +1006,7 @@ failLinePrag1 span _buf _len = do b <- getBit InNestedCommentBit if b then return (L span ITcomment_line_prag)- else lexError "lexical error in pragma"+ else lexError LexErrorInPragma -- See Note [Nested comment line pragmas] popLinePrag1 :: Action@@ -1031,7 +1027,7 @@ Layout prev_off _ : _ -> prev_off < offset _ -> True if isOK then pop_and open_brace span buf len- else addFatalError (mkSrcSpanPs span) (text "Missing block")+ else addFatalError $ Error ErrMissingBlock [] (mkSrcSpanPs span) pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState@@ -1410,7 +1406,7 @@ commentEnd lexToken input commentAcc finalizeComment buf span errBrace :: AlexInput -> RealSrcSpan -> P a-errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) "unterminated `{-'"+errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) (Error (ErrLexer LexUnterminatedComment LexErrKind_EOF) []) open_brace, close_brace :: Action open_brace span _str _len = do@@ -1469,8 +1465,7 @@ lambdaCase <- getBit LambdaCaseBit unless lambdaCase $ do pState <- getPState- addError (mkSrcSpanPs (last_loc pState)) $ text- "Illegal lambda-case (use LambdaCase)"+ addError $ Error ErrLambdaCase [] (mkSrcSpanPs (last_loc pState)) return ITlcase _ -> return ITcase maybe_layout keyword@@ -1500,43 +1495,65 @@ -- See Note [Whitespace-sensitive operator parsing] varsym_prefix :: Action-varsym_prefix = sym $ \exts s ->- if | s == fsLit "@" -- regardless of TypeApplications for better error messages- -> return ITtypeApp- | LinearTypesBit `xtest` exts, s == fsLit "%"- -> return ITpercent- | ThQuotesBit `xtest` exts, s == fsLit "$"- -> return ITdollar- | ThQuotesBit `xtest` exts, s == fsLit "$$"- -> return ITdollardollar- | s == fsLit "-" -- Only when LexicalNegation is on, otherwise we get ITminus and- -- don't hit this code path. See Note [Minus tokens]- -> return ITprefixminus+varsym_prefix = sym $ \span exts s ->+ let warnExtConflict errtok =+ do { addWarning Opt_WarnOperatorWhitespaceExtConflict $+ WarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) 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 "!" -> return ITbang | s == fsLit "~" -> return ITtilde- | otherwise -> return (ITvarsym s)+ | otherwise ->+ do { addWarning Opt_WarnOperatorWhitespace $+ WarnOperatorWhitespace (mkSrcSpanPs span) s+ OperatorWhitespaceOccurrence_Prefix+ ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] varsym_suffix :: Action-varsym_suffix = sym $ \_ s ->- if | s == fsLit "@"- -> failMsgP "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."- | otherwise -> return (ITvarsym s)+varsym_suffix = sym $ \span _ s ->+ if | s == fsLit "@" -> failMsgP (Error ErrSuffixAT [])+ | otherwise ->+ do { addWarning Opt_WarnOperatorWhitespace $+ WarnOperatorWhitespace (mkSrcSpanPs span) s+ OperatorWhitespaceOccurrence_Suffix+ ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] varsym_tight_infix :: Action-varsym_tight_infix = sym $ \_ s ->+varsym_tight_infix = sym $ \span _ s -> if | s == fsLit "@" -> return ITat- | otherwise -> return (ITvarsym s)+ | otherwise ->+ do { addWarning Opt_WarnOperatorWhitespace $+ WarnOperatorWhitespace (mkSrcSpanPs span) s+ OperatorWhitespaceOccurrence_TightInfix+ ; return (ITvarsym s) } -- See Note [Whitespace-sensitive operator parsing] varsym_loose_infix :: Action-varsym_loose_infix = sym (\_ s -> return $ ITvarsym s)+varsym_loose_infix = sym (\_ _ s -> return $ ITvarsym s) consym :: Action-consym = sym (\_exts s -> return $ ITconsym s)+consym = sym (\_span _exts s -> return $ ITconsym s) -sym :: (ExtsBitmap -> FastString -> P Token) -> Action+sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action sym con span buf len = case lookupUFM reservedSymsFM fs of Just (keyword, NormalSyntax, 0) ->@@ -1545,20 +1562,20 @@ exts <- getExts if exts .&. i /= 0 then return $ L span keyword- else L span <$!> con exts fs+ 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 exts fs+ 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 exts fs+ else L span <$!> con span exts fs Nothing -> do exts <- getExts- L span <$!> con exts fs+ L span <$!> con span exts fs where !fs = lexemeToFastString buf len @@ -1573,8 +1590,7 @@ let src = lexemeToString buf len when ((not numericUnderscores) && ('_' `elem` src)) $ do pState <- getPState- addError (mkSrcSpanPs (last_loc pState)) $ text- "Use NumericUnderscores to allow underscores in integer literals"+ addError $ Error (ErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState)) return $ L span $ itint (SourceText src) $! transint $ parseUnsignedInteger (offsetBytes transbuf buf) (subtract translen len) radix char_to_int@@ -1615,8 +1631,7 @@ let src = lexemeToString buf (len-drop) when ((not numericUnderscores) && ('_' `elem` src)) $ do pState <- getPState- addError (mkSrcSpanPs (last_loc pState)) $ text- "Use NumericUnderscores to allow underscores in floating literals"+ addError $ Error (ErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState)) return (L span $! (f $! src)) tok_float, tok_primfloat, tok_primdouble :: String -> Token@@ -1786,7 +1801,7 @@ = case alexGetChar i of Just (c,i') | c == x -> isString i' xs _other -> False- err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) "unterminated options pragma"+ err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) (Error (ErrLexer LexUnterminatedOptions LexErrKind_EOF) []) -- -----------------------------------------------------------------------------@@ -1824,8 +1839,8 @@ setInput i when (any (> '\xFF') s') $ do pState <- getPState- addError (mkSrcSpanPs (last_loc pState)) $ text- "primitive string literal must contain only characters <= \'\\xFF\'"+ let err = Error ErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState))+ addError err return (ITprimstring (SourceText s') (unsafeMkByteString s')) _other -> return (ITstring (SourceText s') (mkFastString s'))@@ -1981,7 +1996,7 @@ Just (c,input') | is_digit c -> do let i' = i*base + conv c if i' > 0x10ffff- then setInput input >> lexError "numeric escape sequence out of range"+ then setInput input >> lexError LexNumEscapeRange else read i' input' _other -> do setInput input; return (chr i)@@ -2030,12 +2045,12 @@ -- 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 "lexical error in string/character literal"+lit_error i = do setInput i; lexError LexStringCharLit getCharOrFail :: AlexInput -> P Char getCharOrFail i = do case alexGetChar' i of- Nothing -> lexError "unexpected end-of-file in string/character literal"+ Nothing -> lexError LexStringCharLitEOF Just (c,i) -> do setInput i; return c -- -----------------------------------------------------------------------------@@ -2086,7 +2101,8 @@ quasiquote_error :: RealSrcLoc -> P a quasiquote_error start = do (AI end buf) <- getInput- reportLexError start (psRealLoc end) buf "unterminated quasiquotation"+ reportLexError start (psRealLoc end) buf+ (\k -> Error (ErrLexer LexUnterminatedQQ k) []) -- ----------------------------------------------------------------------------- -- Warnings@@ -2096,9 +2112,9 @@ addTabWarning (psRealSpan srcspan) lexToken -warnThen :: WarningFlag -> SDoc -> Action -> Action-warnThen option warning action srcspan buf len = do- addWarning option (RealSrcSpan (psRealSpan srcspan) Nothing) warning+warnThen :: WarningFlag -> (SrcSpan -> Warning) -> Action -> Action+warnThen flag warning action srcspan buf len = do+ addWarning flag (warning (RealSrcSpan (psRealSpan srcspan) Nothing)) action srcspan buf len -- -----------------------------------------------------------------------------@@ -2139,10 +2155,8 @@ -- | Parser options. -- -- See 'mkParserOpts' to construct this.-data ParserOpts = ParserOpts {- pWarningFlags :: EnumSet WarningFlag- , pHomeUnitId :: UnitId -- ^ id of the unit currently being compiled- -- (only used in Cmm parser)+data ParserOpts = ParserOpts+ { pWarningFlags :: EnumSet WarningFlag -- ^ enabled warning flags , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions } @@ -2158,11 +2172,10 @@ data PState = PState { buffer :: StringBuffer, options :: ParserOpts,- -- This needs to take DynFlags as an argument until- -- we have a fix for #10143- messages :: DynFlags -> Messages,+ warnings :: Bag Warning,+ errors :: Bag Error, tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file- tab_count :: !Int, -- number of tab warnings in the file+ tab_count :: !Word, -- number of tab warnings in the file last_tk :: Maybe Token, last_loc :: PsSpan, -- pos of previous token last_len :: !Int, -- len of previous token@@ -2240,21 +2253,18 @@ POk s1 a -> (unP (k a)) s1 PFailed s1 -> PFailed s1 -failMsgP :: String -> P a-failMsgP msg = do+failMsgP :: (SrcSpan -> Error) -> P a+failMsgP f = do pState <- getPState- addFatalError (mkSrcSpanPs (last_loc pState)) (text msg)+ addFatalError (f (mkSrcSpanPs (last_loc pState))) -failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a-failLocMsgP loc1 loc2 str =- addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing) (text str)+failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> Error) -> P a+failLocMsgP loc1 loc2 f =+ addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing)) getPState :: P PState getPState = P $ \s -> POk s s -withHomeUnitId :: (UnitId -> a) -> P a-withHomeUnitId f = P $ \s@(PState{options = o}) -> POk s (f (pHomeUnitId o))- getExts :: P ExtsBitmap getExts = P $ \s -> POk s (pExtsBitmap . options $ s) @@ -2294,7 +2304,7 @@ getLastTk :: P (Maybe Token) getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk -data AlexInput = AI PsLoc StringBuffer+data AlexInput = AI !PsLoc !StringBuffer {- Note [Unicode in Alex]@@ -2567,8 +2577,6 @@ mkParserOpts :: EnumSet WarningFlag -- ^ warnings flags enabled -> EnumSet LangExt.Extension -- ^ permitted language extensions enabled- -> UnitId -- ^ id of the unit currently being compiled- -- (used in Cmm parser) -> Bool -- ^ are safe imports on? -> Bool -- ^ keeping Haddock comment tokens -> Bool -- ^ keep regular comment tokens@@ -2580,11 +2588,10 @@ -> ParserOpts -- ^ Given exactly the information needed, set up the 'ParserOpts'-mkParserOpts warningFlags extensionFlags homeUnitId+mkParserOpts warningFlags extensionFlags safeImports isHaddock rawTokStream usePosPrags = ParserOpts { pWarningFlags = warningFlags- , pHomeUnitId = homeUnitId , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits } where@@ -2656,7 +2663,8 @@ PState { buffer = buf, options = options,- messages = const emptyMessages,+ errors = emptyBag,+ warnings = emptyBag, tab_first = Nothing, tab_count = 0, last_tk = Nothing,@@ -2702,59 +2710,40 @@ -- to the accumulator and parsing continues. This allows GHC to report -- more than one parse error per file. --- addError :: SrcSpan -> SDoc -> m ()+ addError :: Error -> m ()+ -- | Add a warning to the accumulator. -- Use 'getMessages' to get the accumulated warnings.- addWarning :: WarningFlag -> SrcSpan -> SDoc -> m ()+ addWarning :: WarningFlag -> Warning -> 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 :: SrcSpan -> SDoc -> m a+ addFatalError :: Error -> m a+ -- | Check if a given flag is currently set in the bitmap. getBit :: ExtBits -> m Bool+ -- | Given a location and a list of AddAnn, apply them all to the location. addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct -> AnnKeywordId -- The first two parameters are the key -> SrcSpan -- The location of the keyword itself -> m () -appendError- :: SrcSpan- -> SDoc- -> (DynFlags -> Messages)- -> (DynFlags -> Messages)-appendError srcspan msg m =- \d ->- let (ws, es) = m d- errormsg = mkErrMsg d srcspan alwaysQualify msg- es' = es `snocBag` errormsg- in (ws, es')+instance MonadP P where+ addError err+ = P $ \s -> POk s { errors = err `consBag` errors s} () -appendWarning- :: ParserOpts- -> WarningFlag- -> SrcSpan- -> SDoc- -> (DynFlags -> Messages)- -> (DynFlags -> Messages)-appendWarning o option srcspan warning m =- \d ->- let (ws, es) = m d- warning' = makeIntoWarning (Reason option) $- mkWarnMsg d srcspan alwaysQualify warning- ws' = if warnopt option o then ws `snocBag` warning' else ws- in (ws', es)+ addWarning option w+ = P $ \s -> if warnopt option (options s)+ then POk (s { warnings = w `consBag` warnings s }) ()+ else POk s () -instance MonadP P where- addError srcspan msg- = P $ \s@PState{messages=m} ->- POk s{messages=appendError srcspan msg m} ()- addWarning option srcspan warning- = P $ \s@PState{messages=m, options=o} ->- POk s{messages=appendWarning o option srcspan warning m} ()- addFatalError span msg =- addError span msg >> P PFailed+ addFatalError err =+ addError err >> P PFailed+ getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s) in b `seq` POk s b+ addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) = do addAnnotationOnly l a v allocateCommentsP l@@ -2773,32 +2762,23 @@ else s in POk s' () -mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg-mkTabWarning PState{tab_first=tf, tab_count=tc} d =- let middle = if tc == 1- then text ""- else text ", and in" <+> speakNOf (tc - 1) (text "further location")- message = text "Tab character found here"- <> middle- <> text "."- $+$ text "Please use spaces instead."- in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $- mkWarnMsg d (RealSrcSpan s Nothing) alwaysQualify message) tf- -- | Get a bag of the errors that have been accumulated so far. -- Does not take -Werror into account.-getErrorMessages :: PState -> DynFlags -> ErrorMessages-getErrorMessages PState{messages=m} d =- let (_, es) = m d in es+getErrorMessages :: PState -> Bag Error+getErrorMessages p = errors p -- | Get the warnings and errors accumulated so far. -- Does not take -Werror into account.-getMessages :: PState -> DynFlags -> Messages-getMessages p@PState{messages=m} d =- let (ws, es) = m d- tabwarning = mkTabWarning p d- ws' = maybe ws (`consBag` ws) tabwarning- in (ws', es)+getMessages :: PState -> (Bag Warning, Bag Error)+getMessages p =+ let ws = warnings p+ -- we add the tabulation warning on the fly because+ -- we count the number of occurences of tab characters+ ws' = case tab_first p of+ Nothing -> ws+ Just tf -> WarnTab (RealSrcSpan tf Nothing) (tab_count p)+ `consBag` ws+ in (ws', errors p) getContext :: P [LayoutContext] getContext = P $ \s@PState{context=ctx} -> POk s ctx@@ -2813,7 +2793,7 @@ (_:tl) -> POk s{ context = tl } () [] ->- unP (addFatalError (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s+ 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 ()@@ -2843,45 +2823,44 @@ :: ParserOpts -> StringBuffer -- current buffer (placed just after the last token) -> Int -- length of the previous token- -> MsgDoc-srcParseErr options buf len- = if null token- then text "parse error (possibly incorrect indentation or mismatched brackets)"- else text "parse error on input" <+> quotes (text token)- $$ ppWhen (not th_enabled && token == "$") -- #7396- (text "Perhaps you intended to use TemplateHaskell")- $$ ppWhen (token == "<-")- (if mdoInLast100- then text "Perhaps you intended to use RecursiveDo"- else text "Perhaps this statement should be within a 'do' block?")- $$ ppWhen (token == "=" && doInLast100) -- #15849- (text "Perhaps you need a 'let' in a 'do' block?"- $$ text "e.g. 'let x = 5' instead of 'x = 5'")- $$ ppWhen (not ps_enabled && pattern == "pattern ") -- #12429- (text "Perhaps you intended to use PatternSynonyms")- 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+ -> SrcSpan+ -> Error+srcParseErr options buf len loc = Error (ErrParse token) suggests loc+ 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 + sug c s = if c then Just s else Nothing+ sug_th = sug (not th_enabled && token == "$") SuggestTH -- #7396+ sug_rdo = sug (token == "<-" && mdoInLast100) SuggestRecursiveDo+ sug_do = sug (token == "<-" && not mdoInLast100) SuggestDo+ sug_let = sug (token == "=" && doInLast100) SuggestLetInDo -- #15849+ sug_pat = sug (not ps_enabled && pattern == "pattern ") SuggestPatternSynonyms -- #12429+ suggests+ | null token = []+ | otherwise = catMaybes [sug_th, sug_rdo, sug_do, sug_let, sug_pat]+ -- 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 (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s+ 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 :: String -> P a-lexError str = do+lexError :: LexErr -> P a+lexError e = do loc <- getRealSrcLoc (AI end buf) <- getInput- reportLexError loc (psRealLoc end) buf str+ reportLexError loc (psRealLoc end) buf+ (\k -> Error (ErrLexer e k) []) -- ----------------------------------------------------------------------------- -- This is the top-level function: called from the parser each time a@@ -2997,9 +2976,7 @@ (ITwhere, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional- (mkSrcSpanPs thisLoc)- (transitionalAlternativeLayoutWarning- "`where' clause at the same depth as implicit layout block")+ $ WarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Where setALRContext ls setNextToken t -- Note that we use lastLoc, as we may need to close@@ -3009,9 +2986,7 @@ (ITvbar, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional- (mkSrcSpanPs thisLoc)- (transitionalAlternativeLayoutWarning- "`|' at the same depth as implicit layout block")+ $ WarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Pipe setALRContext ls setNextToken t -- Note that we use lastLoc, as we may need to close@@ -3078,11 +3053,6 @@ -- the other ITwhere case omitted; general case below covers it (_, _, _) -> return t -transitionalAlternativeLayoutWarning :: String -> SDoc-transitionalAlternativeLayoutWarning msg- = text "transitional layout will not be accepted in the future:"- $$ text msg- isALRopen :: Token -> Bool isALRopen ITcase = True isALRopen ITif = True@@ -3137,7 +3107,8 @@ setLastToken span 0 return (L span ITeof) AlexError (AI loc2 buf) ->- reportLexError (psRealLoc loc1) (psRealLoc loc2) buf "lexical error"+ reportLexError (psRealLoc loc1) (psRealLoc loc2) buf+ (\k -> Error (ErrLexer LexError k) []) AlexSkip inp2 _ -> do setInput inp2 lexToken@@ -3151,14 +3122,14 @@ unless (isComment lt') (setLastTk lt') return lt -reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a-reportLexError loc1 loc2 buf str- | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")+reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> Error) -> 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 (str ++ " (UTF-8 decoding error)")- else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)+ 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' }@@ -3233,7 +3204,7 @@ 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 "unknown pragma"+ Nothing -> lexError LexUnknownPragma known_pragma :: Map String Action -> AlexAccPred ExtsBitmap known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)@@ -3264,45 +3235,12 @@ %************************************************************************ -} --- | Encapsulated call to addAnnotation, requiring only the SrcSpan of--- the AST construct the annotation belongs to; together with the--- AnnKeywordId, this is the key of the annotation map.------ This type is useful for places in the parser where it is not yet--- known what SrcSpan an annotation should be added to. The most--- common situation is when we are parsing a list: the annotations--- need to be associated with the AST element that *contains* the--- list, not the list itself. 'AddAnn' lets us defer adding the--- annotations until we finish parsing the list and are now parsing--- the enclosing element; we then apply the 'AddAnn' to associate--- the annotations. Another common situation is where a common fragment of--- the AST has been factored out but there is no separate AST node for--- this fragment (this occurs in class and data declarations). In this--- case, the annotation belongs to the parent data declaration.------ The usual way an 'AddAnn' is created is using the 'mj' ("make jump")--- function, and then it can be discharged using the 'ams' function.-data AddAnn = AddAnn AnnKeywordId SrcSpan addAnnotationOnly :: RealSrcSpan -> AnnKeywordId -> RealSrcSpan -> P () addAnnotationOnly l a v = P $ \s -> POk s { annotations = ((l,a), [v]) : annotations s } () --- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate--- 'AddAnn' values for the opening and closing bordering on the start--- and end of the span-mkParensApiAnn :: SrcSpan -> [AddAnn]-mkParensApiAnn (UnhelpfulSpan _) = []-mkParensApiAnn (RealSrcSpan ss _) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc]- where- f = srcSpanFile ss- sl = srcSpanStartLine ss- sc = srcSpanStartCol ss- el = srcSpanEndLine ss- ec = srcSpanEndCol ss- lo = RealSrcSpan (mkRealSrcSpan (realSrcSpanStart ss) (mkRealSrcLoc f sl (sc+1))) Nothing- lc = RealSrcSpan (mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)) Nothing queueComment :: RealLocated Token -> P() queueComment c = P $ \s -> POk s {@@ -3401,7 +3339,7 @@ alex_action_34 = endPrag alex_action_35 = dispatch_pragmas fileHeaderPrags alex_action_36 = nested_comment lexToken -alex_action_37 = warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma")+alex_action_37 = warnThen Opt_WarnUnrecognisedPragmas WarnUnrecognisedPragma (nested_comment lexToken) alex_action_38 = multiline_doc_comment alex_action_39 = nested_doc_comment
ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl view
@@ -63,6 +63,8 @@ primOpCanFail IndexByteArrayOp_Word64 = True primOpCanFail IndexByteArrayOp_Word8AsChar = True primOpCanFail IndexByteArrayOp_Word8AsWideChar = True+primOpCanFail IndexByteArrayOp_Word8AsInt = True+primOpCanFail IndexByteArrayOp_Word8AsWord = True primOpCanFail IndexByteArrayOp_Word8AsAddr = True primOpCanFail IndexByteArrayOp_Word8AsFloat = True primOpCanFail IndexByteArrayOp_Word8AsDouble = True@@ -70,11 +72,9 @@ primOpCanFail IndexByteArrayOp_Word8AsInt16 = True primOpCanFail IndexByteArrayOp_Word8AsInt32 = True primOpCanFail IndexByteArrayOp_Word8AsInt64 = True-primOpCanFail IndexByteArrayOp_Word8AsInt = True primOpCanFail IndexByteArrayOp_Word8AsWord16 = True primOpCanFail IndexByteArrayOp_Word8AsWord32 = True primOpCanFail IndexByteArrayOp_Word8AsWord64 = True-primOpCanFail IndexByteArrayOp_Word8AsWord = True primOpCanFail ReadByteArrayOp_Char = True primOpCanFail ReadByteArrayOp_WideChar = True primOpCanFail ReadByteArrayOp_Int = True@@ -93,6 +93,8 @@ primOpCanFail ReadByteArrayOp_Word64 = True primOpCanFail ReadByteArrayOp_Word8AsChar = True primOpCanFail ReadByteArrayOp_Word8AsWideChar = True+primOpCanFail ReadByteArrayOp_Word8AsInt = True+primOpCanFail ReadByteArrayOp_Word8AsWord = True primOpCanFail ReadByteArrayOp_Word8AsAddr = True primOpCanFail ReadByteArrayOp_Word8AsFloat = True primOpCanFail ReadByteArrayOp_Word8AsDouble = True@@ -100,11 +102,9 @@ primOpCanFail ReadByteArrayOp_Word8AsInt16 = True primOpCanFail ReadByteArrayOp_Word8AsInt32 = True primOpCanFail ReadByteArrayOp_Word8AsInt64 = True-primOpCanFail ReadByteArrayOp_Word8AsInt = True primOpCanFail ReadByteArrayOp_Word8AsWord16 = True primOpCanFail ReadByteArrayOp_Word8AsWord32 = True primOpCanFail ReadByteArrayOp_Word8AsWord64 = True-primOpCanFail ReadByteArrayOp_Word8AsWord = True primOpCanFail WriteByteArrayOp_Char = True primOpCanFail WriteByteArrayOp_WideChar = True primOpCanFail WriteByteArrayOp_Int = True@@ -123,6 +123,8 @@ primOpCanFail WriteByteArrayOp_Word64 = True primOpCanFail WriteByteArrayOp_Word8AsChar = True primOpCanFail WriteByteArrayOp_Word8AsWideChar = True+primOpCanFail WriteByteArrayOp_Word8AsInt = True+primOpCanFail WriteByteArrayOp_Word8AsWord = True primOpCanFail WriteByteArrayOp_Word8AsAddr = True primOpCanFail WriteByteArrayOp_Word8AsFloat = True primOpCanFail WriteByteArrayOp_Word8AsDouble = True@@ -130,11 +132,9 @@ primOpCanFail WriteByteArrayOp_Word8AsInt16 = True primOpCanFail WriteByteArrayOp_Word8AsInt32 = True primOpCanFail WriteByteArrayOp_Word8AsInt64 = True-primOpCanFail WriteByteArrayOp_Word8AsInt = True primOpCanFail WriteByteArrayOp_Word8AsWord16 = True primOpCanFail WriteByteArrayOp_Word8AsWord32 = True primOpCanFail WriteByteArrayOp_Word8AsWord64 = True-primOpCanFail WriteByteArrayOp_Word8AsWord = True primOpCanFail CompareByteArraysOp = True primOpCanFail CopyByteArrayOp = True primOpCanFail CopyMutableByteArrayOp = True
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -292,6 +292,8 @@ | IndexByteArrayOp_Word64 | IndexByteArrayOp_Word8AsChar | IndexByteArrayOp_Word8AsWideChar+ | IndexByteArrayOp_Word8AsInt+ | IndexByteArrayOp_Word8AsWord | IndexByteArrayOp_Word8AsAddr | IndexByteArrayOp_Word8AsFloat | IndexByteArrayOp_Word8AsDouble@@ -299,11 +301,9 @@ | IndexByteArrayOp_Word8AsInt16 | IndexByteArrayOp_Word8AsInt32 | IndexByteArrayOp_Word8AsInt64- | IndexByteArrayOp_Word8AsInt | IndexByteArrayOp_Word8AsWord16 | IndexByteArrayOp_Word8AsWord32 | IndexByteArrayOp_Word8AsWord64- | IndexByteArrayOp_Word8AsWord | ReadByteArrayOp_Char | ReadByteArrayOp_WideChar | ReadByteArrayOp_Int@@ -322,6 +322,8 @@ | ReadByteArrayOp_Word64 | ReadByteArrayOp_Word8AsChar | ReadByteArrayOp_Word8AsWideChar+ | ReadByteArrayOp_Word8AsInt+ | ReadByteArrayOp_Word8AsWord | ReadByteArrayOp_Word8AsAddr | ReadByteArrayOp_Word8AsFloat | ReadByteArrayOp_Word8AsDouble@@ -329,11 +331,9 @@ | ReadByteArrayOp_Word8AsInt16 | ReadByteArrayOp_Word8AsInt32 | ReadByteArrayOp_Word8AsInt64- | ReadByteArrayOp_Word8AsInt | ReadByteArrayOp_Word8AsWord16 | ReadByteArrayOp_Word8AsWord32 | ReadByteArrayOp_Word8AsWord64- | ReadByteArrayOp_Word8AsWord | WriteByteArrayOp_Char | WriteByteArrayOp_WideChar | WriteByteArrayOp_Int@@ -352,6 +352,8 @@ | WriteByteArrayOp_Word64 | WriteByteArrayOp_Word8AsChar | WriteByteArrayOp_Word8AsWideChar+ | WriteByteArrayOp_Word8AsInt+ | WriteByteArrayOp_Word8AsWord | WriteByteArrayOp_Word8AsAddr | WriteByteArrayOp_Word8AsFloat | WriteByteArrayOp_Word8AsDouble@@ -359,11 +361,9 @@ | WriteByteArrayOp_Word8AsInt16 | WriteByteArrayOp_Word8AsInt32 | WriteByteArrayOp_Word8AsInt64- | WriteByteArrayOp_Word8AsInt | WriteByteArrayOp_Word8AsWord16 | WriteByteArrayOp_Word8AsWord32 | WriteByteArrayOp_Word8AsWord64- | WriteByteArrayOp_Word8AsWord | CompareByteArraysOp | CopyByteArrayOp | CopyMutableByteArrayOp@@ -458,6 +458,8 @@ | WriteOffAddrOp_Word64 | InterlockedExchange_Addr | InterlockedExchange_Int+ | AtomicCompareExchange_Int+ | AtomicCompareExchange_Addr | NewMutVarOp | ReadMutVarOp | WriteMutVarOp
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -105,36 +105,96 @@ , ("sizeofByteArray#","Return the size of the array in bytes.") , ("sizeofMutableByteArray#","Return the size of the array in bytes. Note that this is deprecated as it is\n unsafe in the presence of shrink and resize operations on the same mutable byte\n array.") , ("getSizeofMutableByteArray#","Return the number of elements in the array.")- , ("indexCharArray#","Read 8-bit character; offset in bytes.")- , ("indexWideCharArray#","Read 31-bit character; offset in 4-byte words.")- , ("indexInt8Array#","Read 8-bit integer; offset in bytes.")- , ("indexInt16Array#","Read 16-bit integer; offset in 16-bit words.")- , ("indexInt32Array#","Read 32-bit integer; offset in 32-bit words.")- , ("indexInt64Array#","Read 64-bit integer; offset in 64-bit words.")- , ("indexWord8Array#","Read 8-bit word; offset in bytes.")- , ("indexWord16Array#","Read 16-bit word; offset in 16-bit words.")- , ("indexWord32Array#","Read 32-bit word; offset in 32-bit words.")- , ("indexWord64Array#","Read 64-bit word; offset in 64-bit words.")- , ("indexWord8ArrayAsChar#","Read 8-bit character; offset in bytes.")- , ("indexWord8ArrayAsWideChar#","Read 31-bit character; offset in bytes.")- , ("indexWord8ArrayAsAddr#","Read address; offset in bytes.")- , ("indexWord8ArrayAsFloat#","Read float; offset in bytes.")- , ("indexWord8ArrayAsDouble#","Read double; offset in bytes.")- , ("indexWord8ArrayAsStablePtr#","Read stable pointer; offset in bytes.")- , ("indexWord8ArrayAsInt16#","Read 16-bit int; offset in bytes.")- , ("indexWord8ArrayAsInt32#","Read 32-bit int; offset in bytes.")- , ("indexWord8ArrayAsInt64#","Read 64-bit int; offset in bytes.")- , ("indexWord8ArrayAsInt#","Read int; offset in bytes.")- , ("indexWord8ArrayAsWord16#","Read 16-bit word; offset in bytes.")- , ("indexWord8ArrayAsWord32#","Read 32-bit word; offset in bytes.")- , ("indexWord8ArrayAsWord64#","Read 64-bit word; offset in bytes.")- , ("indexWord8ArrayAsWord#","Read word; offset in bytes.")- , ("readCharArray#","Read 8-bit character; offset in bytes.")- , ("readWideCharArray#","Read 31-bit character; offset in 4-byte words.")- , ("readIntArray#","Read integer; offset in machine words.")- , ("readWordArray#","Read word; offset in machine words.")- , ("writeCharArray#","Write 8-bit character; offset in bytes.")- , ("writeWideCharArray#","Write 31-bit character; offset in 4-byte words.")+ , ("indexCharArray#","Read a 8-bit character; offset in bytes.")+ , ("indexWideCharArray#","Read a 32-bit character; offset in 4-byte words.")+ , ("indexIntArray#","Read a word-sized integer; offset in machine words.")+ , ("indexWordArray#","Read a word-sized unsigned integer; offset in machine words.")+ , ("indexAddrArray#","Read a machine address; offset in machine words.")+ , ("indexFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.")+ , ("indexDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.")+ , ("indexStablePtrArray#","Read a @StablePtr#@ value; offset in machine words.")+ , ("indexInt8Array#","Read a 8-bit signed integer; offset in bytes.")+ , ("indexInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.")+ , ("indexInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")+ , ("indexInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.")+ , ("indexWord8Array#","Read a 8-bit unsigned integer; offset in bytes.")+ , ("indexWord16Array#","Read a 16-bit unsigned integer; offset in 2-byte words.")+ , ("indexWord32Array#","Read a 32-bit unsigned integer; offset in 4-byte words.")+ , ("indexWord64Array#","Read a 64-bit unsigned integer; offset in 8-byte words.")+ , ("indexWord8ArrayAsChar#","Read a 8-bit character; offset in bytes.")+ , ("indexWord8ArrayAsWideChar#","Read a 32-bit character; offset in bytes.")+ , ("indexWord8ArrayAsInt#","Read a word-sized integer; offset in bytes.")+ , ("indexWord8ArrayAsWord#","Read a word-sized unsigned integer; offset in bytes.")+ , ("indexWord8ArrayAsAddr#","Read a machine address; offset in bytes.")+ , ("indexWord8ArrayAsFloat#","Read a single-precision floating-point value; offset in bytes.")+ , ("indexWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.")+ , ("indexWord8ArrayAsStablePtr#","Read a @StablePtr#@ value; offset in bytes.")+ , ("indexWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.")+ , ("indexWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")+ , ("indexWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")+ , ("indexWord8ArrayAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")+ , ("indexWord8ArrayAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")+ , ("indexWord8ArrayAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")+ , ("readCharArray#","Read a 8-bit character; offset in bytes.")+ , ("readWideCharArray#","Read a 32-bit character; offset in 4-byte words.")+ , ("readIntArray#","Read a word-sized integer; offset in machine words.")+ , ("readWordArray#","Read a word-sized unsigned integer; offset in machine words.")+ , ("readAddrArray#","Read a machine address; offset in machine words.")+ , ("readFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.")+ , ("readDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.")+ , ("readStablePtrArray#","Read a @StablePtr#@ value; offset in machine words.")+ , ("readInt8Array#","Read a 8-bit signed integer; offset in bytes.")+ , ("readInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.")+ , ("readInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")+ , ("readInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.")+ , ("readWord8Array#","Read a 8-bit unsigned integer; offset in bytes.")+ , ("readWord16Array#","Read a 16-bit unsigned integer; offset in 2-byte words.")+ , ("readWord32Array#","Read a 32-bit unsigned integer; offset in 4-byte words.")+ , ("readWord64Array#","Read a 64-bit unsigned integer; offset in 8-byte words.")+ , ("readWord8ArrayAsChar#","Read a 8-bit character; offset in bytes.")+ , ("readWord8ArrayAsWideChar#","Read a 32-bit character; offset in bytes.")+ , ("readWord8ArrayAsInt#","Read a word-sized integer; offset in bytes.")+ , ("readWord8ArrayAsWord#","Read a word-sized unsigned integer; offset in bytes.")+ , ("readWord8ArrayAsAddr#","Read a machine address; offset in bytes.")+ , ("readWord8ArrayAsFloat#","Read a single-precision floating-point value; offset in bytes.")+ , ("readWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.")+ , ("readWord8ArrayAsStablePtr#","Read a @StablePtr#@ value; offset in bytes.")+ , ("readWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.")+ , ("readWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")+ , ("readWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")+ , ("readWord8ArrayAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")+ , ("readWord8ArrayAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")+ , ("readWord8ArrayAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")+ , ("writeCharArray#","Write a 8-bit character; offset in bytes.")+ , ("writeWideCharArray#","Write a 32-bit character; offset in 4-byte words.")+ , ("writeIntArray#","Write a word-sized integer; offset in machine words.")+ , ("writeWordArray#","Write a word-sized unsigned integer; offset in machine words.")+ , ("writeAddrArray#","Write a machine address; offset in machine words.")+ , ("writeFloatArray#","Write a single-precision floating-point value; offset in 4-byte words.")+ , ("writeDoubleArray#","Write a double-precision floating-point value; offset in 8-byte words.")+ , ("writeStablePtrArray#","Write a @StablePtr#@ value; offset in machine words.")+ , ("writeInt8Array#","Write a 8-bit signed integer; offset in bytes.")+ , ("writeInt16Array#","Write a 16-bit signed integer; offset in 2-byte words.")+ , ("writeInt32Array#","Write a 32-bit signed integer; offset in 4-byte words.")+ , ("writeInt64Array#","Write a 64-bit signed integer; offset in 8-byte words.")+ , ("writeWord8Array#","Write a 8-bit unsigned integer; offset in bytes.")+ , ("writeWord16Array#","Write a 16-bit unsigned integer; offset in 2-byte words.")+ , ("writeWord32Array#","Write a 32-bit unsigned integer; offset in 4-byte words.")+ , ("writeWord64Array#","Write a 64-bit unsigned integer; offset in 8-byte words.")+ , ("writeWord8ArrayAsChar#","Write a 8-bit character; offset in bytes.")+ , ("writeWord8ArrayAsWideChar#","Write a 32-bit character; offset in bytes.")+ , ("writeWord8ArrayAsInt#","Write a word-sized integer; offset in bytes.")+ , ("writeWord8ArrayAsWord#","Write a word-sized unsigned integer; offset in bytes.")+ , ("writeWord8ArrayAsAddr#","Write a machine address; offset in bytes.")+ , ("writeWord8ArrayAsFloat#","Write a single-precision floating-point value; offset in bytes.")+ , ("writeWord8ArrayAsDouble#","Write a double-precision floating-point value; offset in bytes.")+ , ("writeWord8ArrayAsStablePtr#","Write a @StablePtr#@ value; offset in bytes.")+ , ("writeWord8ArrayAsInt16#","Write a 16-bit signed integer; offset in bytes.")+ , ("writeWord8ArrayAsInt32#","Write a 32-bit signed integer; offset in bytes.")+ , ("writeWord8ArrayAsInt64#","Write a 64-bit signed integer; offset in bytes.")+ , ("writeWord8ArrayAsWord16#","Write a 16-bit unsigned integer; offset in bytes.")+ , ("writeWord8ArrayAsWord32#","Write a 32-bit unsigned integer; offset in bytes.")+ , ("writeWord8ArrayAsWord64#","Write a 64-bit unsigned integer; offset in bytes.") , ("compareByteArrays#","@compareByteArrays# src1 src1_ofs src2 src2_ofs n@ compares\n @n@ bytes starting at offset @src1_ofs@ in the first\n @ByteArray#@ @src1@ to the range of @n@ bytes\n (i.e. same length) starting at offset @src2_ofs@ of the second\n @ByteArray#@ @src2@. Both arrays must fully contain the\n specified ranges, but this is not checked. Returns an @Int#@\n less than, equal to, or greater than zero if the range is found,\n respectively, to be byte-wise lexicographically less than, to\n match, or be greater than the second range.") , ("copyByteArray#","@copyByteArray# src src_ofs dst dst_ofs n@ copies the range\n starting at offset @src_ofs@ of length @n@ from the\n @ByteArray#@ @src@ to the @MutableByteArray#@ @dst@\n starting at offset @dst_ofs@. Both arrays must fully contain\n the specified ranges, but this is not checked. The two arrays must\n not be the same array in different states, but this is not checked\n either.") , ("copyMutableByteArray#","Copy a range of the first MutableByteArray\\# to the specified region in the second MutableByteArray\\#.\n Both arrays must fully contain the specified ranges, but this is not checked. The regions are\n allowed to overlap, although this is only possible when the same array is provided\n as both the source and the destination.")@@ -167,8 +227,10 @@ , ("indexWideCharOffAddr#","Reads 31-bit character; offset in 4-byte words.") , ("readCharOffAddr#","Reads 8-bit character; offset in bytes.") , ("readWideCharOffAddr#","Reads 31-bit character; offset in 4-byte words.")- , ("interlockedExchangeAddr#","The atomic exchange operation. Atomically exchanges the value at the first address\n with the Addr# given as second argument. Implies a read barrier.")- , ("interlockedExchangeInt#","The atomic exchange operation. Atomically exchanges the value at the address\n with the given value. Returns the old value. Implies a read barrier.")+ , ("atomicExchangeAddr#","The atomic exchange operation. Atomically exchanges the value at the first address\n with the Addr# given as second argument. Implies a read barrier.")+ , ("atomicExchangeInt#","The atomic exchange operation. Atomically exchanges the value at the address\n with the given value. Returns the old value. Implies a read barrier.")+ , ("atomicCasInt#"," Compare and swap on a word-sized memory location.\n\n Use as atomicCasInt# location expected desired\n\n This version always returns the old value read. This follows the normal protocol for CAS operations (and matches the underlying instruction on most architectures).\n\n Implies a full memory barrier.")+ , ("atomicCasAddr#"," Compare and swap on a word-sized memory location.\n\n Use as atomicCasAddr# location expected desired\n\n This version always returns the old value read. This follows the normal protocol for CAS operations (and matches the underlying instruction on most architectures).\n\n Implies a full memory barrier.") , ("MutVar#","A @MutVar\\#@ behaves like a single-element mutable array.") , ("newMutVar#","Create @MutVar\\#@ with specified initial value in specified state thread.") , ("readMutVar#","Read contents of @MutVar\\#@. Result is not yet evaluated.")
ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl view
@@ -47,6 +47,8 @@ primOpHasSideEffects ReadByteArrayOp_Word64 = True primOpHasSideEffects ReadByteArrayOp_Word8AsChar = True primOpHasSideEffects ReadByteArrayOp_Word8AsWideChar = True+primOpHasSideEffects ReadByteArrayOp_Word8AsInt = True+primOpHasSideEffects ReadByteArrayOp_Word8AsWord = True primOpHasSideEffects ReadByteArrayOp_Word8AsAddr = True primOpHasSideEffects ReadByteArrayOp_Word8AsFloat = True primOpHasSideEffects ReadByteArrayOp_Word8AsDouble = True@@ -54,11 +56,9 @@ primOpHasSideEffects ReadByteArrayOp_Word8AsInt16 = True primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsInt = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord16 = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord32 = True primOpHasSideEffects ReadByteArrayOp_Word8AsWord64 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsWord = True primOpHasSideEffects WriteByteArrayOp_Char = True primOpHasSideEffects WriteByteArrayOp_WideChar = True primOpHasSideEffects WriteByteArrayOp_Int = True@@ -77,6 +77,8 @@ primOpHasSideEffects WriteByteArrayOp_Word64 = True primOpHasSideEffects WriteByteArrayOp_Word8AsChar = True primOpHasSideEffects WriteByteArrayOp_Word8AsWideChar = True+primOpHasSideEffects WriteByteArrayOp_Word8AsInt = True+primOpHasSideEffects WriteByteArrayOp_Word8AsWord = True primOpHasSideEffects WriteByteArrayOp_Word8AsAddr = True primOpHasSideEffects WriteByteArrayOp_Word8AsFloat = True primOpHasSideEffects WriteByteArrayOp_Word8AsDouble = True@@ -84,11 +86,9 @@ primOpHasSideEffects WriteByteArrayOp_Word8AsInt16 = True primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsInt = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord16 = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord32 = True primOpHasSideEffects WriteByteArrayOp_Word8AsWord64 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsWord = True primOpHasSideEffects CopyByteArrayOp = True primOpHasSideEffects CopyMutableByteArrayOp = True primOpHasSideEffects CopyByteArrayToAddrOp = True@@ -150,6 +150,8 @@ primOpHasSideEffects WriteOffAddrOp_Word64 = True primOpHasSideEffects InterlockedExchange_Addr = True primOpHasSideEffects InterlockedExchange_Int = True+primOpHasSideEffects AtomicCompareExchange_Int = True+primOpHasSideEffects AtomicCompareExchange_Addr = True primOpHasSideEffects NewMutVarOp = True primOpHasSideEffects ReadMutVarOp = True primOpHasSideEffects WriteMutVarOp = True
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -291,6 +291,8 @@ , IndexByteArrayOp_Word64 , IndexByteArrayOp_Word8AsChar , IndexByteArrayOp_Word8AsWideChar+ , IndexByteArrayOp_Word8AsInt+ , IndexByteArrayOp_Word8AsWord , IndexByteArrayOp_Word8AsAddr , IndexByteArrayOp_Word8AsFloat , IndexByteArrayOp_Word8AsDouble@@ -298,11 +300,9 @@ , IndexByteArrayOp_Word8AsInt16 , IndexByteArrayOp_Word8AsInt32 , IndexByteArrayOp_Word8AsInt64- , IndexByteArrayOp_Word8AsInt , IndexByteArrayOp_Word8AsWord16 , IndexByteArrayOp_Word8AsWord32 , IndexByteArrayOp_Word8AsWord64- , IndexByteArrayOp_Word8AsWord , ReadByteArrayOp_Char , ReadByteArrayOp_WideChar , ReadByteArrayOp_Int@@ -321,6 +321,8 @@ , ReadByteArrayOp_Word64 , ReadByteArrayOp_Word8AsChar , ReadByteArrayOp_Word8AsWideChar+ , ReadByteArrayOp_Word8AsInt+ , ReadByteArrayOp_Word8AsWord , ReadByteArrayOp_Word8AsAddr , ReadByteArrayOp_Word8AsFloat , ReadByteArrayOp_Word8AsDouble@@ -328,11 +330,9 @@ , ReadByteArrayOp_Word8AsInt16 , ReadByteArrayOp_Word8AsInt32 , ReadByteArrayOp_Word8AsInt64- , ReadByteArrayOp_Word8AsInt , ReadByteArrayOp_Word8AsWord16 , ReadByteArrayOp_Word8AsWord32 , ReadByteArrayOp_Word8AsWord64- , ReadByteArrayOp_Word8AsWord , WriteByteArrayOp_Char , WriteByteArrayOp_WideChar , WriteByteArrayOp_Int@@ -351,6 +351,8 @@ , WriteByteArrayOp_Word64 , WriteByteArrayOp_Word8AsChar , WriteByteArrayOp_Word8AsWideChar+ , WriteByteArrayOp_Word8AsInt+ , WriteByteArrayOp_Word8AsWord , WriteByteArrayOp_Word8AsAddr , WriteByteArrayOp_Word8AsFloat , WriteByteArrayOp_Word8AsDouble@@ -358,11 +360,9 @@ , WriteByteArrayOp_Word8AsInt16 , WriteByteArrayOp_Word8AsInt32 , WriteByteArrayOp_Word8AsInt64- , WriteByteArrayOp_Word8AsInt , WriteByteArrayOp_Word8AsWord16 , WriteByteArrayOp_Word8AsWord32 , WriteByteArrayOp_Word8AsWord64- , WriteByteArrayOp_Word8AsWord , CompareByteArraysOp , CopyByteArrayOp , CopyMutableByteArrayOp@@ -457,6 +457,8 @@ , WriteOffAddrOp_Word64 , InterlockedExchange_Addr , InterlockedExchange_Int+ , AtomicCompareExchange_Int+ , AtomicCompareExchange_Addr , NewMutVarOp , ReadMutVarOp , WriteMutVarOp
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -291,6 +291,8 @@ primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy) primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#") [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8ArrayAsAddr#") [] [byteArrayPrimTy, intPrimTy] (addrPrimTy) primOpInfo IndexByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8ArrayAsFloat#") [] [byteArrayPrimTy, intPrimTy] (floatPrimTy) primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#") [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)@@ -298,11 +300,9 @@ primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy)-primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#") [] [byteArrayPrimTy, intPrimTy] (intPrimTy) primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)-primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#") [] [byteArrayPrimTy, intPrimTy] (wordPrimTy) primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))@@ -321,6 +321,8 @@ primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8ArrayAsAddr#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo ReadByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8ArrayAsFloat#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy])) primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))@@ -328,11 +330,9 @@ primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))-primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -351,6 +351,8 @@ primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8ArrayAsAddr#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8ArrayAsFloat#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -358,11 +360,9 @@ primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#") [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy) primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#") [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#") [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -455,8 +455,10 @@ primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#") [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)-primOpInfo InterlockedExchange_Addr = mkGenPrimOp (fsLit "interlockedExchangeAddr#") [deltaTyVar] [addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))-primOpInfo InterlockedExchange_Int = mkGenPrimOp (fsLit "interlockedExchangeInt#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo InterlockedExchange_Addr = mkGenPrimOp (fsLit "atomicExchangeAddr#") [deltaTyVar] [addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo InterlockedExchange_Int = mkGenPrimOp (fsLit "atomicExchangeInt#") [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo AtomicCompareExchange_Int = mkGenPrimOp (fsLit "atomicCasInt#") [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo AtomicCompareExchange_Addr = mkGenPrimOp (fsLit "atomicCasAddr#") [deltaTyVar] [addrPrimTy, addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy])) primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#") [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -1,1213 +1,1215 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1210-primOpTag :: PrimOp -> Int-primOpTag CharGtOp = 1-primOpTag CharGeOp = 2-primOpTag CharEqOp = 3-primOpTag CharNeOp = 4-primOpTag CharLtOp = 5-primOpTag CharLeOp = 6-primOpTag OrdOp = 7-primOpTag Int8Extend = 8-primOpTag Int8Narrow = 9-primOpTag Int8NegOp = 10-primOpTag Int8AddOp = 11-primOpTag Int8SubOp = 12-primOpTag Int8MulOp = 13-primOpTag Int8QuotOp = 14-primOpTag Int8RemOp = 15-primOpTag Int8QuotRemOp = 16-primOpTag Int8EqOp = 17-primOpTag Int8GeOp = 18-primOpTag Int8GtOp = 19-primOpTag Int8LeOp = 20-primOpTag Int8LtOp = 21-primOpTag Int8NeOp = 22-primOpTag Word8Extend = 23-primOpTag Word8Narrow = 24-primOpTag Word8NotOp = 25-primOpTag Word8AddOp = 26-primOpTag Word8SubOp = 27-primOpTag Word8MulOp = 28-primOpTag Word8QuotOp = 29-primOpTag Word8RemOp = 30-primOpTag Word8QuotRemOp = 31-primOpTag Word8EqOp = 32-primOpTag Word8GeOp = 33-primOpTag Word8GtOp = 34-primOpTag Word8LeOp = 35-primOpTag Word8LtOp = 36-primOpTag Word8NeOp = 37-primOpTag Int16Extend = 38-primOpTag Int16Narrow = 39-primOpTag Int16NegOp = 40-primOpTag Int16AddOp = 41-primOpTag Int16SubOp = 42-primOpTag Int16MulOp = 43-primOpTag Int16QuotOp = 44-primOpTag Int16RemOp = 45-primOpTag Int16QuotRemOp = 46-primOpTag Int16EqOp = 47-primOpTag Int16GeOp = 48-primOpTag Int16GtOp = 49-primOpTag Int16LeOp = 50-primOpTag Int16LtOp = 51-primOpTag Int16NeOp = 52-primOpTag Word16Extend = 53-primOpTag Word16Narrow = 54-primOpTag Word16NotOp = 55-primOpTag Word16AddOp = 56-primOpTag Word16SubOp = 57-primOpTag Word16MulOp = 58-primOpTag Word16QuotOp = 59-primOpTag Word16RemOp = 60-primOpTag Word16QuotRemOp = 61-primOpTag Word16EqOp = 62-primOpTag Word16GeOp = 63-primOpTag Word16GtOp = 64-primOpTag Word16LeOp = 65-primOpTag Word16LtOp = 66-primOpTag Word16NeOp = 67-primOpTag IntAddOp = 68-primOpTag IntSubOp = 69-primOpTag IntMulOp = 70-primOpTag IntMul2Op = 71-primOpTag IntMulMayOfloOp = 72-primOpTag IntQuotOp = 73-primOpTag IntRemOp = 74-primOpTag IntQuotRemOp = 75-primOpTag AndIOp = 76-primOpTag OrIOp = 77-primOpTag XorIOp = 78-primOpTag NotIOp = 79-primOpTag IntNegOp = 80-primOpTag IntAddCOp = 81-primOpTag IntSubCOp = 82-primOpTag IntGtOp = 83-primOpTag IntGeOp = 84-primOpTag IntEqOp = 85-primOpTag IntNeOp = 86-primOpTag IntLtOp = 87-primOpTag IntLeOp = 88-primOpTag ChrOp = 89-primOpTag IntToWordOp = 90-primOpTag IntToFloatOp = 91-primOpTag IntToDoubleOp = 92-primOpTag WordToFloatOp = 93-primOpTag WordToDoubleOp = 94-primOpTag ISllOp = 95-primOpTag ISraOp = 96-primOpTag ISrlOp = 97-primOpTag WordAddOp = 98-primOpTag WordAddCOp = 99-primOpTag WordSubCOp = 100-primOpTag WordAdd2Op = 101-primOpTag WordSubOp = 102-primOpTag WordMulOp = 103-primOpTag WordMul2Op = 104-primOpTag WordQuotOp = 105-primOpTag WordRemOp = 106-primOpTag WordQuotRemOp = 107-primOpTag WordQuotRem2Op = 108-primOpTag AndOp = 109-primOpTag OrOp = 110-primOpTag XorOp = 111-primOpTag NotOp = 112-primOpTag SllOp = 113-primOpTag SrlOp = 114-primOpTag WordToIntOp = 115-primOpTag WordGtOp = 116-primOpTag WordGeOp = 117-primOpTag WordEqOp = 118-primOpTag WordNeOp = 119-primOpTag WordLtOp = 120-primOpTag WordLeOp = 121-primOpTag PopCnt8Op = 122-primOpTag PopCnt16Op = 123-primOpTag PopCnt32Op = 124-primOpTag PopCnt64Op = 125-primOpTag PopCntOp = 126-primOpTag Pdep8Op = 127-primOpTag Pdep16Op = 128-primOpTag Pdep32Op = 129-primOpTag Pdep64Op = 130-primOpTag PdepOp = 131-primOpTag Pext8Op = 132-primOpTag Pext16Op = 133-primOpTag Pext32Op = 134-primOpTag Pext64Op = 135-primOpTag PextOp = 136-primOpTag Clz8Op = 137-primOpTag Clz16Op = 138-primOpTag Clz32Op = 139-primOpTag Clz64Op = 140-primOpTag ClzOp = 141-primOpTag Ctz8Op = 142-primOpTag Ctz16Op = 143-primOpTag Ctz32Op = 144-primOpTag Ctz64Op = 145-primOpTag CtzOp = 146-primOpTag BSwap16Op = 147-primOpTag BSwap32Op = 148-primOpTag BSwap64Op = 149-primOpTag BSwapOp = 150-primOpTag BRev8Op = 151-primOpTag BRev16Op = 152-primOpTag BRev32Op = 153-primOpTag BRev64Op = 154-primOpTag BRevOp = 155-primOpTag Narrow8IntOp = 156-primOpTag Narrow16IntOp = 157-primOpTag Narrow32IntOp = 158-primOpTag Narrow8WordOp = 159-primOpTag Narrow16WordOp = 160-primOpTag Narrow32WordOp = 161-primOpTag DoubleGtOp = 162-primOpTag DoubleGeOp = 163-primOpTag DoubleEqOp = 164-primOpTag DoubleNeOp = 165-primOpTag DoubleLtOp = 166-primOpTag DoubleLeOp = 167-primOpTag DoubleAddOp = 168-primOpTag DoubleSubOp = 169-primOpTag DoubleMulOp = 170-primOpTag DoubleDivOp = 171-primOpTag DoubleNegOp = 172-primOpTag DoubleFabsOp = 173-primOpTag DoubleToIntOp = 174-primOpTag DoubleToFloatOp = 175-primOpTag DoubleExpOp = 176-primOpTag DoubleExpM1Op = 177-primOpTag DoubleLogOp = 178-primOpTag DoubleLog1POp = 179-primOpTag DoubleSqrtOp = 180-primOpTag DoubleSinOp = 181-primOpTag DoubleCosOp = 182-primOpTag DoubleTanOp = 183-primOpTag DoubleAsinOp = 184-primOpTag DoubleAcosOp = 185-primOpTag DoubleAtanOp = 186-primOpTag DoubleSinhOp = 187-primOpTag DoubleCoshOp = 188-primOpTag DoubleTanhOp = 189-primOpTag DoubleAsinhOp = 190-primOpTag DoubleAcoshOp = 191-primOpTag DoubleAtanhOp = 192-primOpTag DoublePowerOp = 193-primOpTag DoubleDecode_2IntOp = 194-primOpTag DoubleDecode_Int64Op = 195-primOpTag FloatGtOp = 196-primOpTag FloatGeOp = 197-primOpTag FloatEqOp = 198-primOpTag FloatNeOp = 199-primOpTag FloatLtOp = 200-primOpTag FloatLeOp = 201-primOpTag FloatAddOp = 202-primOpTag FloatSubOp = 203-primOpTag FloatMulOp = 204-primOpTag FloatDivOp = 205-primOpTag FloatNegOp = 206-primOpTag FloatFabsOp = 207-primOpTag FloatToIntOp = 208-primOpTag FloatExpOp = 209-primOpTag FloatExpM1Op = 210-primOpTag FloatLogOp = 211-primOpTag FloatLog1POp = 212-primOpTag FloatSqrtOp = 213-primOpTag FloatSinOp = 214-primOpTag FloatCosOp = 215-primOpTag FloatTanOp = 216-primOpTag FloatAsinOp = 217-primOpTag FloatAcosOp = 218-primOpTag FloatAtanOp = 219-primOpTag FloatSinhOp = 220-primOpTag FloatCoshOp = 221-primOpTag FloatTanhOp = 222-primOpTag FloatAsinhOp = 223-primOpTag FloatAcoshOp = 224-primOpTag FloatAtanhOp = 225-primOpTag FloatPowerOp = 226-primOpTag FloatToDoubleOp = 227-primOpTag FloatDecode_IntOp = 228-primOpTag NewArrayOp = 229-primOpTag SameMutableArrayOp = 230-primOpTag ReadArrayOp = 231-primOpTag WriteArrayOp = 232-primOpTag SizeofArrayOp = 233-primOpTag SizeofMutableArrayOp = 234-primOpTag IndexArrayOp = 235-primOpTag UnsafeFreezeArrayOp = 236-primOpTag UnsafeThawArrayOp = 237-primOpTag CopyArrayOp = 238-primOpTag CopyMutableArrayOp = 239-primOpTag CloneArrayOp = 240-primOpTag CloneMutableArrayOp = 241-primOpTag FreezeArrayOp = 242-primOpTag ThawArrayOp = 243-primOpTag CasArrayOp = 244-primOpTag NewSmallArrayOp = 245-primOpTag SameSmallMutableArrayOp = 246-primOpTag ShrinkSmallMutableArrayOp_Char = 247-primOpTag ReadSmallArrayOp = 248-primOpTag WriteSmallArrayOp = 249-primOpTag SizeofSmallArrayOp = 250-primOpTag SizeofSmallMutableArrayOp = 251-primOpTag GetSizeofSmallMutableArrayOp = 252-primOpTag IndexSmallArrayOp = 253-primOpTag UnsafeFreezeSmallArrayOp = 254-primOpTag UnsafeThawSmallArrayOp = 255-primOpTag CopySmallArrayOp = 256-primOpTag CopySmallMutableArrayOp = 257-primOpTag CloneSmallArrayOp = 258-primOpTag CloneSmallMutableArrayOp = 259-primOpTag FreezeSmallArrayOp = 260-primOpTag ThawSmallArrayOp = 261-primOpTag CasSmallArrayOp = 262-primOpTag NewByteArrayOp_Char = 263-primOpTag NewPinnedByteArrayOp_Char = 264-primOpTag NewAlignedPinnedByteArrayOp_Char = 265-primOpTag MutableByteArrayIsPinnedOp = 266-primOpTag ByteArrayIsPinnedOp = 267-primOpTag ByteArrayContents_Char = 268-primOpTag SameMutableByteArrayOp = 269-primOpTag ShrinkMutableByteArrayOp_Char = 270-primOpTag ResizeMutableByteArrayOp_Char = 271-primOpTag UnsafeFreezeByteArrayOp = 272-primOpTag SizeofByteArrayOp = 273-primOpTag SizeofMutableByteArrayOp = 274-primOpTag GetSizeofMutableByteArrayOp = 275-primOpTag IndexByteArrayOp_Char = 276-primOpTag IndexByteArrayOp_WideChar = 277-primOpTag IndexByteArrayOp_Int = 278-primOpTag IndexByteArrayOp_Word = 279-primOpTag IndexByteArrayOp_Addr = 280-primOpTag IndexByteArrayOp_Float = 281-primOpTag IndexByteArrayOp_Double = 282-primOpTag IndexByteArrayOp_StablePtr = 283-primOpTag IndexByteArrayOp_Int8 = 284-primOpTag IndexByteArrayOp_Int16 = 285-primOpTag IndexByteArrayOp_Int32 = 286-primOpTag IndexByteArrayOp_Int64 = 287-primOpTag IndexByteArrayOp_Word8 = 288-primOpTag IndexByteArrayOp_Word16 = 289-primOpTag IndexByteArrayOp_Word32 = 290-primOpTag IndexByteArrayOp_Word64 = 291-primOpTag IndexByteArrayOp_Word8AsChar = 292-primOpTag IndexByteArrayOp_Word8AsWideChar = 293-primOpTag IndexByteArrayOp_Word8AsAddr = 294-primOpTag IndexByteArrayOp_Word8AsFloat = 295-primOpTag IndexByteArrayOp_Word8AsDouble = 296-primOpTag IndexByteArrayOp_Word8AsStablePtr = 297-primOpTag IndexByteArrayOp_Word8AsInt16 = 298-primOpTag IndexByteArrayOp_Word8AsInt32 = 299-primOpTag IndexByteArrayOp_Word8AsInt64 = 300-primOpTag IndexByteArrayOp_Word8AsInt = 301-primOpTag IndexByteArrayOp_Word8AsWord16 = 302-primOpTag IndexByteArrayOp_Word8AsWord32 = 303-primOpTag IndexByteArrayOp_Word8AsWord64 = 304-primOpTag IndexByteArrayOp_Word8AsWord = 305-primOpTag ReadByteArrayOp_Char = 306-primOpTag ReadByteArrayOp_WideChar = 307-primOpTag ReadByteArrayOp_Int = 308-primOpTag ReadByteArrayOp_Word = 309-primOpTag ReadByteArrayOp_Addr = 310-primOpTag ReadByteArrayOp_Float = 311-primOpTag ReadByteArrayOp_Double = 312-primOpTag ReadByteArrayOp_StablePtr = 313-primOpTag ReadByteArrayOp_Int8 = 314-primOpTag ReadByteArrayOp_Int16 = 315-primOpTag ReadByteArrayOp_Int32 = 316-primOpTag ReadByteArrayOp_Int64 = 317-primOpTag ReadByteArrayOp_Word8 = 318-primOpTag ReadByteArrayOp_Word16 = 319-primOpTag ReadByteArrayOp_Word32 = 320-primOpTag ReadByteArrayOp_Word64 = 321-primOpTag ReadByteArrayOp_Word8AsChar = 322-primOpTag ReadByteArrayOp_Word8AsWideChar = 323-primOpTag ReadByteArrayOp_Word8AsAddr = 324-primOpTag ReadByteArrayOp_Word8AsFloat = 325-primOpTag ReadByteArrayOp_Word8AsDouble = 326-primOpTag ReadByteArrayOp_Word8AsStablePtr = 327-primOpTag ReadByteArrayOp_Word8AsInt16 = 328-primOpTag ReadByteArrayOp_Word8AsInt32 = 329-primOpTag ReadByteArrayOp_Word8AsInt64 = 330-primOpTag ReadByteArrayOp_Word8AsInt = 331-primOpTag ReadByteArrayOp_Word8AsWord16 = 332-primOpTag ReadByteArrayOp_Word8AsWord32 = 333-primOpTag ReadByteArrayOp_Word8AsWord64 = 334-primOpTag ReadByteArrayOp_Word8AsWord = 335-primOpTag WriteByteArrayOp_Char = 336-primOpTag WriteByteArrayOp_WideChar = 337-primOpTag WriteByteArrayOp_Int = 338-primOpTag WriteByteArrayOp_Word = 339-primOpTag WriteByteArrayOp_Addr = 340-primOpTag WriteByteArrayOp_Float = 341-primOpTag WriteByteArrayOp_Double = 342-primOpTag WriteByteArrayOp_StablePtr = 343-primOpTag WriteByteArrayOp_Int8 = 344-primOpTag WriteByteArrayOp_Int16 = 345-primOpTag WriteByteArrayOp_Int32 = 346-primOpTag WriteByteArrayOp_Int64 = 347-primOpTag WriteByteArrayOp_Word8 = 348-primOpTag WriteByteArrayOp_Word16 = 349-primOpTag WriteByteArrayOp_Word32 = 350-primOpTag WriteByteArrayOp_Word64 = 351-primOpTag WriteByteArrayOp_Word8AsChar = 352-primOpTag WriteByteArrayOp_Word8AsWideChar = 353-primOpTag WriteByteArrayOp_Word8AsAddr = 354-primOpTag WriteByteArrayOp_Word8AsFloat = 355-primOpTag WriteByteArrayOp_Word8AsDouble = 356-primOpTag WriteByteArrayOp_Word8AsStablePtr = 357-primOpTag WriteByteArrayOp_Word8AsInt16 = 358-primOpTag WriteByteArrayOp_Word8AsInt32 = 359-primOpTag WriteByteArrayOp_Word8AsInt64 = 360-primOpTag WriteByteArrayOp_Word8AsInt = 361-primOpTag WriteByteArrayOp_Word8AsWord16 = 362-primOpTag WriteByteArrayOp_Word8AsWord32 = 363-primOpTag WriteByteArrayOp_Word8AsWord64 = 364-primOpTag WriteByteArrayOp_Word8AsWord = 365-primOpTag CompareByteArraysOp = 366-primOpTag CopyByteArrayOp = 367-primOpTag CopyMutableByteArrayOp = 368-primOpTag CopyByteArrayToAddrOp = 369-primOpTag CopyMutableByteArrayToAddrOp = 370-primOpTag CopyAddrToByteArrayOp = 371-primOpTag SetByteArrayOp = 372-primOpTag AtomicReadByteArrayOp_Int = 373-primOpTag AtomicWriteByteArrayOp_Int = 374-primOpTag CasByteArrayOp_Int = 375-primOpTag FetchAddByteArrayOp_Int = 376-primOpTag FetchSubByteArrayOp_Int = 377-primOpTag FetchAndByteArrayOp_Int = 378-primOpTag FetchNandByteArrayOp_Int = 379-primOpTag FetchOrByteArrayOp_Int = 380-primOpTag FetchXorByteArrayOp_Int = 381-primOpTag NewArrayArrayOp = 382-primOpTag SameMutableArrayArrayOp = 383-primOpTag UnsafeFreezeArrayArrayOp = 384-primOpTag SizeofArrayArrayOp = 385-primOpTag SizeofMutableArrayArrayOp = 386-primOpTag IndexArrayArrayOp_ByteArray = 387-primOpTag IndexArrayArrayOp_ArrayArray = 388-primOpTag ReadArrayArrayOp_ByteArray = 389-primOpTag ReadArrayArrayOp_MutableByteArray = 390-primOpTag ReadArrayArrayOp_ArrayArray = 391-primOpTag ReadArrayArrayOp_MutableArrayArray = 392-primOpTag WriteArrayArrayOp_ByteArray = 393-primOpTag WriteArrayArrayOp_MutableByteArray = 394-primOpTag WriteArrayArrayOp_ArrayArray = 395-primOpTag WriteArrayArrayOp_MutableArrayArray = 396-primOpTag CopyArrayArrayOp = 397-primOpTag CopyMutableArrayArrayOp = 398-primOpTag AddrAddOp = 399-primOpTag AddrSubOp = 400-primOpTag AddrRemOp = 401-primOpTag AddrToIntOp = 402-primOpTag IntToAddrOp = 403-primOpTag AddrGtOp = 404-primOpTag AddrGeOp = 405-primOpTag AddrEqOp = 406-primOpTag AddrNeOp = 407-primOpTag AddrLtOp = 408-primOpTag AddrLeOp = 409-primOpTag IndexOffAddrOp_Char = 410-primOpTag IndexOffAddrOp_WideChar = 411-primOpTag IndexOffAddrOp_Int = 412-primOpTag IndexOffAddrOp_Word = 413-primOpTag IndexOffAddrOp_Addr = 414-primOpTag IndexOffAddrOp_Float = 415-primOpTag IndexOffAddrOp_Double = 416-primOpTag IndexOffAddrOp_StablePtr = 417-primOpTag IndexOffAddrOp_Int8 = 418-primOpTag IndexOffAddrOp_Int16 = 419-primOpTag IndexOffAddrOp_Int32 = 420-primOpTag IndexOffAddrOp_Int64 = 421-primOpTag IndexOffAddrOp_Word8 = 422-primOpTag IndexOffAddrOp_Word16 = 423-primOpTag IndexOffAddrOp_Word32 = 424-primOpTag IndexOffAddrOp_Word64 = 425-primOpTag ReadOffAddrOp_Char = 426-primOpTag ReadOffAddrOp_WideChar = 427-primOpTag ReadOffAddrOp_Int = 428-primOpTag ReadOffAddrOp_Word = 429-primOpTag ReadOffAddrOp_Addr = 430-primOpTag ReadOffAddrOp_Float = 431-primOpTag ReadOffAddrOp_Double = 432-primOpTag ReadOffAddrOp_StablePtr = 433-primOpTag ReadOffAddrOp_Int8 = 434-primOpTag ReadOffAddrOp_Int16 = 435-primOpTag ReadOffAddrOp_Int32 = 436-primOpTag ReadOffAddrOp_Int64 = 437-primOpTag ReadOffAddrOp_Word8 = 438-primOpTag ReadOffAddrOp_Word16 = 439-primOpTag ReadOffAddrOp_Word32 = 440-primOpTag ReadOffAddrOp_Word64 = 441-primOpTag WriteOffAddrOp_Char = 442-primOpTag WriteOffAddrOp_WideChar = 443-primOpTag WriteOffAddrOp_Int = 444-primOpTag WriteOffAddrOp_Word = 445-primOpTag WriteOffAddrOp_Addr = 446-primOpTag WriteOffAddrOp_Float = 447-primOpTag WriteOffAddrOp_Double = 448-primOpTag WriteOffAddrOp_StablePtr = 449-primOpTag WriteOffAddrOp_Int8 = 450-primOpTag WriteOffAddrOp_Int16 = 451-primOpTag WriteOffAddrOp_Int32 = 452-primOpTag WriteOffAddrOp_Int64 = 453-primOpTag WriteOffAddrOp_Word8 = 454-primOpTag WriteOffAddrOp_Word16 = 455-primOpTag WriteOffAddrOp_Word32 = 456-primOpTag WriteOffAddrOp_Word64 = 457-primOpTag InterlockedExchange_Addr = 458-primOpTag InterlockedExchange_Int = 459-primOpTag NewMutVarOp = 460-primOpTag ReadMutVarOp = 461-primOpTag WriteMutVarOp = 462-primOpTag SameMutVarOp = 463-primOpTag AtomicModifyMutVar2Op = 464-primOpTag AtomicModifyMutVar_Op = 465-primOpTag CasMutVarOp = 466-primOpTag CatchOp = 467-primOpTag RaiseOp = 468-primOpTag RaiseIOOp = 469-primOpTag MaskAsyncExceptionsOp = 470-primOpTag MaskUninterruptibleOp = 471-primOpTag UnmaskAsyncExceptionsOp = 472-primOpTag MaskStatus = 473-primOpTag AtomicallyOp = 474-primOpTag RetryOp = 475-primOpTag CatchRetryOp = 476-primOpTag CatchSTMOp = 477-primOpTag NewTVarOp = 478-primOpTag ReadTVarOp = 479-primOpTag ReadTVarIOOp = 480-primOpTag WriteTVarOp = 481-primOpTag SameTVarOp = 482-primOpTag NewMVarOp = 483-primOpTag TakeMVarOp = 484-primOpTag TryTakeMVarOp = 485-primOpTag PutMVarOp = 486-primOpTag TryPutMVarOp = 487-primOpTag ReadMVarOp = 488-primOpTag TryReadMVarOp = 489-primOpTag SameMVarOp = 490-primOpTag IsEmptyMVarOp = 491-primOpTag NewIOPortrOp = 492-primOpTag ReadIOPortOp = 493-primOpTag WriteIOPortOp = 494-primOpTag SameIOPortOp = 495-primOpTag DelayOp = 496-primOpTag WaitReadOp = 497-primOpTag WaitWriteOp = 498-primOpTag ForkOp = 499-primOpTag ForkOnOp = 500-primOpTag KillThreadOp = 501-primOpTag YieldOp = 502-primOpTag MyThreadIdOp = 503-primOpTag LabelThreadOp = 504-primOpTag IsCurrentThreadBoundOp = 505-primOpTag NoDuplicateOp = 506-primOpTag ThreadStatusOp = 507-primOpTag MkWeakOp = 508-primOpTag MkWeakNoFinalizerOp = 509-primOpTag AddCFinalizerToWeakOp = 510-primOpTag DeRefWeakOp = 511-primOpTag FinalizeWeakOp = 512-primOpTag TouchOp = 513-primOpTag MakeStablePtrOp = 514-primOpTag DeRefStablePtrOp = 515-primOpTag EqStablePtrOp = 516-primOpTag MakeStableNameOp = 517-primOpTag EqStableNameOp = 518-primOpTag StableNameToIntOp = 519-primOpTag CompactNewOp = 520-primOpTag CompactResizeOp = 521-primOpTag CompactContainsOp = 522-primOpTag CompactContainsAnyOp = 523-primOpTag CompactGetFirstBlockOp = 524-primOpTag CompactGetNextBlockOp = 525-primOpTag CompactAllocateBlockOp = 526-primOpTag CompactFixupPointersOp = 527-primOpTag CompactAdd = 528-primOpTag CompactAddWithSharing = 529-primOpTag CompactSize = 530-primOpTag ReallyUnsafePtrEqualityOp = 531-primOpTag ParOp = 532-primOpTag SparkOp = 533-primOpTag SeqOp = 534-primOpTag GetSparkOp = 535-primOpTag NumSparks = 536-primOpTag DataToTagOp = 537-primOpTag TagToEnumOp = 538-primOpTag AddrToAnyOp = 539-primOpTag AnyToAddrOp = 540-primOpTag MkApUpd0_Op = 541-primOpTag NewBCOOp = 542-primOpTag UnpackClosureOp = 543-primOpTag ClosureSizeOp = 544-primOpTag GetApStackValOp = 545-primOpTag GetCCSOfOp = 546-primOpTag GetCurrentCCSOp = 547-primOpTag ClearCCSOp = 548-primOpTag TraceEventOp = 549-primOpTag TraceEventBinaryOp = 550-primOpTag TraceMarkerOp = 551-primOpTag SetThreadAllocationCounter = 552-primOpTag (VecBroadcastOp IntVec 16 W8) = 553-primOpTag (VecBroadcastOp IntVec 8 W16) = 554-primOpTag (VecBroadcastOp IntVec 4 W32) = 555-primOpTag (VecBroadcastOp IntVec 2 W64) = 556-primOpTag (VecBroadcastOp IntVec 32 W8) = 557-primOpTag (VecBroadcastOp IntVec 16 W16) = 558-primOpTag (VecBroadcastOp IntVec 8 W32) = 559-primOpTag (VecBroadcastOp IntVec 4 W64) = 560-primOpTag (VecBroadcastOp IntVec 64 W8) = 561-primOpTag (VecBroadcastOp IntVec 32 W16) = 562-primOpTag (VecBroadcastOp IntVec 16 W32) = 563-primOpTag (VecBroadcastOp IntVec 8 W64) = 564-primOpTag (VecBroadcastOp WordVec 16 W8) = 565-primOpTag (VecBroadcastOp WordVec 8 W16) = 566-primOpTag (VecBroadcastOp WordVec 4 W32) = 567-primOpTag (VecBroadcastOp WordVec 2 W64) = 568-primOpTag (VecBroadcastOp WordVec 32 W8) = 569-primOpTag (VecBroadcastOp WordVec 16 W16) = 570-primOpTag (VecBroadcastOp WordVec 8 W32) = 571-primOpTag (VecBroadcastOp WordVec 4 W64) = 572-primOpTag (VecBroadcastOp WordVec 64 W8) = 573-primOpTag (VecBroadcastOp WordVec 32 W16) = 574-primOpTag (VecBroadcastOp WordVec 16 W32) = 575-primOpTag (VecBroadcastOp WordVec 8 W64) = 576-primOpTag (VecBroadcastOp FloatVec 4 W32) = 577-primOpTag (VecBroadcastOp FloatVec 2 W64) = 578-primOpTag (VecBroadcastOp FloatVec 8 W32) = 579-primOpTag (VecBroadcastOp FloatVec 4 W64) = 580-primOpTag (VecBroadcastOp FloatVec 16 W32) = 581-primOpTag (VecBroadcastOp FloatVec 8 W64) = 582-primOpTag (VecPackOp IntVec 16 W8) = 583-primOpTag (VecPackOp IntVec 8 W16) = 584-primOpTag (VecPackOp IntVec 4 W32) = 585-primOpTag (VecPackOp IntVec 2 W64) = 586-primOpTag (VecPackOp IntVec 32 W8) = 587-primOpTag (VecPackOp IntVec 16 W16) = 588-primOpTag (VecPackOp IntVec 8 W32) = 589-primOpTag (VecPackOp IntVec 4 W64) = 590-primOpTag (VecPackOp IntVec 64 W8) = 591-primOpTag (VecPackOp IntVec 32 W16) = 592-primOpTag (VecPackOp IntVec 16 W32) = 593-primOpTag (VecPackOp IntVec 8 W64) = 594-primOpTag (VecPackOp WordVec 16 W8) = 595-primOpTag (VecPackOp WordVec 8 W16) = 596-primOpTag (VecPackOp WordVec 4 W32) = 597-primOpTag (VecPackOp WordVec 2 W64) = 598-primOpTag (VecPackOp WordVec 32 W8) = 599-primOpTag (VecPackOp WordVec 16 W16) = 600-primOpTag (VecPackOp WordVec 8 W32) = 601-primOpTag (VecPackOp WordVec 4 W64) = 602-primOpTag (VecPackOp WordVec 64 W8) = 603-primOpTag (VecPackOp WordVec 32 W16) = 604-primOpTag (VecPackOp WordVec 16 W32) = 605-primOpTag (VecPackOp WordVec 8 W64) = 606-primOpTag (VecPackOp FloatVec 4 W32) = 607-primOpTag (VecPackOp FloatVec 2 W64) = 608-primOpTag (VecPackOp FloatVec 8 W32) = 609-primOpTag (VecPackOp FloatVec 4 W64) = 610-primOpTag (VecPackOp FloatVec 16 W32) = 611-primOpTag (VecPackOp FloatVec 8 W64) = 612-primOpTag (VecUnpackOp IntVec 16 W8) = 613-primOpTag (VecUnpackOp IntVec 8 W16) = 614-primOpTag (VecUnpackOp IntVec 4 W32) = 615-primOpTag (VecUnpackOp IntVec 2 W64) = 616-primOpTag (VecUnpackOp IntVec 32 W8) = 617-primOpTag (VecUnpackOp IntVec 16 W16) = 618-primOpTag (VecUnpackOp IntVec 8 W32) = 619-primOpTag (VecUnpackOp IntVec 4 W64) = 620-primOpTag (VecUnpackOp IntVec 64 W8) = 621-primOpTag (VecUnpackOp IntVec 32 W16) = 622-primOpTag (VecUnpackOp IntVec 16 W32) = 623-primOpTag (VecUnpackOp IntVec 8 W64) = 624-primOpTag (VecUnpackOp WordVec 16 W8) = 625-primOpTag (VecUnpackOp WordVec 8 W16) = 626-primOpTag (VecUnpackOp WordVec 4 W32) = 627-primOpTag (VecUnpackOp WordVec 2 W64) = 628-primOpTag (VecUnpackOp WordVec 32 W8) = 629-primOpTag (VecUnpackOp WordVec 16 W16) = 630-primOpTag (VecUnpackOp WordVec 8 W32) = 631-primOpTag (VecUnpackOp WordVec 4 W64) = 632-primOpTag (VecUnpackOp WordVec 64 W8) = 633-primOpTag (VecUnpackOp WordVec 32 W16) = 634-primOpTag (VecUnpackOp WordVec 16 W32) = 635-primOpTag (VecUnpackOp WordVec 8 W64) = 636-primOpTag (VecUnpackOp FloatVec 4 W32) = 637-primOpTag (VecUnpackOp FloatVec 2 W64) = 638-primOpTag (VecUnpackOp FloatVec 8 W32) = 639-primOpTag (VecUnpackOp FloatVec 4 W64) = 640-primOpTag (VecUnpackOp FloatVec 16 W32) = 641-primOpTag (VecUnpackOp FloatVec 8 W64) = 642-primOpTag (VecInsertOp IntVec 16 W8) = 643-primOpTag (VecInsertOp IntVec 8 W16) = 644-primOpTag (VecInsertOp IntVec 4 W32) = 645-primOpTag (VecInsertOp IntVec 2 W64) = 646-primOpTag (VecInsertOp IntVec 32 W8) = 647-primOpTag (VecInsertOp IntVec 16 W16) = 648-primOpTag (VecInsertOp IntVec 8 W32) = 649-primOpTag (VecInsertOp IntVec 4 W64) = 650-primOpTag (VecInsertOp IntVec 64 W8) = 651-primOpTag (VecInsertOp IntVec 32 W16) = 652-primOpTag (VecInsertOp IntVec 16 W32) = 653-primOpTag (VecInsertOp IntVec 8 W64) = 654-primOpTag (VecInsertOp WordVec 16 W8) = 655-primOpTag (VecInsertOp WordVec 8 W16) = 656-primOpTag (VecInsertOp WordVec 4 W32) = 657-primOpTag (VecInsertOp WordVec 2 W64) = 658-primOpTag (VecInsertOp WordVec 32 W8) = 659-primOpTag (VecInsertOp WordVec 16 W16) = 660-primOpTag (VecInsertOp WordVec 8 W32) = 661-primOpTag (VecInsertOp WordVec 4 W64) = 662-primOpTag (VecInsertOp WordVec 64 W8) = 663-primOpTag (VecInsertOp WordVec 32 W16) = 664-primOpTag (VecInsertOp WordVec 16 W32) = 665-primOpTag (VecInsertOp WordVec 8 W64) = 666-primOpTag (VecInsertOp FloatVec 4 W32) = 667-primOpTag (VecInsertOp FloatVec 2 W64) = 668-primOpTag (VecInsertOp FloatVec 8 W32) = 669-primOpTag (VecInsertOp FloatVec 4 W64) = 670-primOpTag (VecInsertOp FloatVec 16 W32) = 671-primOpTag (VecInsertOp FloatVec 8 W64) = 672-primOpTag (VecAddOp IntVec 16 W8) = 673-primOpTag (VecAddOp IntVec 8 W16) = 674-primOpTag (VecAddOp IntVec 4 W32) = 675-primOpTag (VecAddOp IntVec 2 W64) = 676-primOpTag (VecAddOp IntVec 32 W8) = 677-primOpTag (VecAddOp IntVec 16 W16) = 678-primOpTag (VecAddOp IntVec 8 W32) = 679-primOpTag (VecAddOp IntVec 4 W64) = 680-primOpTag (VecAddOp IntVec 64 W8) = 681-primOpTag (VecAddOp IntVec 32 W16) = 682-primOpTag (VecAddOp IntVec 16 W32) = 683-primOpTag (VecAddOp IntVec 8 W64) = 684-primOpTag (VecAddOp WordVec 16 W8) = 685-primOpTag (VecAddOp WordVec 8 W16) = 686-primOpTag (VecAddOp WordVec 4 W32) = 687-primOpTag (VecAddOp WordVec 2 W64) = 688-primOpTag (VecAddOp WordVec 32 W8) = 689-primOpTag (VecAddOp WordVec 16 W16) = 690-primOpTag (VecAddOp WordVec 8 W32) = 691-primOpTag (VecAddOp WordVec 4 W64) = 692-primOpTag (VecAddOp WordVec 64 W8) = 693-primOpTag (VecAddOp WordVec 32 W16) = 694-primOpTag (VecAddOp WordVec 16 W32) = 695-primOpTag (VecAddOp WordVec 8 W64) = 696-primOpTag (VecAddOp FloatVec 4 W32) = 697-primOpTag (VecAddOp FloatVec 2 W64) = 698-primOpTag (VecAddOp FloatVec 8 W32) = 699-primOpTag (VecAddOp FloatVec 4 W64) = 700-primOpTag (VecAddOp FloatVec 16 W32) = 701-primOpTag (VecAddOp FloatVec 8 W64) = 702-primOpTag (VecSubOp IntVec 16 W8) = 703-primOpTag (VecSubOp IntVec 8 W16) = 704-primOpTag (VecSubOp IntVec 4 W32) = 705-primOpTag (VecSubOp IntVec 2 W64) = 706-primOpTag (VecSubOp IntVec 32 W8) = 707-primOpTag (VecSubOp IntVec 16 W16) = 708-primOpTag (VecSubOp IntVec 8 W32) = 709-primOpTag (VecSubOp IntVec 4 W64) = 710-primOpTag (VecSubOp IntVec 64 W8) = 711-primOpTag (VecSubOp IntVec 32 W16) = 712-primOpTag (VecSubOp IntVec 16 W32) = 713-primOpTag (VecSubOp IntVec 8 W64) = 714-primOpTag (VecSubOp WordVec 16 W8) = 715-primOpTag (VecSubOp WordVec 8 W16) = 716-primOpTag (VecSubOp WordVec 4 W32) = 717-primOpTag (VecSubOp WordVec 2 W64) = 718-primOpTag (VecSubOp WordVec 32 W8) = 719-primOpTag (VecSubOp WordVec 16 W16) = 720-primOpTag (VecSubOp WordVec 8 W32) = 721-primOpTag (VecSubOp WordVec 4 W64) = 722-primOpTag (VecSubOp WordVec 64 W8) = 723-primOpTag (VecSubOp WordVec 32 W16) = 724-primOpTag (VecSubOp WordVec 16 W32) = 725-primOpTag (VecSubOp WordVec 8 W64) = 726-primOpTag (VecSubOp FloatVec 4 W32) = 727-primOpTag (VecSubOp FloatVec 2 W64) = 728-primOpTag (VecSubOp FloatVec 8 W32) = 729-primOpTag (VecSubOp FloatVec 4 W64) = 730-primOpTag (VecSubOp FloatVec 16 W32) = 731-primOpTag (VecSubOp FloatVec 8 W64) = 732-primOpTag (VecMulOp IntVec 16 W8) = 733-primOpTag (VecMulOp IntVec 8 W16) = 734-primOpTag (VecMulOp IntVec 4 W32) = 735-primOpTag (VecMulOp IntVec 2 W64) = 736-primOpTag (VecMulOp IntVec 32 W8) = 737-primOpTag (VecMulOp IntVec 16 W16) = 738-primOpTag (VecMulOp IntVec 8 W32) = 739-primOpTag (VecMulOp IntVec 4 W64) = 740-primOpTag (VecMulOp IntVec 64 W8) = 741-primOpTag (VecMulOp IntVec 32 W16) = 742-primOpTag (VecMulOp IntVec 16 W32) = 743-primOpTag (VecMulOp IntVec 8 W64) = 744-primOpTag (VecMulOp WordVec 16 W8) = 745-primOpTag (VecMulOp WordVec 8 W16) = 746-primOpTag (VecMulOp WordVec 4 W32) = 747-primOpTag (VecMulOp WordVec 2 W64) = 748-primOpTag (VecMulOp WordVec 32 W8) = 749-primOpTag (VecMulOp WordVec 16 W16) = 750-primOpTag (VecMulOp WordVec 8 W32) = 751-primOpTag (VecMulOp WordVec 4 W64) = 752-primOpTag (VecMulOp WordVec 64 W8) = 753-primOpTag (VecMulOp WordVec 32 W16) = 754-primOpTag (VecMulOp WordVec 16 W32) = 755-primOpTag (VecMulOp WordVec 8 W64) = 756-primOpTag (VecMulOp FloatVec 4 W32) = 757-primOpTag (VecMulOp FloatVec 2 W64) = 758-primOpTag (VecMulOp FloatVec 8 W32) = 759-primOpTag (VecMulOp FloatVec 4 W64) = 760-primOpTag (VecMulOp FloatVec 16 W32) = 761-primOpTag (VecMulOp FloatVec 8 W64) = 762-primOpTag (VecDivOp FloatVec 4 W32) = 763-primOpTag (VecDivOp FloatVec 2 W64) = 764-primOpTag (VecDivOp FloatVec 8 W32) = 765-primOpTag (VecDivOp FloatVec 4 W64) = 766-primOpTag (VecDivOp FloatVec 16 W32) = 767-primOpTag (VecDivOp FloatVec 8 W64) = 768-primOpTag (VecQuotOp IntVec 16 W8) = 769-primOpTag (VecQuotOp IntVec 8 W16) = 770-primOpTag (VecQuotOp IntVec 4 W32) = 771-primOpTag (VecQuotOp IntVec 2 W64) = 772-primOpTag (VecQuotOp IntVec 32 W8) = 773-primOpTag (VecQuotOp IntVec 16 W16) = 774-primOpTag (VecQuotOp IntVec 8 W32) = 775-primOpTag (VecQuotOp IntVec 4 W64) = 776-primOpTag (VecQuotOp IntVec 64 W8) = 777-primOpTag (VecQuotOp IntVec 32 W16) = 778-primOpTag (VecQuotOp IntVec 16 W32) = 779-primOpTag (VecQuotOp IntVec 8 W64) = 780-primOpTag (VecQuotOp WordVec 16 W8) = 781-primOpTag (VecQuotOp WordVec 8 W16) = 782-primOpTag (VecQuotOp WordVec 4 W32) = 783-primOpTag (VecQuotOp WordVec 2 W64) = 784-primOpTag (VecQuotOp WordVec 32 W8) = 785-primOpTag (VecQuotOp WordVec 16 W16) = 786-primOpTag (VecQuotOp WordVec 8 W32) = 787-primOpTag (VecQuotOp WordVec 4 W64) = 788-primOpTag (VecQuotOp WordVec 64 W8) = 789-primOpTag (VecQuotOp WordVec 32 W16) = 790-primOpTag (VecQuotOp WordVec 16 W32) = 791-primOpTag (VecQuotOp WordVec 8 W64) = 792-primOpTag (VecRemOp IntVec 16 W8) = 793-primOpTag (VecRemOp IntVec 8 W16) = 794-primOpTag (VecRemOp IntVec 4 W32) = 795-primOpTag (VecRemOp IntVec 2 W64) = 796-primOpTag (VecRemOp IntVec 32 W8) = 797-primOpTag (VecRemOp IntVec 16 W16) = 798-primOpTag (VecRemOp IntVec 8 W32) = 799-primOpTag (VecRemOp IntVec 4 W64) = 800-primOpTag (VecRemOp IntVec 64 W8) = 801-primOpTag (VecRemOp IntVec 32 W16) = 802-primOpTag (VecRemOp IntVec 16 W32) = 803-primOpTag (VecRemOp IntVec 8 W64) = 804-primOpTag (VecRemOp WordVec 16 W8) = 805-primOpTag (VecRemOp WordVec 8 W16) = 806-primOpTag (VecRemOp WordVec 4 W32) = 807-primOpTag (VecRemOp WordVec 2 W64) = 808-primOpTag (VecRemOp WordVec 32 W8) = 809-primOpTag (VecRemOp WordVec 16 W16) = 810-primOpTag (VecRemOp WordVec 8 W32) = 811-primOpTag (VecRemOp WordVec 4 W64) = 812-primOpTag (VecRemOp WordVec 64 W8) = 813-primOpTag (VecRemOp WordVec 32 W16) = 814-primOpTag (VecRemOp WordVec 16 W32) = 815-primOpTag (VecRemOp WordVec 8 W64) = 816-primOpTag (VecNegOp IntVec 16 W8) = 817-primOpTag (VecNegOp IntVec 8 W16) = 818-primOpTag (VecNegOp IntVec 4 W32) = 819-primOpTag (VecNegOp IntVec 2 W64) = 820-primOpTag (VecNegOp IntVec 32 W8) = 821-primOpTag (VecNegOp IntVec 16 W16) = 822-primOpTag (VecNegOp IntVec 8 W32) = 823-primOpTag (VecNegOp IntVec 4 W64) = 824-primOpTag (VecNegOp IntVec 64 W8) = 825-primOpTag (VecNegOp IntVec 32 W16) = 826-primOpTag (VecNegOp IntVec 16 W32) = 827-primOpTag (VecNegOp IntVec 8 W64) = 828-primOpTag (VecNegOp FloatVec 4 W32) = 829-primOpTag (VecNegOp FloatVec 2 W64) = 830-primOpTag (VecNegOp FloatVec 8 W32) = 831-primOpTag (VecNegOp FloatVec 4 W64) = 832-primOpTag (VecNegOp FloatVec 16 W32) = 833-primOpTag (VecNegOp FloatVec 8 W64) = 834-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 835-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 836-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 837-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 838-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 839-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 840-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 841-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 842-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 843-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 844-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 845-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 846-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 847-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 848-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 849-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 850-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 851-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 852-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 853-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 854-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 855-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 856-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 857-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 858-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 859-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 860-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 861-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 862-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 863-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 864-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 865-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 866-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 867-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 868-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 869-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 870-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 871-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 872-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 873-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 874-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 875-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 876-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 877-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 878-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 879-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 880-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 881-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 882-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 883-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 884-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 885-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 886-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 887-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 888-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 889-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 890-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 891-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 892-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 893-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 894-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 895-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 896-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 897-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 898-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 899-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 900-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 901-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 902-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 903-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 904-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 905-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 906-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 907-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 908-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 909-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 910-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 911-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 912-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 913-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 914-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 915-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 916-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 917-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 918-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 919-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 920-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 921-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 922-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 923-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 924-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 925-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 926-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 927-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 928-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 929-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 930-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 931-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 932-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 933-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 934-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 935-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 936-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 937-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 938-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 939-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 940-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 941-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 942-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 943-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 944-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 945-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 946-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 947-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 948-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 949-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 950-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 951-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 952-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 953-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 954-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 955-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 956-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 957-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 958-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 959-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 960-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 961-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 962-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 963-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 964-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 965-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 966-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 967-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 968-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 969-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 970-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 971-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 972-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 973-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 974-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 975-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 976-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 977-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 978-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 979-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 980-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 981-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 982-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 983-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 984-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 985-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 986-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 987-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 988-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 989-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 990-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 991-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 992-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 993-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 994-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 995-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 996-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 997-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 998-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 999-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1000-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1001-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1002-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1003-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1004-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1005-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1006-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1007-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1008-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1009-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1010-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1011-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1012-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1013-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1014-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1015-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1016-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1017-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1018-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1019-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1020-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1021-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1022-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1023-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1024-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1025-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1026-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1027-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1028-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1029-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1030-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1031-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1032-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1033-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1034-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1035-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1036-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1037-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1038-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1039-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1040-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1041-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1042-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1043-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1044-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1045-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1046-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1047-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1048-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1049-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1050-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1051-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1052-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1053-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1054-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1055-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1056-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1057-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1058-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1059-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1060-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1061-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1062-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1063-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1064-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1065-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1066-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1067-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1068-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1069-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1070-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1071-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1072-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1073-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1074-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1075-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1076-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1077-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1078-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1079-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1080-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1081-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1082-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1083-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1084-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1085-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1086-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1087-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1088-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1089-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1090-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1091-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1092-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1093-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1094-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1095-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1096-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1097-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1098-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1099-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1100-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1101-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1102-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1103-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1104-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1105-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1106-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1107-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1108-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1109-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1110-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1111-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1112-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1113-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1114-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1115-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1116-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1117-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1118-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1119-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1120-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1121-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1122-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1123-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1124-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1125-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1126-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1127-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1128-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1129-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1130-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1131-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1132-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1133-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1134-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1135-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1136-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1137-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1138-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1139-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1140-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1141-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1142-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1143-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1144-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1145-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1146-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1147-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1148-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1149-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1150-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1151-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1152-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1153-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1154-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1155-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1156-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1157-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1158-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1159-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1160-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1161-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1162-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1163-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1164-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1165-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1166-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1167-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1168-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1169-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1170-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1171-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1172-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1173-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1174-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1175-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1176-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1177-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1178-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1179-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1180-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1181-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1182-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1183-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1184-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1185-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1186-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1187-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1188-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1189-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1190-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1191-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1192-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1193-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1194-primOpTag PrefetchByteArrayOp3 = 1195-primOpTag PrefetchMutableByteArrayOp3 = 1196-primOpTag PrefetchAddrOp3 = 1197-primOpTag PrefetchValueOp3 = 1198-primOpTag PrefetchByteArrayOp2 = 1199-primOpTag PrefetchMutableByteArrayOp2 = 1200-primOpTag PrefetchAddrOp2 = 1201-primOpTag PrefetchValueOp2 = 1202-primOpTag PrefetchByteArrayOp1 = 1203-primOpTag PrefetchMutableByteArrayOp1 = 1204-primOpTag PrefetchAddrOp1 = 1205-primOpTag PrefetchValueOp1 = 1206-primOpTag PrefetchByteArrayOp0 = 1207-primOpTag PrefetchMutableByteArrayOp0 = 1208-primOpTag PrefetchAddrOp0 = 1209-primOpTag PrefetchValueOp0 = 1210+maxPrimOpTag = 1212+primOpTag :: PrimOp -> Int+primOpTag CharGtOp = 1+primOpTag CharGeOp = 2+primOpTag CharEqOp = 3+primOpTag CharNeOp = 4+primOpTag CharLtOp = 5+primOpTag CharLeOp = 6+primOpTag OrdOp = 7+primOpTag Int8Extend = 8+primOpTag Int8Narrow = 9+primOpTag Int8NegOp = 10+primOpTag Int8AddOp = 11+primOpTag Int8SubOp = 12+primOpTag Int8MulOp = 13+primOpTag Int8QuotOp = 14+primOpTag Int8RemOp = 15+primOpTag Int8QuotRemOp = 16+primOpTag Int8EqOp = 17+primOpTag Int8GeOp = 18+primOpTag Int8GtOp = 19+primOpTag Int8LeOp = 20+primOpTag Int8LtOp = 21+primOpTag Int8NeOp = 22+primOpTag Word8Extend = 23+primOpTag Word8Narrow = 24+primOpTag Word8NotOp = 25+primOpTag Word8AddOp = 26+primOpTag Word8SubOp = 27+primOpTag Word8MulOp = 28+primOpTag Word8QuotOp = 29+primOpTag Word8RemOp = 30+primOpTag Word8QuotRemOp = 31+primOpTag Word8EqOp = 32+primOpTag Word8GeOp = 33+primOpTag Word8GtOp = 34+primOpTag Word8LeOp = 35+primOpTag Word8LtOp = 36+primOpTag Word8NeOp = 37+primOpTag Int16Extend = 38+primOpTag Int16Narrow = 39+primOpTag Int16NegOp = 40+primOpTag Int16AddOp = 41+primOpTag Int16SubOp = 42+primOpTag Int16MulOp = 43+primOpTag Int16QuotOp = 44+primOpTag Int16RemOp = 45+primOpTag Int16QuotRemOp = 46+primOpTag Int16EqOp = 47+primOpTag Int16GeOp = 48+primOpTag Int16GtOp = 49+primOpTag Int16LeOp = 50+primOpTag Int16LtOp = 51+primOpTag Int16NeOp = 52+primOpTag Word16Extend = 53+primOpTag Word16Narrow = 54+primOpTag Word16NotOp = 55+primOpTag Word16AddOp = 56+primOpTag Word16SubOp = 57+primOpTag Word16MulOp = 58+primOpTag Word16QuotOp = 59+primOpTag Word16RemOp = 60+primOpTag Word16QuotRemOp = 61+primOpTag Word16EqOp = 62+primOpTag Word16GeOp = 63+primOpTag Word16GtOp = 64+primOpTag Word16LeOp = 65+primOpTag Word16LtOp = 66+primOpTag Word16NeOp = 67+primOpTag IntAddOp = 68+primOpTag IntSubOp = 69+primOpTag IntMulOp = 70+primOpTag IntMul2Op = 71+primOpTag IntMulMayOfloOp = 72+primOpTag IntQuotOp = 73+primOpTag IntRemOp = 74+primOpTag IntQuotRemOp = 75+primOpTag AndIOp = 76+primOpTag OrIOp = 77+primOpTag XorIOp = 78+primOpTag NotIOp = 79+primOpTag IntNegOp = 80+primOpTag IntAddCOp = 81+primOpTag IntSubCOp = 82+primOpTag IntGtOp = 83+primOpTag IntGeOp = 84+primOpTag IntEqOp = 85+primOpTag IntNeOp = 86+primOpTag IntLtOp = 87+primOpTag IntLeOp = 88+primOpTag ChrOp = 89+primOpTag IntToWordOp = 90+primOpTag IntToFloatOp = 91+primOpTag IntToDoubleOp = 92+primOpTag WordToFloatOp = 93+primOpTag WordToDoubleOp = 94+primOpTag ISllOp = 95+primOpTag ISraOp = 96+primOpTag ISrlOp = 97+primOpTag WordAddOp = 98+primOpTag WordAddCOp = 99+primOpTag WordSubCOp = 100+primOpTag WordAdd2Op = 101+primOpTag WordSubOp = 102+primOpTag WordMulOp = 103+primOpTag WordMul2Op = 104+primOpTag WordQuotOp = 105+primOpTag WordRemOp = 106+primOpTag WordQuotRemOp = 107+primOpTag WordQuotRem2Op = 108+primOpTag AndOp = 109+primOpTag OrOp = 110+primOpTag XorOp = 111+primOpTag NotOp = 112+primOpTag SllOp = 113+primOpTag SrlOp = 114+primOpTag WordToIntOp = 115+primOpTag WordGtOp = 116+primOpTag WordGeOp = 117+primOpTag WordEqOp = 118+primOpTag WordNeOp = 119+primOpTag WordLtOp = 120+primOpTag WordLeOp = 121+primOpTag PopCnt8Op = 122+primOpTag PopCnt16Op = 123+primOpTag PopCnt32Op = 124+primOpTag PopCnt64Op = 125+primOpTag PopCntOp = 126+primOpTag Pdep8Op = 127+primOpTag Pdep16Op = 128+primOpTag Pdep32Op = 129+primOpTag Pdep64Op = 130+primOpTag PdepOp = 131+primOpTag Pext8Op = 132+primOpTag Pext16Op = 133+primOpTag Pext32Op = 134+primOpTag Pext64Op = 135+primOpTag PextOp = 136+primOpTag Clz8Op = 137+primOpTag Clz16Op = 138+primOpTag Clz32Op = 139+primOpTag Clz64Op = 140+primOpTag ClzOp = 141+primOpTag Ctz8Op = 142+primOpTag Ctz16Op = 143+primOpTag Ctz32Op = 144+primOpTag Ctz64Op = 145+primOpTag CtzOp = 146+primOpTag BSwap16Op = 147+primOpTag BSwap32Op = 148+primOpTag BSwap64Op = 149+primOpTag BSwapOp = 150+primOpTag BRev8Op = 151+primOpTag BRev16Op = 152+primOpTag BRev32Op = 153+primOpTag BRev64Op = 154+primOpTag BRevOp = 155+primOpTag Narrow8IntOp = 156+primOpTag Narrow16IntOp = 157+primOpTag Narrow32IntOp = 158+primOpTag Narrow8WordOp = 159+primOpTag Narrow16WordOp = 160+primOpTag Narrow32WordOp = 161+primOpTag DoubleGtOp = 162+primOpTag DoubleGeOp = 163+primOpTag DoubleEqOp = 164+primOpTag DoubleNeOp = 165+primOpTag DoubleLtOp = 166+primOpTag DoubleLeOp = 167+primOpTag DoubleAddOp = 168+primOpTag DoubleSubOp = 169+primOpTag DoubleMulOp = 170+primOpTag DoubleDivOp = 171+primOpTag DoubleNegOp = 172+primOpTag DoubleFabsOp = 173+primOpTag DoubleToIntOp = 174+primOpTag DoubleToFloatOp = 175+primOpTag DoubleExpOp = 176+primOpTag DoubleExpM1Op = 177+primOpTag DoubleLogOp = 178+primOpTag DoubleLog1POp = 179+primOpTag DoubleSqrtOp = 180+primOpTag DoubleSinOp = 181+primOpTag DoubleCosOp = 182+primOpTag DoubleTanOp = 183+primOpTag DoubleAsinOp = 184+primOpTag DoubleAcosOp = 185+primOpTag DoubleAtanOp = 186+primOpTag DoubleSinhOp = 187+primOpTag DoubleCoshOp = 188+primOpTag DoubleTanhOp = 189+primOpTag DoubleAsinhOp = 190+primOpTag DoubleAcoshOp = 191+primOpTag DoubleAtanhOp = 192+primOpTag DoublePowerOp = 193+primOpTag DoubleDecode_2IntOp = 194+primOpTag DoubleDecode_Int64Op = 195+primOpTag FloatGtOp = 196+primOpTag FloatGeOp = 197+primOpTag FloatEqOp = 198+primOpTag FloatNeOp = 199+primOpTag FloatLtOp = 200+primOpTag FloatLeOp = 201+primOpTag FloatAddOp = 202+primOpTag FloatSubOp = 203+primOpTag FloatMulOp = 204+primOpTag FloatDivOp = 205+primOpTag FloatNegOp = 206+primOpTag FloatFabsOp = 207+primOpTag FloatToIntOp = 208+primOpTag FloatExpOp = 209+primOpTag FloatExpM1Op = 210+primOpTag FloatLogOp = 211+primOpTag FloatLog1POp = 212+primOpTag FloatSqrtOp = 213+primOpTag FloatSinOp = 214+primOpTag FloatCosOp = 215+primOpTag FloatTanOp = 216+primOpTag FloatAsinOp = 217+primOpTag FloatAcosOp = 218+primOpTag FloatAtanOp = 219+primOpTag FloatSinhOp = 220+primOpTag FloatCoshOp = 221+primOpTag FloatTanhOp = 222+primOpTag FloatAsinhOp = 223+primOpTag FloatAcoshOp = 224+primOpTag FloatAtanhOp = 225+primOpTag FloatPowerOp = 226+primOpTag FloatToDoubleOp = 227+primOpTag FloatDecode_IntOp = 228+primOpTag NewArrayOp = 229+primOpTag SameMutableArrayOp = 230+primOpTag ReadArrayOp = 231+primOpTag WriteArrayOp = 232+primOpTag SizeofArrayOp = 233+primOpTag SizeofMutableArrayOp = 234+primOpTag IndexArrayOp = 235+primOpTag UnsafeFreezeArrayOp = 236+primOpTag UnsafeThawArrayOp = 237+primOpTag CopyArrayOp = 238+primOpTag CopyMutableArrayOp = 239+primOpTag CloneArrayOp = 240+primOpTag CloneMutableArrayOp = 241+primOpTag FreezeArrayOp = 242+primOpTag ThawArrayOp = 243+primOpTag CasArrayOp = 244+primOpTag NewSmallArrayOp = 245+primOpTag SameSmallMutableArrayOp = 246+primOpTag ShrinkSmallMutableArrayOp_Char = 247+primOpTag ReadSmallArrayOp = 248+primOpTag WriteSmallArrayOp = 249+primOpTag SizeofSmallArrayOp = 250+primOpTag SizeofSmallMutableArrayOp = 251+primOpTag GetSizeofSmallMutableArrayOp = 252+primOpTag IndexSmallArrayOp = 253+primOpTag UnsafeFreezeSmallArrayOp = 254+primOpTag UnsafeThawSmallArrayOp = 255+primOpTag CopySmallArrayOp = 256+primOpTag CopySmallMutableArrayOp = 257+primOpTag CloneSmallArrayOp = 258+primOpTag CloneSmallMutableArrayOp = 259+primOpTag FreezeSmallArrayOp = 260+primOpTag ThawSmallArrayOp = 261+primOpTag CasSmallArrayOp = 262+primOpTag NewByteArrayOp_Char = 263+primOpTag NewPinnedByteArrayOp_Char = 264+primOpTag NewAlignedPinnedByteArrayOp_Char = 265+primOpTag MutableByteArrayIsPinnedOp = 266+primOpTag ByteArrayIsPinnedOp = 267+primOpTag ByteArrayContents_Char = 268+primOpTag SameMutableByteArrayOp = 269+primOpTag ShrinkMutableByteArrayOp_Char = 270+primOpTag ResizeMutableByteArrayOp_Char = 271+primOpTag UnsafeFreezeByteArrayOp = 272+primOpTag SizeofByteArrayOp = 273+primOpTag SizeofMutableByteArrayOp = 274+primOpTag GetSizeofMutableByteArrayOp = 275+primOpTag IndexByteArrayOp_Char = 276+primOpTag IndexByteArrayOp_WideChar = 277+primOpTag IndexByteArrayOp_Int = 278+primOpTag IndexByteArrayOp_Word = 279+primOpTag IndexByteArrayOp_Addr = 280+primOpTag IndexByteArrayOp_Float = 281+primOpTag IndexByteArrayOp_Double = 282+primOpTag IndexByteArrayOp_StablePtr = 283+primOpTag IndexByteArrayOp_Int8 = 284+primOpTag IndexByteArrayOp_Int16 = 285+primOpTag IndexByteArrayOp_Int32 = 286+primOpTag IndexByteArrayOp_Int64 = 287+primOpTag IndexByteArrayOp_Word8 = 288+primOpTag IndexByteArrayOp_Word16 = 289+primOpTag IndexByteArrayOp_Word32 = 290+primOpTag IndexByteArrayOp_Word64 = 291+primOpTag IndexByteArrayOp_Word8AsChar = 292+primOpTag IndexByteArrayOp_Word8AsWideChar = 293+primOpTag IndexByteArrayOp_Word8AsInt = 294+primOpTag IndexByteArrayOp_Word8AsWord = 295+primOpTag IndexByteArrayOp_Word8AsAddr = 296+primOpTag IndexByteArrayOp_Word8AsFloat = 297+primOpTag IndexByteArrayOp_Word8AsDouble = 298+primOpTag IndexByteArrayOp_Word8AsStablePtr = 299+primOpTag IndexByteArrayOp_Word8AsInt16 = 300+primOpTag IndexByteArrayOp_Word8AsInt32 = 301+primOpTag IndexByteArrayOp_Word8AsInt64 = 302+primOpTag IndexByteArrayOp_Word8AsWord16 = 303+primOpTag IndexByteArrayOp_Word8AsWord32 = 304+primOpTag IndexByteArrayOp_Word8AsWord64 = 305+primOpTag ReadByteArrayOp_Char = 306+primOpTag ReadByteArrayOp_WideChar = 307+primOpTag ReadByteArrayOp_Int = 308+primOpTag ReadByteArrayOp_Word = 309+primOpTag ReadByteArrayOp_Addr = 310+primOpTag ReadByteArrayOp_Float = 311+primOpTag ReadByteArrayOp_Double = 312+primOpTag ReadByteArrayOp_StablePtr = 313+primOpTag ReadByteArrayOp_Int8 = 314+primOpTag ReadByteArrayOp_Int16 = 315+primOpTag ReadByteArrayOp_Int32 = 316+primOpTag ReadByteArrayOp_Int64 = 317+primOpTag ReadByteArrayOp_Word8 = 318+primOpTag ReadByteArrayOp_Word16 = 319+primOpTag ReadByteArrayOp_Word32 = 320+primOpTag ReadByteArrayOp_Word64 = 321+primOpTag ReadByteArrayOp_Word8AsChar = 322+primOpTag ReadByteArrayOp_Word8AsWideChar = 323+primOpTag ReadByteArrayOp_Word8AsInt = 324+primOpTag ReadByteArrayOp_Word8AsWord = 325+primOpTag ReadByteArrayOp_Word8AsAddr = 326+primOpTag ReadByteArrayOp_Word8AsFloat = 327+primOpTag ReadByteArrayOp_Word8AsDouble = 328+primOpTag ReadByteArrayOp_Word8AsStablePtr = 329+primOpTag ReadByteArrayOp_Word8AsInt16 = 330+primOpTag ReadByteArrayOp_Word8AsInt32 = 331+primOpTag ReadByteArrayOp_Word8AsInt64 = 332+primOpTag ReadByteArrayOp_Word8AsWord16 = 333+primOpTag ReadByteArrayOp_Word8AsWord32 = 334+primOpTag ReadByteArrayOp_Word8AsWord64 = 335+primOpTag WriteByteArrayOp_Char = 336+primOpTag WriteByteArrayOp_WideChar = 337+primOpTag WriteByteArrayOp_Int = 338+primOpTag WriteByteArrayOp_Word = 339+primOpTag WriteByteArrayOp_Addr = 340+primOpTag WriteByteArrayOp_Float = 341+primOpTag WriteByteArrayOp_Double = 342+primOpTag WriteByteArrayOp_StablePtr = 343+primOpTag WriteByteArrayOp_Int8 = 344+primOpTag WriteByteArrayOp_Int16 = 345+primOpTag WriteByteArrayOp_Int32 = 346+primOpTag WriteByteArrayOp_Int64 = 347+primOpTag WriteByteArrayOp_Word8 = 348+primOpTag WriteByteArrayOp_Word16 = 349+primOpTag WriteByteArrayOp_Word32 = 350+primOpTag WriteByteArrayOp_Word64 = 351+primOpTag WriteByteArrayOp_Word8AsChar = 352+primOpTag WriteByteArrayOp_Word8AsWideChar = 353+primOpTag WriteByteArrayOp_Word8AsInt = 354+primOpTag WriteByteArrayOp_Word8AsWord = 355+primOpTag WriteByteArrayOp_Word8AsAddr = 356+primOpTag WriteByteArrayOp_Word8AsFloat = 357+primOpTag WriteByteArrayOp_Word8AsDouble = 358+primOpTag WriteByteArrayOp_Word8AsStablePtr = 359+primOpTag WriteByteArrayOp_Word8AsInt16 = 360+primOpTag WriteByteArrayOp_Word8AsInt32 = 361+primOpTag WriteByteArrayOp_Word8AsInt64 = 362+primOpTag WriteByteArrayOp_Word8AsWord16 = 363+primOpTag WriteByteArrayOp_Word8AsWord32 = 364+primOpTag WriteByteArrayOp_Word8AsWord64 = 365+primOpTag CompareByteArraysOp = 366+primOpTag CopyByteArrayOp = 367+primOpTag CopyMutableByteArrayOp = 368+primOpTag CopyByteArrayToAddrOp = 369+primOpTag CopyMutableByteArrayToAddrOp = 370+primOpTag CopyAddrToByteArrayOp = 371+primOpTag SetByteArrayOp = 372+primOpTag AtomicReadByteArrayOp_Int = 373+primOpTag AtomicWriteByteArrayOp_Int = 374+primOpTag CasByteArrayOp_Int = 375+primOpTag FetchAddByteArrayOp_Int = 376+primOpTag FetchSubByteArrayOp_Int = 377+primOpTag FetchAndByteArrayOp_Int = 378+primOpTag FetchNandByteArrayOp_Int = 379+primOpTag FetchOrByteArrayOp_Int = 380+primOpTag FetchXorByteArrayOp_Int = 381+primOpTag NewArrayArrayOp = 382+primOpTag SameMutableArrayArrayOp = 383+primOpTag UnsafeFreezeArrayArrayOp = 384+primOpTag SizeofArrayArrayOp = 385+primOpTag SizeofMutableArrayArrayOp = 386+primOpTag IndexArrayArrayOp_ByteArray = 387+primOpTag IndexArrayArrayOp_ArrayArray = 388+primOpTag ReadArrayArrayOp_ByteArray = 389+primOpTag ReadArrayArrayOp_MutableByteArray = 390+primOpTag ReadArrayArrayOp_ArrayArray = 391+primOpTag ReadArrayArrayOp_MutableArrayArray = 392+primOpTag WriteArrayArrayOp_ByteArray = 393+primOpTag WriteArrayArrayOp_MutableByteArray = 394+primOpTag WriteArrayArrayOp_ArrayArray = 395+primOpTag WriteArrayArrayOp_MutableArrayArray = 396+primOpTag CopyArrayArrayOp = 397+primOpTag CopyMutableArrayArrayOp = 398+primOpTag AddrAddOp = 399+primOpTag AddrSubOp = 400+primOpTag AddrRemOp = 401+primOpTag AddrToIntOp = 402+primOpTag IntToAddrOp = 403+primOpTag AddrGtOp = 404+primOpTag AddrGeOp = 405+primOpTag AddrEqOp = 406+primOpTag AddrNeOp = 407+primOpTag AddrLtOp = 408+primOpTag AddrLeOp = 409+primOpTag IndexOffAddrOp_Char = 410+primOpTag IndexOffAddrOp_WideChar = 411+primOpTag IndexOffAddrOp_Int = 412+primOpTag IndexOffAddrOp_Word = 413+primOpTag IndexOffAddrOp_Addr = 414+primOpTag IndexOffAddrOp_Float = 415+primOpTag IndexOffAddrOp_Double = 416+primOpTag IndexOffAddrOp_StablePtr = 417+primOpTag IndexOffAddrOp_Int8 = 418+primOpTag IndexOffAddrOp_Int16 = 419+primOpTag IndexOffAddrOp_Int32 = 420+primOpTag IndexOffAddrOp_Int64 = 421+primOpTag IndexOffAddrOp_Word8 = 422+primOpTag IndexOffAddrOp_Word16 = 423+primOpTag IndexOffAddrOp_Word32 = 424+primOpTag IndexOffAddrOp_Word64 = 425+primOpTag ReadOffAddrOp_Char = 426+primOpTag ReadOffAddrOp_WideChar = 427+primOpTag ReadOffAddrOp_Int = 428+primOpTag ReadOffAddrOp_Word = 429+primOpTag ReadOffAddrOp_Addr = 430+primOpTag ReadOffAddrOp_Float = 431+primOpTag ReadOffAddrOp_Double = 432+primOpTag ReadOffAddrOp_StablePtr = 433+primOpTag ReadOffAddrOp_Int8 = 434+primOpTag ReadOffAddrOp_Int16 = 435+primOpTag ReadOffAddrOp_Int32 = 436+primOpTag ReadOffAddrOp_Int64 = 437+primOpTag ReadOffAddrOp_Word8 = 438+primOpTag ReadOffAddrOp_Word16 = 439+primOpTag ReadOffAddrOp_Word32 = 440+primOpTag ReadOffAddrOp_Word64 = 441+primOpTag WriteOffAddrOp_Char = 442+primOpTag WriteOffAddrOp_WideChar = 443+primOpTag WriteOffAddrOp_Int = 444+primOpTag WriteOffAddrOp_Word = 445+primOpTag WriteOffAddrOp_Addr = 446+primOpTag WriteOffAddrOp_Float = 447+primOpTag WriteOffAddrOp_Double = 448+primOpTag WriteOffAddrOp_StablePtr = 449+primOpTag WriteOffAddrOp_Int8 = 450+primOpTag WriteOffAddrOp_Int16 = 451+primOpTag WriteOffAddrOp_Int32 = 452+primOpTag WriteOffAddrOp_Int64 = 453+primOpTag WriteOffAddrOp_Word8 = 454+primOpTag WriteOffAddrOp_Word16 = 455+primOpTag WriteOffAddrOp_Word32 = 456+primOpTag WriteOffAddrOp_Word64 = 457+primOpTag InterlockedExchange_Addr = 458+primOpTag InterlockedExchange_Int = 459+primOpTag AtomicCompareExchange_Int = 460+primOpTag AtomicCompareExchange_Addr = 461+primOpTag NewMutVarOp = 462+primOpTag ReadMutVarOp = 463+primOpTag WriteMutVarOp = 464+primOpTag SameMutVarOp = 465+primOpTag AtomicModifyMutVar2Op = 466+primOpTag AtomicModifyMutVar_Op = 467+primOpTag CasMutVarOp = 468+primOpTag CatchOp = 469+primOpTag RaiseOp = 470+primOpTag RaiseIOOp = 471+primOpTag MaskAsyncExceptionsOp = 472+primOpTag MaskUninterruptibleOp = 473+primOpTag UnmaskAsyncExceptionsOp = 474+primOpTag MaskStatus = 475+primOpTag AtomicallyOp = 476+primOpTag RetryOp = 477+primOpTag CatchRetryOp = 478+primOpTag CatchSTMOp = 479+primOpTag NewTVarOp = 480+primOpTag ReadTVarOp = 481+primOpTag ReadTVarIOOp = 482+primOpTag WriteTVarOp = 483+primOpTag SameTVarOp = 484+primOpTag NewMVarOp = 485+primOpTag TakeMVarOp = 486+primOpTag TryTakeMVarOp = 487+primOpTag PutMVarOp = 488+primOpTag TryPutMVarOp = 489+primOpTag ReadMVarOp = 490+primOpTag TryReadMVarOp = 491+primOpTag SameMVarOp = 492+primOpTag IsEmptyMVarOp = 493+primOpTag NewIOPortrOp = 494+primOpTag ReadIOPortOp = 495+primOpTag WriteIOPortOp = 496+primOpTag SameIOPortOp = 497+primOpTag DelayOp = 498+primOpTag WaitReadOp = 499+primOpTag WaitWriteOp = 500+primOpTag ForkOp = 501+primOpTag ForkOnOp = 502+primOpTag KillThreadOp = 503+primOpTag YieldOp = 504+primOpTag MyThreadIdOp = 505+primOpTag LabelThreadOp = 506+primOpTag IsCurrentThreadBoundOp = 507+primOpTag NoDuplicateOp = 508+primOpTag ThreadStatusOp = 509+primOpTag MkWeakOp = 510+primOpTag MkWeakNoFinalizerOp = 511+primOpTag AddCFinalizerToWeakOp = 512+primOpTag DeRefWeakOp = 513+primOpTag FinalizeWeakOp = 514+primOpTag TouchOp = 515+primOpTag MakeStablePtrOp = 516+primOpTag DeRefStablePtrOp = 517+primOpTag EqStablePtrOp = 518+primOpTag MakeStableNameOp = 519+primOpTag EqStableNameOp = 520+primOpTag StableNameToIntOp = 521+primOpTag CompactNewOp = 522+primOpTag CompactResizeOp = 523+primOpTag CompactContainsOp = 524+primOpTag CompactContainsAnyOp = 525+primOpTag CompactGetFirstBlockOp = 526+primOpTag CompactGetNextBlockOp = 527+primOpTag CompactAllocateBlockOp = 528+primOpTag CompactFixupPointersOp = 529+primOpTag CompactAdd = 530+primOpTag CompactAddWithSharing = 531+primOpTag CompactSize = 532+primOpTag ReallyUnsafePtrEqualityOp = 533+primOpTag ParOp = 534+primOpTag SparkOp = 535+primOpTag SeqOp = 536+primOpTag GetSparkOp = 537+primOpTag NumSparks = 538+primOpTag DataToTagOp = 539+primOpTag TagToEnumOp = 540+primOpTag AddrToAnyOp = 541+primOpTag AnyToAddrOp = 542+primOpTag MkApUpd0_Op = 543+primOpTag NewBCOOp = 544+primOpTag UnpackClosureOp = 545+primOpTag ClosureSizeOp = 546+primOpTag GetApStackValOp = 547+primOpTag GetCCSOfOp = 548+primOpTag GetCurrentCCSOp = 549+primOpTag ClearCCSOp = 550+primOpTag TraceEventOp = 551+primOpTag TraceEventBinaryOp = 552+primOpTag TraceMarkerOp = 553+primOpTag SetThreadAllocationCounter = 554+primOpTag (VecBroadcastOp IntVec 16 W8) = 555+primOpTag (VecBroadcastOp IntVec 8 W16) = 556+primOpTag (VecBroadcastOp IntVec 4 W32) = 557+primOpTag (VecBroadcastOp IntVec 2 W64) = 558+primOpTag (VecBroadcastOp IntVec 32 W8) = 559+primOpTag (VecBroadcastOp IntVec 16 W16) = 560+primOpTag (VecBroadcastOp IntVec 8 W32) = 561+primOpTag (VecBroadcastOp IntVec 4 W64) = 562+primOpTag (VecBroadcastOp IntVec 64 W8) = 563+primOpTag (VecBroadcastOp IntVec 32 W16) = 564+primOpTag (VecBroadcastOp IntVec 16 W32) = 565+primOpTag (VecBroadcastOp IntVec 8 W64) = 566+primOpTag (VecBroadcastOp WordVec 16 W8) = 567+primOpTag (VecBroadcastOp WordVec 8 W16) = 568+primOpTag (VecBroadcastOp WordVec 4 W32) = 569+primOpTag (VecBroadcastOp WordVec 2 W64) = 570+primOpTag (VecBroadcastOp WordVec 32 W8) = 571+primOpTag (VecBroadcastOp WordVec 16 W16) = 572+primOpTag (VecBroadcastOp WordVec 8 W32) = 573+primOpTag (VecBroadcastOp WordVec 4 W64) = 574+primOpTag (VecBroadcastOp WordVec 64 W8) = 575+primOpTag (VecBroadcastOp WordVec 32 W16) = 576+primOpTag (VecBroadcastOp WordVec 16 W32) = 577+primOpTag (VecBroadcastOp WordVec 8 W64) = 578+primOpTag (VecBroadcastOp FloatVec 4 W32) = 579+primOpTag (VecBroadcastOp FloatVec 2 W64) = 580+primOpTag (VecBroadcastOp FloatVec 8 W32) = 581+primOpTag (VecBroadcastOp FloatVec 4 W64) = 582+primOpTag (VecBroadcastOp FloatVec 16 W32) = 583+primOpTag (VecBroadcastOp FloatVec 8 W64) = 584+primOpTag (VecPackOp IntVec 16 W8) = 585+primOpTag (VecPackOp IntVec 8 W16) = 586+primOpTag (VecPackOp IntVec 4 W32) = 587+primOpTag (VecPackOp IntVec 2 W64) = 588+primOpTag (VecPackOp IntVec 32 W8) = 589+primOpTag (VecPackOp IntVec 16 W16) = 590+primOpTag (VecPackOp IntVec 8 W32) = 591+primOpTag (VecPackOp IntVec 4 W64) = 592+primOpTag (VecPackOp IntVec 64 W8) = 593+primOpTag (VecPackOp IntVec 32 W16) = 594+primOpTag (VecPackOp IntVec 16 W32) = 595+primOpTag (VecPackOp IntVec 8 W64) = 596+primOpTag (VecPackOp WordVec 16 W8) = 597+primOpTag (VecPackOp WordVec 8 W16) = 598+primOpTag (VecPackOp WordVec 4 W32) = 599+primOpTag (VecPackOp WordVec 2 W64) = 600+primOpTag (VecPackOp WordVec 32 W8) = 601+primOpTag (VecPackOp WordVec 16 W16) = 602+primOpTag (VecPackOp WordVec 8 W32) = 603+primOpTag (VecPackOp WordVec 4 W64) = 604+primOpTag (VecPackOp WordVec 64 W8) = 605+primOpTag (VecPackOp WordVec 32 W16) = 606+primOpTag (VecPackOp WordVec 16 W32) = 607+primOpTag (VecPackOp WordVec 8 W64) = 608+primOpTag (VecPackOp FloatVec 4 W32) = 609+primOpTag (VecPackOp FloatVec 2 W64) = 610+primOpTag (VecPackOp FloatVec 8 W32) = 611+primOpTag (VecPackOp FloatVec 4 W64) = 612+primOpTag (VecPackOp FloatVec 16 W32) = 613+primOpTag (VecPackOp FloatVec 8 W64) = 614+primOpTag (VecUnpackOp IntVec 16 W8) = 615+primOpTag (VecUnpackOp IntVec 8 W16) = 616+primOpTag (VecUnpackOp IntVec 4 W32) = 617+primOpTag (VecUnpackOp IntVec 2 W64) = 618+primOpTag (VecUnpackOp IntVec 32 W8) = 619+primOpTag (VecUnpackOp IntVec 16 W16) = 620+primOpTag (VecUnpackOp IntVec 8 W32) = 621+primOpTag (VecUnpackOp IntVec 4 W64) = 622+primOpTag (VecUnpackOp IntVec 64 W8) = 623+primOpTag (VecUnpackOp IntVec 32 W16) = 624+primOpTag (VecUnpackOp IntVec 16 W32) = 625+primOpTag (VecUnpackOp IntVec 8 W64) = 626+primOpTag (VecUnpackOp WordVec 16 W8) = 627+primOpTag (VecUnpackOp WordVec 8 W16) = 628+primOpTag (VecUnpackOp WordVec 4 W32) = 629+primOpTag (VecUnpackOp WordVec 2 W64) = 630+primOpTag (VecUnpackOp WordVec 32 W8) = 631+primOpTag (VecUnpackOp WordVec 16 W16) = 632+primOpTag (VecUnpackOp WordVec 8 W32) = 633+primOpTag (VecUnpackOp WordVec 4 W64) = 634+primOpTag (VecUnpackOp WordVec 64 W8) = 635+primOpTag (VecUnpackOp WordVec 32 W16) = 636+primOpTag (VecUnpackOp WordVec 16 W32) = 637+primOpTag (VecUnpackOp WordVec 8 W64) = 638+primOpTag (VecUnpackOp FloatVec 4 W32) = 639+primOpTag (VecUnpackOp FloatVec 2 W64) = 640+primOpTag (VecUnpackOp FloatVec 8 W32) = 641+primOpTag (VecUnpackOp FloatVec 4 W64) = 642+primOpTag (VecUnpackOp FloatVec 16 W32) = 643+primOpTag (VecUnpackOp FloatVec 8 W64) = 644+primOpTag (VecInsertOp IntVec 16 W8) = 645+primOpTag (VecInsertOp IntVec 8 W16) = 646+primOpTag (VecInsertOp IntVec 4 W32) = 647+primOpTag (VecInsertOp IntVec 2 W64) = 648+primOpTag (VecInsertOp IntVec 32 W8) = 649+primOpTag (VecInsertOp IntVec 16 W16) = 650+primOpTag (VecInsertOp IntVec 8 W32) = 651+primOpTag (VecInsertOp IntVec 4 W64) = 652+primOpTag (VecInsertOp IntVec 64 W8) = 653+primOpTag (VecInsertOp IntVec 32 W16) = 654+primOpTag (VecInsertOp IntVec 16 W32) = 655+primOpTag (VecInsertOp IntVec 8 W64) = 656+primOpTag (VecInsertOp WordVec 16 W8) = 657+primOpTag (VecInsertOp WordVec 8 W16) = 658+primOpTag (VecInsertOp WordVec 4 W32) = 659+primOpTag (VecInsertOp WordVec 2 W64) = 660+primOpTag (VecInsertOp WordVec 32 W8) = 661+primOpTag (VecInsertOp WordVec 16 W16) = 662+primOpTag (VecInsertOp WordVec 8 W32) = 663+primOpTag (VecInsertOp WordVec 4 W64) = 664+primOpTag (VecInsertOp WordVec 64 W8) = 665+primOpTag (VecInsertOp WordVec 32 W16) = 666+primOpTag (VecInsertOp WordVec 16 W32) = 667+primOpTag (VecInsertOp WordVec 8 W64) = 668+primOpTag (VecInsertOp FloatVec 4 W32) = 669+primOpTag (VecInsertOp FloatVec 2 W64) = 670+primOpTag (VecInsertOp FloatVec 8 W32) = 671+primOpTag (VecInsertOp FloatVec 4 W64) = 672+primOpTag (VecInsertOp FloatVec 16 W32) = 673+primOpTag (VecInsertOp FloatVec 8 W64) = 674+primOpTag (VecAddOp IntVec 16 W8) = 675+primOpTag (VecAddOp IntVec 8 W16) = 676+primOpTag (VecAddOp IntVec 4 W32) = 677+primOpTag (VecAddOp IntVec 2 W64) = 678+primOpTag (VecAddOp IntVec 32 W8) = 679+primOpTag (VecAddOp IntVec 16 W16) = 680+primOpTag (VecAddOp IntVec 8 W32) = 681+primOpTag (VecAddOp IntVec 4 W64) = 682+primOpTag (VecAddOp IntVec 64 W8) = 683+primOpTag (VecAddOp IntVec 32 W16) = 684+primOpTag (VecAddOp IntVec 16 W32) = 685+primOpTag (VecAddOp IntVec 8 W64) = 686+primOpTag (VecAddOp WordVec 16 W8) = 687+primOpTag (VecAddOp WordVec 8 W16) = 688+primOpTag (VecAddOp WordVec 4 W32) = 689+primOpTag (VecAddOp WordVec 2 W64) = 690+primOpTag (VecAddOp WordVec 32 W8) = 691+primOpTag (VecAddOp WordVec 16 W16) = 692+primOpTag (VecAddOp WordVec 8 W32) = 693+primOpTag (VecAddOp WordVec 4 W64) = 694+primOpTag (VecAddOp WordVec 64 W8) = 695+primOpTag (VecAddOp WordVec 32 W16) = 696+primOpTag (VecAddOp WordVec 16 W32) = 697+primOpTag (VecAddOp WordVec 8 W64) = 698+primOpTag (VecAddOp FloatVec 4 W32) = 699+primOpTag (VecAddOp FloatVec 2 W64) = 700+primOpTag (VecAddOp FloatVec 8 W32) = 701+primOpTag (VecAddOp FloatVec 4 W64) = 702+primOpTag (VecAddOp FloatVec 16 W32) = 703+primOpTag (VecAddOp FloatVec 8 W64) = 704+primOpTag (VecSubOp IntVec 16 W8) = 705+primOpTag (VecSubOp IntVec 8 W16) = 706+primOpTag (VecSubOp IntVec 4 W32) = 707+primOpTag (VecSubOp IntVec 2 W64) = 708+primOpTag (VecSubOp IntVec 32 W8) = 709+primOpTag (VecSubOp IntVec 16 W16) = 710+primOpTag (VecSubOp IntVec 8 W32) = 711+primOpTag (VecSubOp IntVec 4 W64) = 712+primOpTag (VecSubOp IntVec 64 W8) = 713+primOpTag (VecSubOp IntVec 32 W16) = 714+primOpTag (VecSubOp IntVec 16 W32) = 715+primOpTag (VecSubOp IntVec 8 W64) = 716+primOpTag (VecSubOp WordVec 16 W8) = 717+primOpTag (VecSubOp WordVec 8 W16) = 718+primOpTag (VecSubOp WordVec 4 W32) = 719+primOpTag (VecSubOp WordVec 2 W64) = 720+primOpTag (VecSubOp WordVec 32 W8) = 721+primOpTag (VecSubOp WordVec 16 W16) = 722+primOpTag (VecSubOp WordVec 8 W32) = 723+primOpTag (VecSubOp WordVec 4 W64) = 724+primOpTag (VecSubOp WordVec 64 W8) = 725+primOpTag (VecSubOp WordVec 32 W16) = 726+primOpTag (VecSubOp WordVec 16 W32) = 727+primOpTag (VecSubOp WordVec 8 W64) = 728+primOpTag (VecSubOp FloatVec 4 W32) = 729+primOpTag (VecSubOp FloatVec 2 W64) = 730+primOpTag (VecSubOp FloatVec 8 W32) = 731+primOpTag (VecSubOp FloatVec 4 W64) = 732+primOpTag (VecSubOp FloatVec 16 W32) = 733+primOpTag (VecSubOp FloatVec 8 W64) = 734+primOpTag (VecMulOp IntVec 16 W8) = 735+primOpTag (VecMulOp IntVec 8 W16) = 736+primOpTag (VecMulOp IntVec 4 W32) = 737+primOpTag (VecMulOp IntVec 2 W64) = 738+primOpTag (VecMulOp IntVec 32 W8) = 739+primOpTag (VecMulOp IntVec 16 W16) = 740+primOpTag (VecMulOp IntVec 8 W32) = 741+primOpTag (VecMulOp IntVec 4 W64) = 742+primOpTag (VecMulOp IntVec 64 W8) = 743+primOpTag (VecMulOp IntVec 32 W16) = 744+primOpTag (VecMulOp IntVec 16 W32) = 745+primOpTag (VecMulOp IntVec 8 W64) = 746+primOpTag (VecMulOp WordVec 16 W8) = 747+primOpTag (VecMulOp WordVec 8 W16) = 748+primOpTag (VecMulOp WordVec 4 W32) = 749+primOpTag (VecMulOp WordVec 2 W64) = 750+primOpTag (VecMulOp WordVec 32 W8) = 751+primOpTag (VecMulOp WordVec 16 W16) = 752+primOpTag (VecMulOp WordVec 8 W32) = 753+primOpTag (VecMulOp WordVec 4 W64) = 754+primOpTag (VecMulOp WordVec 64 W8) = 755+primOpTag (VecMulOp WordVec 32 W16) = 756+primOpTag (VecMulOp WordVec 16 W32) = 757+primOpTag (VecMulOp WordVec 8 W64) = 758+primOpTag (VecMulOp FloatVec 4 W32) = 759+primOpTag (VecMulOp FloatVec 2 W64) = 760+primOpTag (VecMulOp FloatVec 8 W32) = 761+primOpTag (VecMulOp FloatVec 4 W64) = 762+primOpTag (VecMulOp FloatVec 16 W32) = 763+primOpTag (VecMulOp FloatVec 8 W64) = 764+primOpTag (VecDivOp FloatVec 4 W32) = 765+primOpTag (VecDivOp FloatVec 2 W64) = 766+primOpTag (VecDivOp FloatVec 8 W32) = 767+primOpTag (VecDivOp FloatVec 4 W64) = 768+primOpTag (VecDivOp FloatVec 16 W32) = 769+primOpTag (VecDivOp FloatVec 8 W64) = 770+primOpTag (VecQuotOp IntVec 16 W8) = 771+primOpTag (VecQuotOp IntVec 8 W16) = 772+primOpTag (VecQuotOp IntVec 4 W32) = 773+primOpTag (VecQuotOp IntVec 2 W64) = 774+primOpTag (VecQuotOp IntVec 32 W8) = 775+primOpTag (VecQuotOp IntVec 16 W16) = 776+primOpTag (VecQuotOp IntVec 8 W32) = 777+primOpTag (VecQuotOp IntVec 4 W64) = 778+primOpTag (VecQuotOp IntVec 64 W8) = 779+primOpTag (VecQuotOp IntVec 32 W16) = 780+primOpTag (VecQuotOp IntVec 16 W32) = 781+primOpTag (VecQuotOp IntVec 8 W64) = 782+primOpTag (VecQuotOp WordVec 16 W8) = 783+primOpTag (VecQuotOp WordVec 8 W16) = 784+primOpTag (VecQuotOp WordVec 4 W32) = 785+primOpTag (VecQuotOp WordVec 2 W64) = 786+primOpTag (VecQuotOp WordVec 32 W8) = 787+primOpTag (VecQuotOp WordVec 16 W16) = 788+primOpTag (VecQuotOp WordVec 8 W32) = 789+primOpTag (VecQuotOp WordVec 4 W64) = 790+primOpTag (VecQuotOp WordVec 64 W8) = 791+primOpTag (VecQuotOp WordVec 32 W16) = 792+primOpTag (VecQuotOp WordVec 16 W32) = 793+primOpTag (VecQuotOp WordVec 8 W64) = 794+primOpTag (VecRemOp IntVec 16 W8) = 795+primOpTag (VecRemOp IntVec 8 W16) = 796+primOpTag (VecRemOp IntVec 4 W32) = 797+primOpTag (VecRemOp IntVec 2 W64) = 798+primOpTag (VecRemOp IntVec 32 W8) = 799+primOpTag (VecRemOp IntVec 16 W16) = 800+primOpTag (VecRemOp IntVec 8 W32) = 801+primOpTag (VecRemOp IntVec 4 W64) = 802+primOpTag (VecRemOp IntVec 64 W8) = 803+primOpTag (VecRemOp IntVec 32 W16) = 804+primOpTag (VecRemOp IntVec 16 W32) = 805+primOpTag (VecRemOp IntVec 8 W64) = 806+primOpTag (VecRemOp WordVec 16 W8) = 807+primOpTag (VecRemOp WordVec 8 W16) = 808+primOpTag (VecRemOp WordVec 4 W32) = 809+primOpTag (VecRemOp WordVec 2 W64) = 810+primOpTag (VecRemOp WordVec 32 W8) = 811+primOpTag (VecRemOp WordVec 16 W16) = 812+primOpTag (VecRemOp WordVec 8 W32) = 813+primOpTag (VecRemOp WordVec 4 W64) = 814+primOpTag (VecRemOp WordVec 64 W8) = 815+primOpTag (VecRemOp WordVec 32 W16) = 816+primOpTag (VecRemOp WordVec 16 W32) = 817+primOpTag (VecRemOp WordVec 8 W64) = 818+primOpTag (VecNegOp IntVec 16 W8) = 819+primOpTag (VecNegOp IntVec 8 W16) = 820+primOpTag (VecNegOp IntVec 4 W32) = 821+primOpTag (VecNegOp IntVec 2 W64) = 822+primOpTag (VecNegOp IntVec 32 W8) = 823+primOpTag (VecNegOp IntVec 16 W16) = 824+primOpTag (VecNegOp IntVec 8 W32) = 825+primOpTag (VecNegOp IntVec 4 W64) = 826+primOpTag (VecNegOp IntVec 64 W8) = 827+primOpTag (VecNegOp IntVec 32 W16) = 828+primOpTag (VecNegOp IntVec 16 W32) = 829+primOpTag (VecNegOp IntVec 8 W64) = 830+primOpTag (VecNegOp FloatVec 4 W32) = 831+primOpTag (VecNegOp FloatVec 2 W64) = 832+primOpTag (VecNegOp FloatVec 8 W32) = 833+primOpTag (VecNegOp FloatVec 4 W64) = 834+primOpTag (VecNegOp FloatVec 16 W32) = 835+primOpTag (VecNegOp FloatVec 8 W64) = 836+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 837+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 838+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 839+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 840+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 841+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 842+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 843+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 844+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 845+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 846+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 847+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 848+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 849+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 850+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 851+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 852+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 853+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 854+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 855+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 856+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 857+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 858+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 859+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 860+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 861+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 862+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 863+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 864+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 865+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 866+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 867+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 868+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 869+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 870+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 871+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 872+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 873+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 874+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 875+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 876+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 877+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 878+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 879+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 880+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 881+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 882+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 883+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 884+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 885+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 886+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 887+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 888+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 889+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 890+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 891+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 892+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 893+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 894+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 895+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 896+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 897+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 898+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 899+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 900+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 901+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 902+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 903+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 904+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 905+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 906+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 907+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 908+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 909+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 910+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 911+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 912+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 913+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 914+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 915+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 916+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 917+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 918+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 919+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 920+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 921+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 922+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 923+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 924+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 925+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 926+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 927+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 928+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 929+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 930+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 931+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 932+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 933+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 934+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 935+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 936+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 937+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 938+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 939+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 940+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 941+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 942+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 943+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 944+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 945+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 946+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 947+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 948+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 949+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 950+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 951+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 952+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 953+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 954+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 955+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 956+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 957+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 958+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 959+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 960+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 961+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 962+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 963+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 964+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 965+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 966+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 967+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 968+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 969+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 970+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 971+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 972+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 973+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 974+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 975+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 976+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 977+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 978+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 979+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 980+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 981+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 982+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 983+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 984+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 985+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 986+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 987+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 988+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 989+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 990+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 991+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 992+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 993+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 994+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 995+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 996+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 997+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 998+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 999+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1000+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1001+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1002+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1003+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1004+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1005+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1006+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1007+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1008+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1009+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1010+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1011+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1012+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1013+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1014+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1015+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1016+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1017+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1018+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1019+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1020+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1021+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1022+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1023+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1024+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1025+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1026+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1027+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1028+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1029+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1030+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1031+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1032+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1033+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1034+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1035+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1036+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1037+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1038+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1039+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1040+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1041+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1042+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1043+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1044+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1045+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1046+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1047+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1048+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1049+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1050+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1051+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1052+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1053+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1054+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1055+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1056+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1057+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1058+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1059+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1060+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1061+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1062+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1063+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1064+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1065+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1066+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1067+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1068+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1069+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1070+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1071+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1072+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1073+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1074+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1075+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1076+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1077+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1078+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1079+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1080+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1081+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1082+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1083+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1084+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1085+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1086+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1087+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1088+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1089+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1090+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1091+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1092+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1093+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1094+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1095+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1096+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1097+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1098+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1099+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1100+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1101+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1102+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1103+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1104+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1105+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1106+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1107+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1108+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1109+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1110+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1111+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1112+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1113+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1114+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1115+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1116+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1117+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1118+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1119+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1120+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1121+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1122+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1123+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1124+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1125+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1126+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1127+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1128+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1129+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1130+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1131+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1132+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1133+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1134+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1135+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1136+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1137+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1138+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1139+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1140+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1141+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1142+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1143+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1144+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1145+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1146+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1147+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1148+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1149+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1150+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1151+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1152+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1153+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1154+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1155+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1156+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1157+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1158+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1159+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1160+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1161+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1162+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1163+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1164+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1165+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1166+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1167+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1168+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1169+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1170+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1171+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1172+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1173+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1174+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1175+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1176+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1177+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1178+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1179+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1180+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1181+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1182+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1183+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1184+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1185+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1186+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1187+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1188+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1189+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1190+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1191+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1192+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1193+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1194+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1195+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1196+primOpTag PrefetchByteArrayOp3 = 1197+primOpTag PrefetchMutableByteArrayOp3 = 1198+primOpTag PrefetchAddrOp3 = 1199+primOpTag PrefetchValueOp3 = 1200+primOpTag PrefetchByteArrayOp2 = 1201+primOpTag PrefetchMutableByteArrayOp2 = 1202+primOpTag PrefetchAddrOp2 = 1203+primOpTag PrefetchValueOp2 = 1204+primOpTag PrefetchByteArrayOp1 = 1205+primOpTag PrefetchMutableByteArrayOp1 = 1206+primOpTag PrefetchAddrOp1 = 1207+primOpTag PrefetchValueOp1 = 1208+primOpTag PrefetchByteArrayOp0 = 1209+primOpTag PrefetchMutableByteArrayOp0 = 1210+primOpTag PrefetchAddrOp0 = 1211+primOpTag PrefetchValueOp0 = 1212
ghc-lib/stage0/lib/ghcautoconf.h view
@@ -541,7 +541,7 @@ /* #undef pid_t */ /* The supported LLVM version number */-#define sUPPORTED_LLVM_VERSION (9)+#define sUPPORTED_LLVM_VERSION (10) /* Define to `unsigned int' if <sys/types.h> does not define. */ /* #undef size_t */
ghc-lib/stage0/lib/ghcversion.h view
@@ -5,11 +5,11 @@ #define __GLASGOW_HASKELL__ 901 #endif #if !defined(__GLASGOW_HASKELL_FULL_VERSION__)-#define __GLASGOW_HASKELL_FULL_VERSION__ "9.1.0.20201001"+#define __GLASGOW_HASKELL_FULL_VERSION__ "9.1.0.20201101" #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20201001+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20201101 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \
ghc-lib/stage0/lib/settings view
@@ -47,7 +47,5 @@ ,("Tables next to code", "YES") ,("Leading underscore", "YES") ,("Use LibFFI", "NO")-,("Use Threads", "YES")-,("Use Debugging", "NO") ,("RTS expects libdw", "NO") ]
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String-cProjectGitCommitId = "5c32655fffd0d8862f3ba693351f1e612daa0b6b"+cProjectGitCommitId = "e63db32c7eb089985a1a7279a0a886a32d70ac0e" cProjectVersion :: String-cProjectVersion = "9.1.0.20201001"+cProjectVersion = "9.1.0.20201101" cProjectVersionInt :: String cProjectVersionInt = "901" cProjectPatchLevel :: String-cProjectPatchLevel = "020201001"+cProjectPatchLevel = "020201101" cProjectPatchLevel1 :: String cProjectPatchLevel1 = "0" cProjectPatchLevel2 :: String-cProjectPatchLevel2 = "20201001"+cProjectPatchLevel2 = "20201101"
+ libraries/ghc-boot/GHC/Data/ShortText.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, GeneralizedNewtypeDeriving, DerivingStrategies #-}+{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}++-- |+-- An Unicode string for internal GHC use. Meant to replace String+-- in places where being a lazy linked is not very useful and a more+-- memory efficient data structure is desirable.++-- Very similar to FastString, but not hash-consed and with some extra instances and+-- functions for serialisation and I/O. Should be imported qualified.++module GHC.Data.ShortText (+ -- * ShortText+ ShortText(..),+ -- ** Conversion to and from String+ pack,+ unpack,+ -- ** Operations+ codepointLength,+ byteLength,+ GHC.Data.ShortText.null,+ splitFilePath,+ GHC.Data.ShortText.head,+ stripPrefix+ ) where++import Prelude++import Control.Monad (guard)+import Control.DeepSeq as DeepSeq+import Data.Binary+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Short.Internal as SBS+import GHC.Exts+import GHC.IO+import GHC.Utils.Encoding+import System.FilePath (isPathSeparator)++{-| A 'ShortText' is a modified UTF-8 encoded string meant for short strings like+file paths, module descriptions, etc.+-}+newtype ShortText = ShortText { contents :: SBS.ShortByteString+ }+ deriving stock (Show)+ deriving newtype (Eq, Ord, Binary, Semigroup, Monoid, NFData)++-- We don't want to derive this one from ShortByteString since that one won't handle+-- UTF-8 characters correctly.+instance IsString ShortText where+ fromString = pack++-- | /O(n)/ Returns the length of the 'ShortText' in characters.+codepointLength :: ShortText -> Int+codepointLength st = unsafeDupablePerformIO $ countUTF8Chars (contents st)+-- | /O(1)/ Returns the length of the 'ShortText' in bytes.+byteLength :: ShortText -> Int+byteLength st = SBS.length $ contents st++-- | /O(n)/ Convert a 'String' into a 'ShortText'.+pack :: String -> ShortText+pack s = unsafeDupablePerformIO $ ShortText <$> utf8EncodeShortByteString s++-- | /O(n)/ Convert a 'ShortText' into a 'String'.+unpack :: ShortText -> String+unpack st = utf8DecodeShortByteString $ contents st++-- | /O(1)/ Test whether the 'ShortText' is the empty string.+null :: ShortText -> Bool+null st = SBS.null $ contents st++-- | /O(n)/ Split a 'ShortText' representing a file path into its components by separating+-- on the file separator characters for this platform.+splitFilePath :: ShortText -> [ShortText]+-- This seems dangerous, but since the path separators are in the ASCII set they map down+-- to a single byte when encoded in UTF-8 and so this should work even when casting to ByteString.+-- We DeepSeq.force the resulting list so that we can be sure that no references to the+-- bytestring in `st'` remain in unevaluated thunks, which might prevent `st'` from being+-- collected by the GC.+splitFilePath st = DeepSeq.force $ map (ShortText . SBS.toShort) $ B8.splitWith isPathSeparator st'+ where st' = SBS.fromShort $ contents st++-- | /O(1)/ Returns the first UTF-8 codepoint in the 'ShortText'. Depending on the string in+-- question, this may or may not be the actual first character in the string due to Unicode+-- non-printable characters.+head :: ShortText -> Char+head st+ | SBS.null $ contents st = error "head: Empty ShortText"+ | otherwise = Prelude.head $ unpack st++-- | /O(n)/ The 'stripPrefix' function takes two 'ShortText's and returns 'Just' the remainder of+-- the second iff the first is its prefix, and otherwise Nothing.+stripPrefix :: ShortText -> ShortText -> Maybe ShortText+stripPrefix prefix st = do+ let !(SBS.SBS prefixBA) = contents prefix+ let !(SBS.SBS stBA) = contents st+ let prefixLength = sizeofByteArray# prefixBA+ let stLength = sizeofByteArray# stBA+ -- If the length of 'st' is not >= than the length of 'prefix', it is impossible for 'prefix'+ -- to be the prefix of `st`.+ guard $ (I# stLength) >= (I# prefixLength)+ -- 'prefix' is a prefix of 'st' if the first <length of prefix> bytes of 'st'+ -- are equal to 'prefix'+ guard $ I# (compareByteArrays# prefixBA 0# stBA 0# prefixLength) == 0+ -- Allocate a new ByteArray# and copy the remainder of the 'st' into it+ unsafeDupablePerformIO $ do+ let newBAsize = (stLength -# prefixLength)+ newSBS <- IO $ \s0 ->+ let !(# s1, ba #) = newByteArray# newBAsize s0+ s2 = copyByteArray# stBA prefixLength ba 0# newBAsize s1+ !(# s3, fba #) = unsafeFreezeByteArray# ba s2+ in (# s3, SBS.SBS fba #)+ return . Just . ShortText $ newSBS
libraries/ghc-boot/GHC/Unit/Database.hs view
@@ -12,6 +12,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- |@@ -82,16 +83,16 @@ import Data.Binary as Bin import Data.Binary.Put as Bin import Data.Binary.Get as Bin+import Data.List (intersperse) import Control.Exception as Exception import Control.Monad (when) import System.FilePath as FilePath-import qualified System.FilePath.Posix as FilePath.Posix import System.IO import System.IO.Error import GHC.IO.Exception (IOErrorType(InappropriateType))+import qualified GHC.Data.ShortText as ST import GHC.IO.Handle.Lock import System.Directory-import Data.List (stripPrefix) -- | @ghc-boot@'s UnitInfo, serialized to the database. type DbUnitInfo = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule@@ -142,28 +143,28 @@ -- components that can be registered in a database and used by other -- modules. - , unitAbiHash :: String+ , unitAbiHash :: ST.ShortText -- ^ ABI hash used to avoid mixing up units compiled with different -- dependencies, compiler, options, etc. , unitDepends :: [uid] -- ^ Identifiers of the units this one depends on - , unitAbiDepends :: [(uid, String)]+ , unitAbiDepends :: [(uid, ST.ShortText)] -- ^ Like 'unitDepends', but each dependency is annotated with the ABI hash -- we expect the dependency to respect. - , unitImportDirs :: [FilePath]+ , unitImportDirs :: [FilePathST] -- ^ Directories containing module interfaces - , unitLibraries :: [String]+ , unitLibraries :: [ST.ShortText] -- ^ Names of the Haskell libraries provided by this unit - , unitExtDepLibsSys :: [String]+ , unitExtDepLibsSys :: [ST.ShortText] -- ^ Names of the external system libraries that this unit depends on. See -- also `unitExtDepLibsGhc` field. - , unitExtDepLibsGhc :: [String]+ , unitExtDepLibsGhc :: [ST.ShortText] -- ^ Because of slight differences between the GHC dynamic linker (in -- GHC.Runtime.Linker) and the -- native system linker, some packages have to link with a different list@@ -174,46 +175,46 @@ -- If this field is set, then we use that instead of the -- `unitExtDepLibsSys` field. - , unitLibraryDirs :: [FilePath]+ , unitLibraryDirs :: [FilePathST] -- ^ Directories containing libraries provided by this unit. See also -- `unitLibraryDynDirs`. -- -- It seems to be used to store paths to external library dependencies -- too. - , unitLibraryDynDirs :: [FilePath]+ , unitLibraryDynDirs :: [FilePathST] -- ^ Directories containing the dynamic libraries provided by this unit. -- See also `unitLibraryDirs`. -- -- It seems to be used to store paths to external dynamic library -- dependencies too. - , unitExtDepFrameworks :: [String]+ , unitExtDepFrameworks :: [ST.ShortText] -- ^ Names of the external MacOS frameworks that this unit depends on. - , unitExtDepFrameworkDirs :: [FilePath]+ , unitExtDepFrameworkDirs :: [FilePathST] -- ^ Directories containing MacOS frameworks that this unit depends -- on. - , unitLinkerOptions :: [String]+ , unitLinkerOptions :: [ST.ShortText] -- ^ Linker (e.g. ld) command line options - , unitCcOptions :: [String]+ , unitCcOptions :: [ST.ShortText] -- ^ C compiler options that needs to be passed to the C compiler when we -- compile some C code against this unit. - , unitIncludes :: [String]+ , unitIncludes :: [ST.ShortText] -- ^ C header files that are required by this unit (provided by this unit -- or external) - , unitIncludeDirs :: [FilePath]+ , unitIncludeDirs :: [FilePathST] -- ^ Directories containing C header files that this unit depends -- on. - , unitHaddockInterfaces :: [FilePath]+ , unitHaddockInterfaces :: [FilePathST] -- ^ Paths to Haddock interface files for this unit - , unitHaddockHTMLs :: [FilePath]+ , unitHaddockHTMLs :: [FilePathST] -- ^ Paths to Haddock directories containing HTML files , unitExposedModules :: [(modulename, Maybe mod)]@@ -242,6 +243,8 @@ } deriving (Eq, Show) +type FilePathST = ST.ShortText+ -- | Convert between GenericUnitInfo instances mapGenericUnitInfo :: (uid1 -> uid2)@@ -646,12 +649,12 @@ -- Also perform a similar substitution for the older GHC-specific -- "$topdir" variable. The "topdir" is the location of the ghc -- installation (obtained from the -B option).-mkMungePathUrl :: FilePath -> FilePath -> (FilePath -> FilePath, FilePath -> FilePath)+mkMungePathUrl :: FilePathST -> FilePathST -> (FilePathST -> FilePathST, FilePathST -> FilePathST) mkMungePathUrl top_dir pkgroot = (munge_path, munge_url) where munge_path p- | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'- | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'+ | Just p' <- stripVarPrefix "${pkgroot}" p = mappend pkgroot p'+ | Just p' <- stripVarPrefix "$topdir" p = mappend top_dir p' | otherwise = p munge_url p@@ -659,20 +662,19 @@ | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' | otherwise = p - toUrlPath r p = "file:///"- -- URLs always use posix style '/' separators:- ++ FilePath.Posix.joinPath- (r : -- We need to drop a leading "/" or "\\"- -- if there is one:- dropWhile (all isPathSeparator)- (FilePath.splitDirectories p))+ toUrlPath r p = mconcat $ "file:///" : (intersperse "/" (r : (splitDirectories p)))+ -- URLs always use posix style '/' separators + -- We need to drop a leading "/" or "\\" if there is one:+ splitDirectories :: FilePathST -> [FilePathST]+ splitDirectories p = filter (not . ST.null) $ ST.splitFilePath p+ -- We could drop the separator here, and then use </> above. However, -- by leaving it in and using ++ we keep the same path separator -- rather than letting FilePath change it to use \ as the separator- stripVarPrefix var path = case stripPrefix var path of- Just [] -> Just []- Just cs@(c : _) | isPathSeparator c -> Just cs+ stripVarPrefix var path = case ST.stripPrefix var path of+ Just "" -> Just ""+ Just cs | isPathSeparator (ST.head cs) -> Just cs _ -> Nothing @@ -684,7 +686,7 @@ -- Also perform a similar substitution for the older GHC-specific -- "$topdir" variable. The "topdir" is the location of the ghc -- installation (obtained from the -B option).-mungeUnitInfoPaths :: FilePath -> FilePath -> GenericUnitInfo a b c d e f -> GenericUnitInfo a b c d e f+mungeUnitInfoPaths :: FilePathST -> FilePathST -> GenericUnitInfo a b c d e f -> GenericUnitInfo a b c d e f mungeUnitInfoPaths top_dir pkgroot pkg = -- TODO: similar code is duplicated in utils/ghc-pkg/Main.hs pkg
+ libraries/ghc-boot/GHC/Utils/Encoding.hs view
@@ -0,0 +1,529 @@+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}+{-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected. This module used to live in the `ghc`+-- package but has been moved to `ghc-boot` because the definition+-- of the package database (needed in both ghc and in ghc-pkg) lives in+-- `ghc-boot` and uses ShortText, which in turn depends on this module.++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 1997-2006+--+-- Character encodings+--+-- -----------------------------------------------------------------------------++module GHC.Utils.Encoding (+ -- * UTF-8+ utf8DecodeCharAddr#,+ utf8PrevChar,+ utf8CharStart,+ utf8DecodeChar,+ utf8DecodeByteString,+ utf8DecodeShortByteString,+ utf8CompareShortByteString,+ utf8DecodeStringLazy,+ utf8EncodeChar,+ utf8EncodeString,+ utf8EncodeShortByteString,+ utf8EncodedLength,+ countUTF8Chars,++ -- * Z-encoding+ zEncodeString,+ zDecodeString,++ -- * Base62-encoding+ toBase62,+ toBase62Padded+ ) where++import Prelude++import Foreign+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Data.Char+import qualified Data.Char as Char+import Numeric+import GHC.IO+import GHC.ST++import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as BS+import Data.ByteString.Short.Internal (ShortByteString(..))++import GHC.Exts++-- -----------------------------------------------------------------------------+-- UTF-8++-- We can't write the decoder as efficiently as we'd like without+-- resorting to unboxed extensions, unfortunately. I tried to write+-- an IO version of this function, but GHC can't eliminate boxed+-- results from an IO-returning function.+--+-- We assume we can ignore overflow when parsing a multibyte character here.+-- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences+-- before decoding them (see "GHC.Data.StringBuffer").++{-# INLINE utf8DecodeChar# #-}+utf8DecodeChar# :: (Int# -> Word#) -> (# Char#, Int# #)+utf8DecodeChar# indexWord8# =+ let !ch0 = word2Int# (indexWord8# 0#) in+ case () of+ _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #)++ | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) ->+ let !ch1 = word2Int# (indexWord8# 1#) in+ if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else+ (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +#+ (ch1 -# 0x80#)),+ 2# #)++ | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) ->+ let !ch1 = word2Int# (indexWord8# 1#) in+ if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else+ let !ch2 = word2Int# (indexWord8# 2#) in+ if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else+ (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +#+ ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +#+ (ch2 -# 0x80#)),+ 3# #)++ | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) ->+ let !ch1 = word2Int# (indexWord8# 1#) in+ if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else+ let !ch2 = word2Int# (indexWord8# 2#) in+ if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else+ let !ch3 = word2Int# (indexWord8# 3#) in+ if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else+ (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +#+ ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +#+ ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +#+ (ch3 -# 0x80#)),+ 4# #)++ | otherwise -> fail 1#+ where+ -- all invalid sequences end up here:+ fail :: Int# -> (# Char#, Int# #)+ fail nBytes# = (# '\0'#, nBytes# #)+ -- '\xFFFD' would be the usual replacement character, but+ -- that's a valid symbol in Haskell, so will result in a+ -- confusing parse error later on. Instead we use '\0' which+ -- will signal a lexer error immediately.++utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #)+utf8DecodeCharAddr# a# off# =+ utf8DecodeChar# (\i# -> indexWord8OffAddr# a# (i# +# off#))++utf8DecodeCharByteArray# :: ByteArray# -> Int# -> (# Char#, Int# #)+utf8DecodeCharByteArray# ba# off# =+ utf8DecodeChar# (\i# -> indexWord8Array# ba# (i# +# off#))++utf8DecodeChar :: Ptr Word8 -> (Char, Int)+utf8DecodeChar !(Ptr a#) =+ case utf8DecodeCharAddr# a# 0# of+ (# c#, nBytes# #) -> ( C# c#, I# nBytes# )++-- UTF-8 is cleverly designed so that we can always figure out where+-- the start of the current character is, given any position in a+-- stream. This function finds the start of the previous character,+-- assuming there *is* a previous character.+utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8)+utf8PrevChar p = utf8CharStart (p `plusPtr` (-1))++utf8CharStart :: Ptr Word8 -> IO (Ptr Word8)+utf8CharStart p = go p+ where go p = do w <- peek p+ if w >= 0x80 && w < 0xC0+ then go (p `plusPtr` (-1))+ else return p++{-# INLINE utf8DecodeLazy# #-}+utf8DecodeLazy# :: (IO ()) -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char]+utf8DecodeLazy# retain decodeChar# len#+ = unpack 0#+ where+ unpack i#+ | isTrue# (i# >=# len#) = retain >> return []+ | otherwise =+ case decodeChar# i# of+ (# c#, nBytes# #) -> do+ rest <- unsafeDupableInterleaveIO $ unpack (i# +# nBytes#)+ return (C# c# : rest)++utf8DecodeByteString :: ByteString -> [Char]+utf8DecodeByteString (BS.PS fptr offset len)+ = utf8DecodeStringLazy fptr offset len++utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char]+utf8DecodeStringLazy fp offset (I# len#)+ = unsafeDupablePerformIO $ do+ let !(Ptr a#) = unsafeForeignPtrToPtr fp `plusPtr` offset+ utf8DecodeLazy# (touchForeignPtr fp) (utf8DecodeCharAddr# a#) len#+-- Note that since utf8DecodeLazy# returns a thunk the lifetime of the+-- ForeignPtr actually needs to be longer than the lexical lifetime+-- withForeignPtr would provide here. That's why we use touchForeignPtr to+-- keep the fp alive until the last character has actually been decoded.++utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering+utf8CompareShortByteString (SBS a1) (SBS a2) = go 0# 0#+ -- UTF-8 has the property that sorting by bytes values also sorts by+ -- code-points.+ -- BUT we use "Modified UTF-8" which encodes \0 as 0xC080 so this property+ -- doesn't hold and we must explicitly check this case here.+ -- Note that decoding every code point would also work but it would be much+ -- more costly.+ where+ !sz1 = sizeofByteArray# a1+ !sz2 = sizeofByteArray# a2+ go off1 off2+ | isTrue# ((off1 >=# sz1) `andI#` (off2 >=# sz2)) = EQ+ | isTrue# (off1 >=# sz1) = LT+ | isTrue# (off2 >=# sz2) = GT+ | otherwise =+ let !b1_1 = indexWord8Array# a1 off1+ !b2_1 = indexWord8Array# a2 off2+ in case b1_1 of+ 0xC0## -> case b2_1 of+ 0xC0## -> go (off1 +# 1#) (off2 +# 1#)+ _ -> case indexWord8Array# a1 (off1 +# 1#) of+ 0x80## -> LT+ _ -> go (off1 +# 1#) (off2 +# 1#)+ _ -> case b2_1 of+ 0xC0## -> case indexWord8Array# a2 (off2 +# 1#) of+ 0x80## -> GT+ _ -> go (off1 +# 1#) (off2 +# 1#)+ _ | isTrue# (b1_1 `gtWord#` b2_1) -> GT+ | isTrue# (b1_1 `ltWord#` b2_1) -> LT+ | otherwise -> go (off1 +# 1#) (off2 +# 1#)++utf8DecodeShortByteString :: ShortByteString -> [Char]+utf8DecodeShortByteString (SBS ba#)+ = unsafeDupablePerformIO $+ let len# = sizeofByteArray# ba# in+ utf8DecodeLazy# (return ()) (utf8DecodeCharByteArray# ba#) len#++countUTF8Chars :: ShortByteString -> IO Int+countUTF8Chars (SBS ba) = go 0# 0#+ where+ len# = sizeofByteArray# ba+ go i# n#+ | isTrue# (i# >=# len#) =+ return (I# n#)+ | otherwise = do+ case utf8DecodeCharByteArray# ba i# of+ (# _, nBytes# #) -> go (i# +# nBytes#) (n# +# 1#)++{-# INLINE utf8EncodeChar #-}+utf8EncodeChar :: (Int# -> Word# -> State# s -> State# s)+ -> Char -> ST s Int+utf8EncodeChar write# c =+ let x = ord c in+ case () of+ _ | x > 0 && x <= 0x007f -> do+ write 0 x+ return 1+ -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we+ -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8).+ | x <= 0x07ff -> do+ write 0 (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))+ write 1 (0x80 .|. (x .&. 0x3F))+ return 2+ | x <= 0xffff -> do+ write 0 (0xE0 .|. (x `shiftR` 12) .&. 0x0F)+ write 1 (0x80 .|. (x `shiftR` 6) .&. 0x3F)+ write 2 (0x80 .|. (x .&. 0x3F))+ return 3+ | otherwise -> do+ write 0 (0xF0 .|. (x `shiftR` 18))+ write 1 (0x80 .|. ((x `shiftR` 12) .&. 0x3F))+ write 2 (0x80 .|. ((x `shiftR` 6) .&. 0x3F))+ write 3 (0x80 .|. (x .&. 0x3F))+ return 4+ where+ {-# INLINE write #-}+ write (I# off#) (I# c#) = ST $ \s ->+ case write# off# (int2Word# c#) s of+ s -> (# s, () #)++utf8EncodeString :: Ptr Word8 -> String -> IO ()+utf8EncodeString (Ptr a#) str = go a# str+ where go !_ [] = return ()+ go a# (c:cs) = do+ I# off# <- stToIO $ utf8EncodeChar (writeWord8OffAddr# a#) c+ go (a# `plusAddr#` off#) cs++utf8EncodeShortByteString :: String -> IO ShortByteString+utf8EncodeShortByteString str = IO $ \s ->+ case utf8EncodedLength str of { I# len# ->+ case newByteArray# len# s of { (# s, mba# #) ->+ case go mba# 0# str of { ST f_go ->+ case f_go s of { (# s, () #) ->+ case unsafeFreezeByteArray# mba# s of { (# s, ba# #) ->+ (# s, SBS ba# #) }}}}}+ where+ go _ _ [] = return ()+ go mba# i# (c:cs) = do+ I# off# <- utf8EncodeChar (\j# -> writeWord8Array# mba# (i# +# j#)) c+ go mba# (i# +# off#) cs++utf8EncodedLength :: String -> Int+utf8EncodedLength str = go 0 str+ where go !n [] = n+ go n (c:cs)+ | ord c > 0 && ord c <= 0x007f = go (n+1) cs+ | ord c <= 0x07ff = go (n+2) cs+ | ord c <= 0xffff = go (n+3) cs+ | otherwise = go (n+4) cs++-- -----------------------------------------------------------------------------+-- Note [Z-Encoding]+-- ~~~~~~~~~~~~~~~~~++{-+This is the main name-encoding and decoding function. It encodes any+string into a string that is acceptable as a C name. This is done+right before we emit a symbol name into the compiled C or asm code.+Z-encoding of strings is cached in the FastString interface, so we+never encode the same string more than once.++The basic encoding scheme is this.++* Tuples (,,,) are coded as Z3T++* Alphabetic characters (upper and lower) and digits+ all translate to themselves;+ except 'Z', which translates to 'ZZ'+ and 'z', which translates to 'zz'+ We need both so that we can preserve the variable/tycon distinction++* Most other printable characters translate to 'zx' or 'Zx' for some+ alphabetic character x++* The others translate as 'znnnU' where 'nnn' is the decimal number+ of the character++ Before After+ --------------------------+ Trak Trak+ foo_wib foozuwib+ > zg+ >1 zg1+ foo# foozh+ foo## foozhzh+ foo##1 foozhzh1+ fooZ fooZZ+ :+ ZCzp+ () Z0T 0-tuple+ (,,,,) Z5T 5-tuple+ (# #) Z1H unboxed 1-tuple (note the space)+ (#,,,,#) Z5H unboxed 5-tuple+ (NB: There is no Z1T nor Z0H.)+-}++type UserString = String -- As the user typed it+type EncodedString = String -- Encoded form+++zEncodeString :: UserString -> EncodedString+zEncodeString cs = case maybe_tuple cs of+ Just n -> n -- Tuples go to Z2T etc+ Nothing -> go cs+ where+ go [] = []+ go (c:cs) = encode_digit_ch c ++ go' cs+ go' [] = []+ go' (c:cs) = encode_ch c ++ go' cs++unencodedChar :: Char -> Bool -- True for chars that don't need encoding+unencodedChar 'Z' = False+unencodedChar 'z' = False+unencodedChar c = c >= 'a' && c <= 'z'+ || c >= 'A' && c <= 'Z'+ || c >= '0' && c <= '9'++-- If a digit is at the start of a symbol then we need to encode it.+-- Otherwise package names like 9pH-0.1 give linker errors.+encode_digit_ch :: Char -> EncodedString+encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c+encode_digit_ch c | otherwise = encode_ch c++encode_ch :: Char -> EncodedString+encode_ch c | unencodedChar c = [c] -- Common case first++-- Constructors+encode_ch '(' = "ZL" -- Needed for things like (,), and (->)+encode_ch ')' = "ZR" -- For symmetry with (+encode_ch '[' = "ZM"+encode_ch ']' = "ZN"+encode_ch ':' = "ZC"+encode_ch 'Z' = "ZZ"++-- Variables+encode_ch 'z' = "zz"+encode_ch '&' = "za"+encode_ch '|' = "zb"+encode_ch '^' = "zc"+encode_ch '$' = "zd"+encode_ch '=' = "ze"+encode_ch '>' = "zg"+encode_ch '#' = "zh"+encode_ch '.' = "zi"+encode_ch '<' = "zl"+encode_ch '-' = "zm"+encode_ch '!' = "zn"+encode_ch '+' = "zp"+encode_ch '\'' = "zq"+encode_ch '\\' = "zr"+encode_ch '/' = "zs"+encode_ch '*' = "zt"+encode_ch '_' = "zu"+encode_ch '%' = "zv"+encode_ch c = encode_as_unicode_char c++encode_as_unicode_char :: Char -> EncodedString+encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str+ else '0':hex_str+ where hex_str = showHex (ord c) "U"+ -- ToDo: we could improve the encoding here in various ways.+ -- eg. strings of unicode characters come out as 'z1234Uz5678U', we+ -- could remove the 'U' in the middle (the 'z' works as a separator).++zDecodeString :: EncodedString -> UserString+zDecodeString [] = []+zDecodeString ('Z' : d : rest)+ | isDigit d = decode_tuple d rest+ | otherwise = decode_upper d : zDecodeString rest+zDecodeString ('z' : d : rest)+ | isDigit d = decode_num_esc d rest+ | otherwise = decode_lower d : zDecodeString rest+zDecodeString (c : rest) = c : zDecodeString rest++decode_upper, decode_lower :: Char -> Char++decode_upper 'L' = '('+decode_upper 'R' = ')'+decode_upper 'M' = '['+decode_upper 'N' = ']'+decode_upper 'C' = ':'+decode_upper 'Z' = 'Z'+decode_upper ch = {-pprTrace "decode_upper" (char ch)-} ch++decode_lower 'z' = 'z'+decode_lower 'a' = '&'+decode_lower 'b' = '|'+decode_lower 'c' = '^'+decode_lower 'd' = '$'+decode_lower 'e' = '='+decode_lower 'g' = '>'+decode_lower 'h' = '#'+decode_lower 'i' = '.'+decode_lower 'l' = '<'+decode_lower 'm' = '-'+decode_lower 'n' = '!'+decode_lower 'p' = '+'+decode_lower 'q' = '\''+decode_lower 'r' = '\\'+decode_lower 's' = '/'+decode_lower 't' = '*'+decode_lower 'u' = '_'+decode_lower 'v' = '%'+decode_lower ch = {-pprTrace "decode_lower" (char ch)-} ch++-- Characters not having a specific code are coded as z224U (in hex)+decode_num_esc :: Char -> EncodedString -> UserString+decode_num_esc d rest+ = go (digitToInt d) rest+ where+ go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest+ go n ('U' : rest) = chr n : zDecodeString rest+ go n other = error ("decode_num_esc: " ++ show n ++ ' ':other)++decode_tuple :: Char -> EncodedString -> UserString+decode_tuple d rest+ = go (digitToInt d) rest+ where+ -- NB. recurse back to zDecodeString after decoding the tuple, because+ -- the tuple might be embedded in a longer name.+ go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest+ go 0 ('T':rest) = "()" ++ zDecodeString rest+ go n ('T':rest) = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest+ go 1 ('H':rest) = "(# #)" ++ zDecodeString rest+ go n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest+ go n other = error ("decode_tuple: " ++ show n ++ ' ':other)++{-+Tuples are encoded as+ Z3T or Z3H+for 3-tuples or unboxed 3-tuples respectively. No other encoding starts+ Z<digit>++* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple)+ There are no unboxed 0-tuples.++* "()" is the tycon for a boxed 0-tuple.+ There are no boxed 1-tuples.+-}++maybe_tuple :: UserString -> Maybe EncodedString++maybe_tuple "(# #)" = Just("Z1H")+maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of+ (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")+ _ -> Nothing+maybe_tuple "()" = Just("Z0T")+maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of+ (n, ')' : _) -> Just ('Z' : shows (n+1) "T")+ _ -> Nothing+maybe_tuple _ = Nothing++count_commas :: Int -> String -> (Int, String)+count_commas n (',' : cs) = count_commas (n+1) cs+count_commas n cs = (n,cs)+++{-+************************************************************************+* *+ Base 62+* *+************************************************************************++Note [Base 62 encoding 128-bit integers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instead of base-62 encoding a single 128-bit integer+(ceil(21.49) characters), we'll base-62 a pair of 64-bit integers+(2 * ceil(10.75) characters). Luckily for us, it's the same number of+characters!+-}++--------------------------------------------------------------------------+-- Base 62++-- The base-62 code is based off of 'locators'+-- ((c) Operational Dynamics Consulting, BSD3 licensed)++-- | Size of a 64-bit word when written as a base-62 string+word64Base62Len :: Int+word64Base62Len = 11++-- | Converts a 64-bit word into a base-62 string+toBase62Padded :: Word64 -> String+toBase62Padded w = pad ++ str+ where+ pad = replicate len '0'+ len = word64Base62Len - length str -- 11 == ceil(64 / lg 62)+ str = toBase62 w++toBase62 :: Word64 -> String+toBase62 w = showIntAtBase 62 represent w ""+ where+ represent :: Int -> Char+ represent x+ | x < 10 = Char.chr (48 + x)+ | x < 36 = Char.chr (65 + x - 10)+ | x < 62 = Char.chr (97 + x - 36)+ | otherwise = error "represent (base 62): impossible!"