diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-10-15 17:55:34 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-10-29 03:53:52 -0400 |
| commit | 0e9f6defbdc1f691ff7197b21e68ac16ffa4ab59 (patch) | |
| tree | 1c9d9848db07596c19221fd195db81cdf6430385 | |
| parent | 795908dc4eab8e8b40cb318a2adbe4a4d4126c74 (diff) | |
| download | haskell-0e9f6defbdc1f691ff7197b21e68ac16ffa4ab59.tar.gz | |
Split GHC.Driver.Types
I was working on making DynFlags stateless (#17957), especially by
storing loaded plugins into HscEnv instead of DynFlags. It turned out to
be complicated because HscEnv is in GHC.Driver.Types but LoadedPlugin
isn't: it is in GHC.Driver.Plugins which depends on GHC.Driver.Types. I
didn't feel like introducing yet another hs-boot file to break the loop.
Additionally I remember that while we introduced the module hierarchy
(#13009) we talked about splitting GHC.Driver.Types because it contained
various unrelated types and functions, but we never executed. I didn't
feel like making GHC.Driver.Types bigger with more unrelated Plugins
related types, so finally I bit the bullet and split GHC.Driver.Types.
As a consequence this patch moves a lot of things. I've tried to put
them into appropriate modules but nothing is set in stone.
Several other things moved to avoid loops.
* Removed Binary instances from GHC.Utils.Binary for random compiler
things
* Moved Typeable Binary instances into GHC.Utils.Binary.Typeable: they
import a lot of things that users of GHC.Utils.Binary don't want to
depend on.
* put everything related to Units/Modules under GHC.Unit:
GHC.Unit.Finder, GHC.Unit.Module.{ModGuts,ModIface,Deps,etc.}
* Created several modules under GHC.Types: GHC.Types.Fixity, SourceText,
etc.
* Split GHC.Utils.Error (into GHC.Types.Error)
* Finally removed GHC.Driver.Types
Note that this patch doesn't put loaded plugins into HscEnv. It's left
for another patch.
Bump haddock submodule
205 files changed, 7237 insertions, 6117 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 19df839730..d9ebd356f2 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -264,6 +264,7 @@ module GHC ( -- * Exceptions GhcException(..), showGhcException, + GhcApiError(..), -- * Token stream manipulations Token, @@ -294,14 +295,14 @@ module GHC ( import GHC.Prelude hiding (init) -import GHC.ByteCode.Types -import GHC.Runtime.Eval -import GHC.Runtime.Eval.Types -import GHC.Runtime.Interpreter -import GHC.Runtime.Interpreter.Types -import GHCi.RemoteTypes +import GHC.Platform +import GHC.Platform.Ways -import GHC.Core.Ppr.TyThing ( pprFamInst ) +import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename + , isSourceFilename, startPhase ) +import GHC.Driver.Env +import GHC.Driver.CmdLine +import GHC.Driver.Session hiding (WarnReason(..)) import GHC.Driver.Backend import GHC.Driver.Config import GHC.Driver.Main @@ -309,19 +310,49 @@ import GHC.Driver.Make import GHC.Driver.Hooks import GHC.Driver.Pipeline ( compileOne' ) import GHC.Driver.Monad -import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) +import GHC.Driver.Ppr + +import GHC.ByteCode.Types +import GHC.Runtime.Eval +import GHC.Runtime.Eval.Types +import GHC.Runtime.Interpreter +import GHC.Runtime.Interpreter.Types +import GHC.Runtime.Context +import GHCi.RemoteTypes + +import qualified GHC.Parser as Parser +import GHC.Parser.Lexer +import GHC.Parser.Annotation +import GHC.Parser.Errors.Ppr + import GHC.Iface.Load ( loadSysInterface ) +import GHC.Hs +import GHC.Builtin.Types.Prim ( alphaTyVars ) +import GHC.Iface.Tidy +import GHC.Data.Bag ( listToBag ) +import GHC.Data.StringBuffer +import GHC.Data.FastString +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types +import GHC.Tc.Utils.TcType +import GHC.Tc.Module +import GHC.Tc.Utils.Instantiate +import GHC.Tc.Instance.Family + +import GHC.SysTools.FileCleanup +import GHC.SysTools +import GHC.SysTools.BaseDir + +import GHC.Utils.Error +import GHC.Utils.Monad +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + import GHC.Core.Predicate -import GHC.Unit -import GHC.Unit.State -import GHC.Types.Name.Set -import GHC.Types.Name.Reader -import GHC.Hs import GHC.Core.Type hiding( typeKind ) -import GHC.Tc.Utils.TcType -import GHC.Types.Id -import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Core.TyCon import GHC.Core.TyCo.Ppr ( pprForAll ) import GHC.Core.Class @@ -329,42 +360,37 @@ import GHC.Core.DataCon import GHC.Core.FVs ( orphNamesOfFamInst ) import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts ) import GHC.Core.InstEnv +import GHC.Core + +import GHC.Types.Id import GHC.Types.Name hiding ( varName ) import GHC.Types.Avail import GHC.Types.SrcLoc -import GHC.Core -import GHC.Iface.Tidy -import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename - , isSourceFilename, startPhase ) -import GHC.Driver.Finder -import GHC.Driver.Types -import GHC.Driver.CmdLine -import GHC.Driver.Session hiding (WarnReason(..)) -import GHC.Platform.Ways -import GHC.Driver.Ppr -import GHC.SysTools -import GHC.SysTools.BaseDir +import GHC.Types.TyThing.Ppr ( pprFamInst ) import GHC.Types.Annotations -import GHC.Utils.Panic -import GHC.Platform -import GHC.Data.Bag ( listToBag ) -import GHC.Utils.Error -import GHC.Utils.Monad -import GHC.Utils.Misc -import GHC.Data.StringBuffer -import GHC.Utils.Outputable +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.SourceError +import GHC.Types.SafeHaskell +import GHC.Types.Fixity +import GHC.Types.Target import GHC.Types.Basic -import GHC.Data.FastString -import qualified GHC.Parser as Parser -import GHC.Parser.Lexer -import GHC.Parser.Annotation -import GHC.Parser.Errors.Ppr -import qualified GHC.LanguageExtensions as LangExt +import GHC.Types.TyThing import GHC.Types.Name.Env -import GHC.Tc.Module -import GHC.Tc.Utils.Instantiate -import GHC.Tc.Instance.Family -import GHC.SysTools.FileCleanup +import GHC.Types.Name.Ppr +import GHC.Types.TypeEnv +import GHC.Types.SourceFile + +import GHC.Unit +import GHC.Unit.External +import GHC.Unit.State +import GHC.Unit.Finder +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Graph +import GHC.Unit.Home.ModInfo import Data.Foldable import qualified Data.Map.Strict as Map @@ -1507,7 +1533,7 @@ getModuleSourceAndFlags mod = do -- | Return module source as token stream, including comments. -- -- The module must be in the module graph and its source must be available. --- Throws a 'GHC.Driver.Types.SourceError' on parse error. +-- Throws a 'GHC.Driver.Env.SourceError' on parse error. getTokenStream :: GhcMonad m => Module -> m [Located Token] getTokenStream mod = do (sourceFile, source, dflags) <- getModuleSourceAndFlags mod @@ -1842,3 +1868,15 @@ interpretPackageEnv dflags = do "Package environment " ++ show env ++ " (specified in GHC_ENVIRONMENT) not found" + +-- | 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 + +mkApiErr :: DynFlags -> SDoc -> GhcApiError +mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) + diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs index 8ed04097f7..4ad8652922 100644 --- a/compiler/GHC/Builtin/PrimOps.hs +++ b/compiler/GHC/Builtin/PrimOps.hs @@ -39,10 +39,11 @@ import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS ) 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.Types ( Unit ) diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 771db90d85..52febf72d2 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -164,13 +164,15 @@ import GHC.Builtin.Uniques -- 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 diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs index 1b3d22fc21..fc74596e45 100644 --- a/compiler/GHC/Builtin/Types/Prim.hs +++ b/compiler/GHC/Builtin/Types/Prim.hs @@ -115,6 +115,7 @@ import {-# SOURCE #-} GHC.Builtin.Types 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 @@ -199,14 +200,14 @@ mkPrimTc :: FastString -> Unique -> TyCon -> Name 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 @@ -547,7 +548,7 @@ mkPrimTyConName = mkPrimTcName BuiltInSyntax 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. diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs index 3aeac609d9..1d69b47f37 100644 --- a/compiler/GHC/Builtin/Utils.hs +++ b/compiler/GHC/Builtin/Utils.hs @@ -50,31 +50,34 @@ module GHC.Builtin.Utils ( import GHC.Prelude import GHC.Builtin.Uniques -import GHC.Types.Unique ( isValidKnownKeyUnique ) - -import GHC.Core.ConLike ( ConLike(..) ) +import GHC.Builtin.PrimOps +import GHC.Builtin.Types +import GHC.Builtin.Types.Literals ( typeNatTyCons ) +import GHC.Builtin.Types.Prim import GHC.Builtin.Names.TH ( templateHaskellNames ) import GHC.Builtin.Names + +import GHC.Core.ConLike ( ConLike(..) ) import GHC.Core.Opt.ConstantFold -import GHC.Types.Avail -import GHC.Builtin.PrimOps import GHC.Core.DataCon +import GHC.Core.Class +import GHC.Core.TyCon + +import GHC.Types.Avail import GHC.Types.Basic import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Id.Make -import GHC.Utils.Outputable -import GHC.Builtin.Types.Prim -import GHC.Builtin.Types -import GHC.Driver.Types -import GHC.Core.Class -import GHC.Core.TyCon import GHC.Types.Unique.FM +import GHC.Types.TyThing +import GHC.Types.Unique ( isValidKnownKeyUnique ) + +import GHC.Utils.Outputable import GHC.Utils.Misc as Utils import GHC.Utils.Panic -import GHC.Builtin.Types.Literals ( typeNatTyCons ) import GHC.Hs.Doc +import GHC.Unit.Module.ModIface (IfaceExport) import Control.Applicative ((<|>)) import Data.List ( intercalate , find ) diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs index c344823ccb..92255f9ea0 100644 --- a/compiler/GHC/ByteCode/Asm.hs +++ b/compiler/GHC/ByteCode/Asm.hs @@ -19,27 +19,30 @@ module GHC.ByteCode.Asm ( import GHC.Prelude +import GHC.Driver.Env +import GHC.Driver.Session + import GHC.ByteCode.Instr import GHC.ByteCode.InfoTable import GHC.ByteCode.Types import GHCi.RemoteTypes import GHC.Runtime.Interpreter +import GHC.Runtime.Heap.Layout -import GHC.Driver.Types import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Literal +import GHC.Types.Unique +import GHC.Types.Unique.DSet + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + import GHC.Core.TyCon import GHC.Data.FastString import GHC.StgToCmm.Layout ( ArgRep(..) ) -import GHC.Runtime.Heap.Layout -import GHC.Driver.Session -import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Platform -import GHC.Utils.Misc -import GHC.Types.Unique -import GHC.Types.Unique.DSet -- From iserv import SizedSeq diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs index 567209adda..594a68c12b 100644 --- a/compiler/GHC/ByteCode/InfoTable.hs +++ b/compiler/GHC/ByteCode/InfoTable.hs @@ -12,21 +12,26 @@ module GHC.ByteCode.InfoTable ( mkITbls ) where import GHC.Prelude +import GHC.Driver.Session +import GHC.Driver.Env + import GHC.Platform import GHC.Platform.Profile import GHC.ByteCode.Types import GHC.Runtime.Interpreter -import GHC.Driver.Session -import GHC.Driver.Types + import GHC.Types.Name ( Name, getName ) import GHC.Types.Name.Env +import GHC.Types.RepType + import GHC.Core.DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import GHC.Core.Multiplicity ( scaledThing ) -import GHC.Types.RepType + import GHC.StgToCmm.Layout ( mkVirtConstrSizes ) import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) ) + import GHC.Utils.Misc import GHC.Utils.Panic diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs index a158886369..7b532b96d5 100644 --- a/compiler/GHC/ByteCode/Linker.hs +++ b/compiler/GHC/ByteCode/Linker.hs @@ -19,24 +19,29 @@ module GHC.ByteCode.Linker ( import GHC.Prelude +import GHC.Driver.Env + +import GHC.Runtime.Interpreter +import GHC.ByteCode.Types import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray import SizedSeq -import GHC.Runtime.Interpreter -import GHC.ByteCode.Types -import GHC.Driver.Types -import GHC.Types.Name -import GHC.Types.Name.Env import GHC.Builtin.PrimOps + import GHC.Unit.Types import GHC.Unit.Module.Name + import GHC.Data.FastString + import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Types.Name +import GHC.Types.Name.Env + -- Standard libraries import Data.Array.Unboxed import Foreign.Ptr diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index f5cf20a6b6..d408402e27 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -24,7 +24,7 @@ import GHC.Types.Unique.Supply import GHC.Driver.Session import GHC.Driver.Backend import GHC.Utils.Error -import GHC.Driver.Types +import GHC.Driver.Env import Control.Monad import GHC.Utils.Outputable import GHC.Platform diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index c99182f978..a6c1c282ab 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -968,7 +968,7 @@ data Tickish id = { 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". diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs index 3221eab4b2..ae7ae8971f 100644 --- a/compiler/GHC/Core/Coercion/Axiom.hs +++ b/compiler/GHC/Core/Coercion/Axiom.hs @@ -385,7 +385,7 @@ giving rise to the FamInstBranch. 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 diff --git a/compiler/GHC/Core/ConLike.hs-boot b/compiler/GHC/Core/ConLike.hs-boot deleted file mode 100644 index 0a6e732d88..0000000000 --- a/compiler/GHC/Core/ConLike.hs-boot +++ /dev/null @@ -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 diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index 542fea4e1e..adbdc144c3 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -73,7 +73,9 @@ import GHC.Core.Coercion 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 @@ -674,7 +676,7 @@ data DataConRep -- 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 @@ -1194,11 +1196,11 @@ dataConWrapId dc = case dcRep dc of -- 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] diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 1331602c08..0744d512f3 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -226,7 +226,7 @@ instance Outputable FamInst where 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" diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 0a1d5d0ddb..6fdcb02c8c 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -27,6 +27,10 @@ module GHC.Core.Lint ( 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 @@ -73,10 +77,10 @@ import GHC.Core.InstEnv ( instanceDFunId ) 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 ) @@ -437,7 +441,7 @@ lintInteractiveExpr what hsc_env expr 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 diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index ca054263b4..2ce1f2c870 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -55,37 +55,39 @@ module GHC.Core.Make ( #include "HsVersions.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` diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs index d539e4f386..bc98f764c7 100644 --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -23,20 +23,24 @@ module GHC.Core.Opt.FloatIn ( floatInwards ) where import GHC.Prelude import GHC.Platform +import GHC.Driver.Session + import GHC.Core import GHC.Core.Make hiding ( wrapFloats ) -import GHC.Driver.Types ( ModGuts(..) ) import GHC.Core.Utils import GHC.Core.FVs -import GHC.Core.Opt.Monad ( CoreM ) +import GHC.Core.Opt.Monad ( CoreM ) +import GHC.Core.Type + +import GHC.Types.Basic ( RecFlag(..), isRec ) import GHC.Types.Id ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) import GHC.Types.Var -import GHC.Core.Type import GHC.Types.Var.Set + +import GHC.Unit.Module.ModGuts + import GHC.Utils.Misc -import GHC.Driver.Session import GHC.Utils.Panic -import GHC.Types.Basic ( RecFlag(..), isRec ) {- Top-level interface function, @floatInwards@. Note that we do not diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index e7298fef54..c535c24638 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -50,27 +50,34 @@ module GHC.Core.Opt.Monad ( 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 Data.Bifunctor ( bimap ) + +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Error( Severity(..), DumpFormat (..), dumpOptionsFromFlag ) +import GHC.Utils.Monad import GHC.Utils.Error (dumpAction) + +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 Data.List (intersperse, groupBy, sortBy) import Data.Ord import Data.Dynamic diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 3e9470dc88..041fdf3a29 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -14,15 +14,16 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) +import GHC.Driver.Env + import GHC.Core -import GHC.Driver.Types import GHC.Core.Opt.CSE ( cseProgram ) import GHC.Core.Rules ( mkRuleBase, unionRuleBase, extendRuleBaseList, ruleCheckProgram, addRuleInfo, getRules, initRuleOpts ) import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) -import GHC.Types.Id.Info import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) import GHC.Core.Utils ( mkTicks, stripTicksTop, dumpIdInfoOfProgram ) import GHC.Core.Lint ( endPass, lintPassResult, dumpPassResult, @@ -32,16 +33,8 @@ import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfoldin import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Monad -import qualified GHC.Utils.Error as Err -import GHC.Core.Opt.FloatIn ( floatInwards ) -import GHC.Core.Opt.FloatOut ( floatOutwards ) -import GHC.Core.FamInstEnv -import GHC.Types.Id -import GHC.Utils.Error ( withTiming, withTimingD, DumpFormat (..) ) -import GHC.Types.Basic -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Types.Demand +import GHC.Core.Opt.FloatIn ( floatInwards ) +import GHC.Core.Opt.FloatOut ( floatOutwards ) import GHC.Core.Opt.LiberateCase ( liberateCase ) import GHC.Core.Opt.StaticArgs ( doStaticArgs ) import GHC.Core.Opt.Specialise ( specProgram) @@ -52,16 +45,33 @@ import GHC.Core.Opt.CallArity ( callArityAnalProgram ) import GHC.Core.Opt.Exitify ( exitifyProgram ) import GHC.Core.Opt.WorkWrap ( wwTopBinds ) import GHC.Core.Seq (seqBinds) -import GHC.Types.SrcLoc +import GHC.Core.FamInstEnv + +import qualified GHC.Utils.Error as Err +import GHC.Utils.Error ( withTiming, withTimingD, DumpFormat (..) ) import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Unit.External import GHC.Unit.Module.Env -import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.Deps + import GHC.Runtime.Loader -- ( initializePlugins ) +import GHC.Runtime.Context +import GHC.Types.SrcLoc +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Basic +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Demand import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import GHC.Types.Unique.FM -import GHC.Utils.Outputable -import GHC.Utils.Panic +import GHC.Types.Name.Ppr + import Control.Monad import qualified GHC.LanguageExtensions as LangExt {- diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 4ba4b0a797..42cc081498 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -25,6 +25,7 @@ import GHC.Core.Opt.Simplify.Utils import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Core.FamInstEnv ( FamInstEnv ) import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326 +import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.Id.Make ( seqId ) import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index ab36ad8f22..d3ee317234 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -25,7 +25,7 @@ import GHC.Core.Unfold import GHC.Core.FVs ( exprsFreeVarsList ) import GHC.Core.Opt.Monad import GHC.Types.Literal ( litIsLifted ) -import GHC.Driver.Types ( ModGuts(..) ) +import GHC.Unit.Module.ModGuts import GHC.Core.Opt.WorkWrap.Utils ( isWorkerSmallEnough, mkWorkerArgs ) import GHC.Core.DataCon import GHC.Core.Coercion hiding( substCo ) diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 14a1e0cda9..2fa9e9b18c 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -14,44 +14,53 @@ module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where import GHC.Prelude -import GHC.Types.Id +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Driver.Config +import GHC.Driver.Env + import GHC.Tc.Utils.TcType hiding( substTy ) + import GHC.Core.Type hiding( substTy, extendTvSubstList ) import GHC.Core.Multiplicity import GHC.Core.Predicate -import GHC.Unit.Module( Module ) import GHC.Core.Coercion( Coercion ) import GHC.Core.Opt.Monad import qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make -import GHC.Types.Var ( isLocalVar ) -import GHC.Types.Var.Set -import GHC.Types.Var.Env import GHC.Core import GHC.Core.Rules import GHC.Core.Utils ( exprIsTrivial, getIdFromTrivialExpr_maybe , mkCast, exprType ) import GHC.Core.FVs +import GHC.Core.TyCo.Rep (TyCoBinder (..)) import GHC.Core.Opt.Arity ( collectBindersPushingCo , etaExpandToJoinPointRule ) + +import GHC.Builtin.Types ( unboxedUnitTy ) + +import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust ) +import GHC.Data.Bag +import GHC.Data.FastString + +import GHC.Types.Basic import GHC.Types.Unique.Supply +import GHC.Types.Unique.DFM import GHC.Types.Name import GHC.Types.Id.Make ( voidArgId, voidPrimId ) -import GHC.Builtin.Types ( unboxedUnitTy ) -import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust ) +import GHC.Types.Var ( isLocalVar ) +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Id + import GHC.Utils.Monad ( foldlM ) -import GHC.Types.Basic -import GHC.Driver.Types -import GHC.Data.Bag -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Driver.Config import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Data.FastString -import GHC.Types.Unique.DFM -import GHC.Core.TyCo.Rep (TyCoBinder (..)) + +import GHC.Unit.Module( Module ) +import GHC.Unit.Module.ModGuts +import GHC.Unit.External {- ************************************************************************ diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 4994875772..842a4981d1 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -26,6 +26,7 @@ import GHC.Driver.Ppr import GHC.Driver.Config import GHC.Types.Demand import GHC.Types.Cpr +import GHC.Types.SourceText import GHC.Core.Opt.WorkWrap.Utils import GHC.Utils.Misc import GHC.Utils.Outputable diff --git a/compiler/GHC/Core/PatSyn.hs-boot b/compiler/GHC/Core/PatSyn.hs-boot deleted file mode 100644 index d4f816d13d..0000000000 --- a/compiler/GHC/Core/PatSyn.hs-boot +++ /dev/null @@ -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 diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs index dcfb9f2557..0a14150ed7 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -22,9 +22,6 @@ module GHC.Core.TyCo.Ppr pprCo, pprParendCo, debugPprType, - - -- * Pretty-printing 'TyThing's - pprTyThingCategory, pprShortTyThing, ) where import GHC.Prelude @@ -79,7 +76,7 @@ See Note [Precedence in types] in GHC.Types.Basic. -------------------------------------------------------- -- When pretty-printing types, we convert to IfaceType, -- and pretty-print that. --- See Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing +-- See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr -------------------------------------------------------- pprType, pprParendType, pprTidiedType :: Type -> SDoc diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index 4b81a39d75..87b943f790 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -24,7 +24,6 @@ Note [The Type-related module hierarchy] -- We expose the relevant stuff from this module via the Type module module GHC.Core.TyCo.Rep ( - TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, -- * Types Type(..), @@ -83,13 +82,10 @@ import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit ) -- 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 @@ -107,66 +103,6 @@ import GHC.Utils.Panic 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 diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot index 7bc1eb4f81..cb675327b7 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs-boot +++ b/compiler/GHC/Core/TyCo/Rep.hs-boot @@ -5,7 +5,6 @@ import Data.Data ( Data ) import {-# SOURCE #-} GHC.Types.Var( Var, ArgFlag, AnonArgFlag ) data Type -data TyThing data Coercion data UnivCoProvenance data TyLit diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 626fa55b46..68b73b589b 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -15,7 +15,7 @@ module GHC.Core.Type ( -- $type_classification -- $representation_types - TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), + Type, ArgFlag(..), AnonArgFlag(..), Specificity(..), KindOrType, PredType, ThetaType, Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index 8043ccaef9..f8cb9737d9 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -17,6 +17,9 @@ module GHC.CoreToByteCode ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where import GHC.Prelude +import GHC.Driver.Session +import GHC.Driver.Env + import GHC.ByteCode.Instr import GHC.ByteCode.Asm import GHC.ByteCode.Types @@ -28,13 +31,11 @@ import GHC.Runtime.Interpreter import GHCi.FFI import GHCi.RemoteTypes import GHC.Types.Basic -import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Types.Name import GHC.Types.Id.Make import GHC.Types.Id import GHC.Types.ForeignCall -import GHC.Driver.Types import GHC.Core.Utils import GHC.Core import GHC.Core.Ppr diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 05430a5658..f290ca9545 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -20,14 +20,20 @@ where #include "HsVersions.h" import GHC.Prelude -import GHC.Platform -import GHC.Core.Opt.OccurAnal +import GHC.Platform +import GHC.Platform.Ways -import GHC.Driver.Types +import GHC.Driver.Session +import GHC.Driver.Env import GHC.Driver.Ppr + +import GHC.Tc.Utils.Env +import GHC.Unit + import GHC.Builtin.Names -import GHC.Types.Id.Make ( realWorldPrimId ) +import GHC.Builtin.Types + import GHC.Core.Utils import GHC.Core.Opt.Arity import GHC.Core.FVs @@ -36,37 +42,39 @@ import GHC.Core.Lint ( endPassIO ) import GHC.Core import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here import GHC.Core.Type -import GHC.Types.Literal import GHC.Core.Coercion -import GHC.Tc.Utils.Env import GHC.Core.TyCon -import GHC.Types.Demand -import GHC.Types.Var -import GHC.Types.Var.Set -import GHC.Types.Var.Env -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Builtin.Types import GHC.Core.DataCon -import GHC.Types.Basic -import GHC.Unit -import GHC.Types.Unique.Supply +import GHC.Core.Opt.OccurAnal + import GHC.Data.Maybe import GHC.Data.OrdList +import GHC.Data.FastString + import GHC.Utils.Error -import GHC.Driver.Session -import GHC.Platform.Ways import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable -import GHC.Data.FastString +import GHC.Utils.Monad ( mapAccumLM ) + +import GHC.Types.Demand +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Id.Make ( realWorldPrimId ) +import GHC.Types.Basic import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) +import GHC.Types.Literal +import GHC.Types.TyThing +import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) +import GHC.Types.Unique.Supply + import Data.Bits -import GHC.Utils.Monad ( mapAccumLM ) import Data.List ( unfoldr ) import Control.Monad -import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) import qualified Data.Set as S {- diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index cd9cb8672b..54961066d8 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -23,43 +23,54 @@ import GHC.Prelude -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax - -import GHC.Parser.Annotation -import GHC.Parser.Errors.Ppr -import GHC hiding (Failed, Succeeded) -import GHC.Parser -import GHC.Parser.Lexer import GHC.Driver.Config import GHC.Driver.Monad import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Driver.Main +import GHC.Driver.Make +import GHC.Driver.Env + +import GHC.Parser +import GHC.Parser.Header +import GHC.Parser.Lexer +import GHC.Parser.Annotation +import GHC.Parser.Errors.Ppr + +import GHC hiding (Failed, Succeeded) import GHC.Tc.Utils.Monad -import GHC.Tc.Module -import GHC.Unit -import GHC.Unit.State -import GHC.Driver.Types -import GHC.Data.StringBuffer -import GHC.Data.FastString -import qualified GHC.Data.ShortText as ST -import GHC.Utils.Error +import GHC.Iface.Recomp +import GHC.Builtin.Names + import GHC.Types.SrcLoc -import GHC.Driver.Main +import GHC.Types.SourceError +import GHC.Types.SourceText +import GHC.Types.SourceFile import GHC.Types.Unique.FM import GHC.Types.Unique.DFM -import GHC.Utils.Outputable -import GHC.Data.Maybe -import GHC.Parser.Header -import GHC.Iface.Recomp -import GHC.Driver.Make import GHC.Types.Unique.DSet -import GHC.Builtin.Names -import GHC.Types.Basic hiding (SuccessFlag(..)) -import GHC.Driver.Finder + +import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Utils.Panic +import GHC.Utils.Error + +import GHC.Unit +import GHC.Unit.External +import GHC.Unit.State +import GHC.Unit.Finder +import GHC.Unit.Module.ModSummary (showModMsg) +import GHC.Unit.Home.ModInfo + +import GHC.Runtime.Linker.Types import qualified GHC.LanguageExtensions as LangExt -import GHC.Utils.Panic +import GHC.Data.Maybe +import GHC.Data.StringBuffer +import GHC.Data.FastString +import qualified GHC.Data.ShortText as ST + import Data.List ( partition ) import System.Exit import Control.Monad diff --git a/compiler/GHC/Driver/Backpack/Syntax.hs b/compiler/GHC/Driver/Backpack/Syntax.hs index e7e73b6cae..edaf5200d3 100644 --- a/compiler/GHC/Driver/Backpack/Syntax.hs +++ b/compiler/GHC/Driver/Backpack/Syntax.hs @@ -18,14 +18,17 @@ module GHC.Driver.Backpack.Syntax ( import GHC.Prelude -import GHC.Driver.Phases import GHC.Hs + import GHC.Types.SrcLoc -import GHC.Utils.Outputable +import GHC.Types.SourceFile + import GHC.Unit.Module.Name import GHC.Unit.Types import GHC.Unit.Info +import GHC.Utils.Outputable + {- ************************************************************************ * * diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index cee81b900e..f9912ee303 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -17,33 +17,38 @@ where import GHC.Prelude import GHC.Platform +import GHC.ForeignSrcLang import GHC.CmmToAsm ( nativeCodeGen ) import GHC.CmmToLlvm ( llvmCodeGen ) -import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) - -import GHC.Driver.Finder ( mkStubPaths ) -import GHC.Driver.Backend import GHC.CmmToC ( cmmToC ) import GHC.Cmm.Lint ( cmmLint ) import GHC.Cmm ( RawCmmGroup ) import GHC.Cmm.CLabel -import GHC.Driver.Types + import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Driver.Backend + import qualified GHC.Data.ShortText as ST import GHC.Data.Stream ( Stream ) import qualified GHC.Data.Stream as Stream + import GHC.SysTools.FileCleanup import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic + import GHC.Unit import GHC.Unit.State +import GHC.Unit.Finder ( mkStubPaths ) + import GHC.Types.SrcLoc import GHC.Types.CostCentre +import GHC.Types.ForeignStubs +import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) import Control.Exception import System.Directory diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs new file mode 100644 index 0000000000..324177ac0f --- /dev/null +++ b/compiler/GHC/Driver/Env.hs @@ -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 "HsVersions.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. + diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs index 36b97502cb..25e6530eef 100644 --- a/compiler/GHC/Driver/Hooks.hs +++ b/compiler/GHC/Driver/Hooks.hs @@ -31,34 +31,46 @@ where 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 {- ************************************************************************ diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 827855a519..143b1f5ccd 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -88,88 +88,127 @@ module GHC.Driver.Main import GHC.Prelude -import Data.Data hiding (Fixity, TyCon) -import Data.Maybe ( fromJust ) -import GHC.Types.Id +import GHC.Driver.Plugins +import GHC.Driver.Session +import GHC.Driver.Backend +import GHC.Driver.Env +import GHC.Driver.CodeOutput +import GHC.Driver.Config +import GHC.Driver.Hooks + +import GHC.Runtime.Context +import GHC.Runtime.Linker +import GHC.Runtime.Linker.Types import GHC.Runtime.Interpreter ( addSptEntry ) +import GHC.Runtime.Loader ( initializePlugins ) import GHCi.RemoteTypes ( ForeignHValue ) +import GHC.ByteCode.Types + +import GHC.Hs +import GHC.Hs.Dump +import GHC.Hs.Stats ( ppSourceStats ) + +import GHC.HsToCore + import GHC.CoreToByteCode ( byteCodeGen, coreExprToBCOs ) -import GHC.Runtime.Linker + +import GHC.IfaceToCore ( typecheckIface ) + +import GHC.Iface.Load ( ifaceStats, initExternalPackageState, writeIface ) +import GHC.Iface.Make +import GHC.Iface.Recomp +import GHC.Iface.Tidy +import GHC.Iface.Ext.Ast ( mkHieFile ) +import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module ) +import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..)) +import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) +import GHC.Iface.Env ( updNameCache ) + +import GHC.Core import GHC.Core.Tidy ( tidyExpr ) import GHC.Core.Type ( Type, Kind ) import GHC.Core.Lint ( lintInteractiveExpr ) -import GHC.Types.Var.Env ( emptyTidyEnv ) -import GHC.Utils.Panic import GHC.Core.ConLike +import GHC.Core.Opt.Pipeline +import GHC.Core.TyCon +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv + +import GHC.CoreToStg.Prep +import GHC.CoreToStg ( coreToStg ) import GHC.Parser.Annotation import GHC.Parser.Errors import GHC.Parser.Errors.Ppr -import GHC.Unit -import GHC.Unit.State -import GHC.Types.Name.Reader -import GHC.Hs -import GHC.Hs.Dump -import GHC.Core -import GHC.Data.StringBuffer import GHC.Parser import GHC.Parser.Lexer as Lexer -import GHC.Types.SrcLoc + import GHC.Tc.Module -import GHC.IfaceToCore ( typecheckIface ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) ) -import GHC.Types.Name.Cache ( initNameCache ) -import GHC.Builtin.Utils -import GHC.Core.Opt.Pipeline -import GHC.HsToCore -import GHC.Iface.Load ( ifaceStats, initExternalPackageState, writeIface ) -import GHC.Iface.Make -import GHC.Iface.Recomp -import GHC.Iface.Tidy -import GHC.CoreToStg.Prep -import GHC.CoreToStg ( coreToStg ) + import GHC.Stg.Syntax import GHC.Stg.FVs ( annTopBindingsFreeVars ) import GHC.Stg.Pipeline ( stg2stg ) + +import GHC.Builtin.Utils +import GHC.Builtin.Names + import qualified GHC.StgToCmm as StgToCmm ( codeGen ) -import GHC.Types.CostCentre -import GHC.Core.TyCon -import GHC.Types.Name +import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos) + import GHC.Cmm import GHC.Cmm.Parser ( parseCmmFile ) import GHC.Cmm.Info.Build import GHC.Cmm.Pipeline import GHC.Cmm.Info -import GHC.Driver.CodeOutput -import GHC.Driver.Config -import GHC.Core.InstEnv -import GHC.Core.FamInstEnv -import GHC.Utils.Fingerprint ( Fingerprint ) -import GHC.Driver.Hooks -import GHC.Tc.Utils.Env -import GHC.Builtin.Names -import GHC.Driver.Plugins -import GHC.Runtime.Loader ( initializePlugins ) -import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos) -import GHC.Driver.Session -import GHC.Driver.Backend -import GHC.Utils.Error +import GHC.Unit +import GHC.Unit.External +import GHC.Unit.State +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Graph +import GHC.Unit.Module.Imported +import GHC.Unit.Module.Deps +import GHC.Unit.Module.Status +import GHC.Unit.Home.ModInfo -import GHC.Utils.Outputable +import GHC.Types.Id +import GHC.Types.SourceError +import GHC.Types.SafeHaskell +import GHC.Types.ForeignStubs +import GHC.Types.Var.Env ( emptyTidyEnv ) +import GHC.Types.Fixity.Env +import GHC.Types.CostCentre +import GHC.Types.Unique.Supply +import GHC.Types.SourceFile +import GHC.Types.SrcLoc +import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Hs.Stats ( ppSourceStats ) -import GHC.Driver.Types +import GHC.Types.Name.Cache ( initNameCache ) +import GHC.Types.Name.Reader +import GHC.Types.Name.Ppr +import GHC.Types.TyThing +import GHC.Types.HpcInfo + +import GHC.Utils.Fingerprint ( Fingerprint ) +import GHC.Utils.Panic +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Exception +import GHC.Utils.Misc + import GHC.Data.FastString -import GHC.Types.Unique.Supply import GHC.Data.Bag -import GHC.Utils.Exception +import GHC.Data.StringBuffer import qualified GHC.Data.Stream as Stream import GHC.Data.Stream (Stream) -import GHC.Utils.Misc - +import Data.Data hiding (Fixity, TyCon) +import Data.Maybe ( fromJust ) import Data.List ( nub, isPrefixOf, partition ) import Control.Monad import Data.IORef @@ -183,11 +222,6 @@ import Data.Functor import Control.DeepSeq (force) import Data.Bifunctor (first, bimap) -import GHC.Iface.Ext.Ast ( mkHieFile ) -import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module ) -import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..)) -import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) - #include "HsVersions.h" @@ -1639,7 +1673,7 @@ you run it you get a list of HValues that should be the same length as the list of names; add them to the ClosureEnv. A naked expression returns a singleton Name [it]. The stmt is lifted into the -IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types +IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context -} -- | Compile a stmt all the way to an HValue, but don't run it @@ -1781,7 +1815,7 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do -- We only need to keep around the external bindings -- (as decided by GHC.Iface.Tidy), since those are the only ones -- that might later be looked up by name. But we can exclude - -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Driver.Types + -- - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context -- - Implicit Ids, which are implicit in tcs -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 5c955749a3..5023eacdc7 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -35,45 +35,62 @@ module GHC.Driver.Make ( import GHC.Prelude +import GHC.Tc.Utils.Backpack + import qualified GHC.Runtime.Linker as Linker +import GHC.Runtime.Linker.Types +import GHC.Runtime.Context import GHC.Driver.Config import GHC.Driver.Phases import GHC.Driver.Pipeline import GHC.Driver.Session import GHC.Driver.Backend -import GHC.Utils.Error -import GHC.Driver.Finder import GHC.Driver.Monad +import GHC.Driver.Env +import GHC.Driver.Main + import GHC.Parser.Header import GHC.Parser.Errors.Ppr -import GHC.Driver.Types -import GHC.Unit -import GHC.Unit.State + +import GHC.Utils.Error import GHC.IfaceToCore ( typecheckIface ) import GHC.Tc.Utils.Monad ( initIfaceCheck ) -import GHC.Driver.Main import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag ) -import GHC.Types.Basic import GHC.Data.Graph.Directed -import GHC.Utils.Exception ( tryIO ) import GHC.Data.FastString import GHC.Data.Maybe ( expectJust ) -import GHC.Types.Name +import GHC.Data.StringBuffer +import qualified GHC.LanguageExtensions as LangExt +import GHC.SysTools.FileCleanup + +import GHC.Utils.Exception ( tryIO ) import GHC.Utils.Monad ( allM ) import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Types.Basic +import GHC.Types.Target +import GHC.Types.SourceFile +import GHC.Types.SourceError import GHC.Types.SrcLoc -import GHC.Data.StringBuffer import GHC.Types.Unique.FM import GHC.Types.Unique.DSet -import GHC.Tc.Utils.Backpack import GHC.Types.Unique.Set -import GHC.Utils.Misc -import qualified GHC.LanguageExtensions as LangExt +import GHC.Types.Name import GHC.Types.Name.Env -import GHC.SysTools.FileCleanup + +import GHC.Unit +import GHC.Unit.External +import GHC.Unit.State +import GHC.Unit.Finder +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.Graph +import GHC.Unit.Home.ModInfo import Data.Either ( rights, partitionEithers ) import qualified Data.Map as Map diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index a393bdbba4..81408ab7c9 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -22,18 +22,22 @@ import GHC.Driver.Monad import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Utils.Misc -import GHC.Driver.Types +import GHC.Driver.Env import qualified GHC.SysTools as SysTools -import GHC.Unit.Module import GHC.Data.Graph.Directed ( SCC(..) ) -import GHC.Driver.Finder import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Types.SourceError import GHC.Types.SrcLoc import Data.List import GHC.Data.FastString import GHC.SysTools.FileCleanup +import GHC.Unit.Module +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Graph +import GHC.Unit.Finder + import GHC.Utils.Exception import GHC.Utils.Error diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs index 72dc3b9800..4787574465 100644 --- a/compiler/GHC/Driver/Monad.hs +++ b/compiler/GHC/Driver/Monad.hs @@ -25,12 +25,15 @@ module GHC.Driver.Monad ( 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 import Control.Monad.Trans.Reader diff --git a/compiler/GHC/Driver/Phases.hs b/compiler/GHC/Driver/Phases.hs index 4892b20c60..40aa2055c3 100644 --- a/compiler/GHC/Driver/Phases.hs +++ b/compiler/GHC/Driver/Phases.hs @@ -9,7 +9,6 @@ ----------------------------------------------------------------------------- module GHC.Driver.Phases ( - HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, Phase(..), happensBefore, eqPhase, anyHsc, isStopLn, startPhase, @@ -34,20 +33,27 @@ module GHC.Driver.Phases ( isCishFilename, isDynLibFilename, isHaskellUserSrcFilename, - isSourceFilename + isSourceFilename, + + phaseForeignLanguage ) where #include "HsVersions.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 @@ import GHC.Utils.Misc 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 @@ isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f) 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 + diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 7ca219bc48..5428c83b99 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -39,46 +39,67 @@ module GHC.Driver.Pipeline ( import GHC.Prelude +import GHC.Platform + +import GHC.Tc.Types + +import GHC.Driver.Main +import GHC.Driver.Env hiding ( Hsc ) import GHC.Driver.Pipeline.Monad -import GHC.Unit -import GHC.Unit.State +import GHC.Driver.Config +import GHC.Driver.Phases +import GHC.Driver.Session +import GHC.Driver.Backend +import GHC.Driver.Ppr +import GHC.Driver.Hooks + import GHC.Platform.Ways import GHC.Platform.ArchOS -import GHC.Driver.Config + import GHC.Parser.Header import GHC.Parser.Errors.Ppr -import GHC.Driver.Phases + import GHC.SysTools import GHC.SysTools.ExtraObj -import GHC.Driver.Main -import GHC.Driver.Finder -import GHC.Driver.Types hiding ( Hsc ) +import GHC.SysTools.FileCleanup +import GHC.SysTools.Ar + import GHC.Utils.Outputable import GHC.Utils.Error -import GHC.Driver.Session -import GHC.Driver.Backend -import GHC.Driver.Ppr import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer ) -import GHC.Types.Basic ( SuccessFlag(..) ) -import GHC.Data.Maybe ( expectJust ) -import GHC.Types.SrcLoc -import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) import GHC.Utils.Monad -import GHC.Platform -import GHC.Tc.Types -import GHC.Driver.Hooks +import GHC.Utils.Exception as Exception + +import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) import qualified GHC.LanguageExtensions as LangExt -import GHC.SysTools.FileCleanup -import GHC.SysTools.Ar import GHC.Settings -import GHC.Data.Bag ( unitBag ) -import GHC.Data.FastString ( mkFastString ) -import GHC.Iface.Make ( mkFullIface ) -import GHC.Iface.UpdateIdInfos ( updateModDetailsIdInfos ) +import GHC.Runtime.Linker.Types + +import GHC.Data.Bag ( unitBag ) +import GHC.Data.FastString ( mkFastString ) +import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer ) +import GHC.Data.Maybe ( expectJust ) + +import GHC.Iface.Make ( mkFullIface ) +import GHC.Iface.UpdateIdInfos ( updateModDetailsIdInfos ) + +import GHC.Types.Basic ( SuccessFlag(..) ) +import GHC.Types.Target +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +import GHC.Types.SourceError + +import GHC.Unit +import GHC.Unit.State +import GHC.Unit.Finder +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Graph (needsTemplateHaskellOrQQ) +import GHC.Unit.Module.Deps +import GHC.Unit.Home.ModInfo -import GHC.Utils.Exception as Exception import System.Directory import System.FilePath import System.IO @@ -594,7 +615,7 @@ findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath) findHSLib dflags dirs lib = do let batch_lib_file = if WayDyn `notElem` ways dflags then "lib" ++ lib <.> "a" - else mkSOName (targetPlatform dflags) lib + else platformSOName (targetPlatform dflags) lib found <- filterM doesFileExist (map (</> batch_lib_file) dirs) case found of [] -> return Nothing diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs index 2fcf24e85d..b2db6170ec 100644 --- a/compiler/GHC/Driver/Pipeline/Monad.hs +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -14,12 +14,20 @@ import GHC.Prelude 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 newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs index 6d6a976856..3436cc34a6 100644 --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -49,20 +49,26 @@ module GHC.Driver.Plugins ( 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.<> import qualified Data.Semigroup diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index ccc7d2b8a3..20fd137ea7 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -69,7 +69,6 @@ module GHC.Driver.Session ( putLogMsg, -- ** Safe Haskell - SafeHaskellMode(..), safeHaskellOn, safeHaskellModeEnabled, safeImportsOn, safeLanguageOn, safeInferOn, packageTrustOn, @@ -257,6 +256,7 @@ import GHC.Data.Maybe 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 @@ -264,9 +264,9 @@ import GHC.Utils.Outputable 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 ) @@ -404,27 +404,6 @@ addQuoteInclude spec paths = let f = includePathsQuote spec 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 { @@ -937,13 +916,13 @@ versionedFilePath platform = uniqueSubdir platform -- | The 'GhcMode' tells us whether we're doing multi-module -- compilation (controlled via the "GHC" API) or one-shot -- (single-module) compilation. This makes a difference primarily to --- the "GHC.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 @@ -5080,4 +5059,3 @@ initSDocContext dflags style = SDC -- | Initialize the pretty-printing options using the default user style initDefaultSDocContext :: DynFlags -> SDocContext initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle - diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs deleted file mode 100644 index 3bc3167031..0000000000 --- a/compiler/GHC/Driver/Types.hs +++ /dev/null @@ -1,3340 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{- -(c) The University of Glasgow, 2006 - -\section[GHC.Driver.Types]{Types for the per-module compiler} --} - --- | Types for the per-module compiler -module GHC.Driver.Types ( - -- * compilation state - HscEnv(..), hscEPS, - FinderCache, FindResult(..), InstalledFindResult(..), - Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId, findTarget, - 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, 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 "HsVersions.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. - - , 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) - --- | 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 - -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 - -{- -************************************************************************ -* * -\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 :: 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 - --- | 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) } diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index 2512ba91cc..674c99bbfa 100644 --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -32,6 +32,7 @@ module GHC.Hs ( Fixity, HsModule(..), + HsParsedModule(..) ) where -- friends: @@ -45,15 +46,17 @@ import GHC.Hs.Lit 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 ) @@ -150,3 +153,16 @@ pp_mb Nothing = empty 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 + } + diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index f5e973053a..41db2d5f85 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -37,8 +37,10 @@ import GHC.Tc.Types.Evidence 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) @@ -982,7 +984,7 @@ data Sig pass -- 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 -- @@ -995,7 +997,7 @@ data Sig pass -- 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 -- @@ -1006,7 +1008,7 @@ data Sig pass -- > {-# 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 diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index 78a7fd3320..51f1e2a127 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -114,6 +114,7 @@ import GHC.Types.ForeignCall import GHC.Hs.Extension import GHC.Types.Name import GHC.Types.Name.Set +import GHC.Types.Fixity -- others: import GHC.Core.Class @@ -121,7 +122,9 @@ import GHC.Utils.Outputable 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 @@ -2372,7 +2375,7 @@ instance Outputable ForeignExport where -- | 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 @@ -2515,7 +2518,7 @@ We use exported entities for things to deprecate. -- | 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 @@ -2563,7 +2566,7 @@ type LAnnDecl pass = XRec pass (AnnDecl pass) -- | 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' diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs index 6ce865a36a..639c738b74 100644 --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -17,19 +17,21 @@ module GHC.Hs.Dump ( 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 diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 724f37cbd7..ef8934b831 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -42,8 +42,10 @@ import GHC.Types.Id( Id ) 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 @@ -831,7 +833,7 @@ instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where -- | 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', diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index 1faadf38bd..0aec281312 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -19,7 +19,7 @@ import GHC.Prelude 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 @@ -79,7 +79,7 @@ data ImportDecl pass = 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 diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs index 967d41f283..75ea3ef469 100644 --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -11,9 +11,9 @@ (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -\section[HsLit]{Abstract syntax: source-language literals} -} +-- | Source-language literals module GHC.Hs.Lit where #include "HsVersions.h" @@ -21,10 +21,8 @@ module GHC.Hs.Lit where 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 diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index b2507a0865..3033806ddd 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -57,6 +57,7 @@ import GHC.Hs.Extension 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 diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 2e9f7b60c1..a193eefa12 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -87,6 +87,7 @@ import {-# SOURCE #-} GHC.Hs.Expr ( HsSplice, pprSplice ) 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(..), diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index c1edb7ef3e..8252d91249 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -116,8 +116,6 @@ import GHC.Hs.Lit 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,8 +126,12 @@ import GHC.Types.Id 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 diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index ac9adfac22..9954c204dc 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -20,55 +20,71 @@ module GHC.HsToCore ( import GHC.Prelude -import GHC.HsToCore.Usage import GHC.Driver.Session import GHC.Driver.Config -import GHC.Driver.Types +import GHC.Driver.Env import GHC.Driver.Backend + import GHC.Hs + +import GHC.HsToCore.Usage +import GHC.HsToCore.Monad +import GHC.HsToCore.Expr +import GHC.HsToCore.Binds +import GHC.HsToCore.Foreign.Decl +import GHC.HsToCore.Coverage +import GHC.HsToCore.Docs + import GHC.Tc.Types import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances ) import GHC.Tc.Module ( runTcInteractive ) -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Name + import GHC.Core.Type import GHC.Core.TyCon ( tyConDataCons ) -import GHC.Types.Avail import GHC.Core import GHC.Core.FVs ( exprsSomeFreeVarsList ) import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr ) import GHC.Core.Utils import GHC.Core.Unfold.Make import GHC.Core.Ppr -import GHC.HsToCore.Monad -import GHC.HsToCore.Expr -import GHC.HsToCore.Binds -import GHC.HsToCore.Foreign.Decl -import GHC.Builtin.Names -import GHC.Builtin.Types.Prim import GHC.Core.Coercion -import GHC.Builtin.Types import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make -import GHC.Unit -import GHC.Types.Name.Set -import GHC.Types.Name.Env import GHC.Core.Rules -import GHC.Types.Basic import GHC.Core.Opt.Monad ( CoreToDo(..) ) import GHC.Core.Lint ( endPassIO ) -import GHC.Types.Var.Set + +import GHC.Builtin.Names +import GHC.Builtin.Types.Prim +import GHC.Builtin.Types + import GHC.Data.FastString +import GHC.Data.OrdList + import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Types.SrcLoc -import GHC.HsToCore.Coverage import GHC.Utils.Misc import GHC.Utils.Monad -import GHC.Data.OrdList -import GHC.HsToCore.Docs + +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.ForeignStubs +import GHC.Types.Avail +import GHC.Types.Basic +import GHC.Types.Var.Set +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +import GHC.Types.TypeEnv +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Name.Ppr +import GHC.Types.HpcInfo + +import GHC.Unit +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModIface import Data.List import Data.IORef diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index a755d27883..9b3bbdf0b0 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -13,41 +13,47 @@ module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where import GHC.Prelude as Prelude +import GHC.Driver.Session +import GHC.Driver.Backend +import GHC.Driver.Ppr +import GHC.Driver.Env + import qualified GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes -import Data.Array import GHC.ByteCode.Types import GHC.Stack.CCS -import GHC.Core.Type import GHC.Hs import GHC.Unit +import GHC.Cmm.CLabel + +import GHC.Core.Type +import GHC.Core.ConLike +import GHC.Core +import GHC.Core.TyCon + +import GHC.Data.Maybe +import GHC.Data.FastString +import GHC.Data.Bag + +import GHC.Utils.Misc +import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Driver.Session -import GHC.Driver.Backend -import GHC.Driver.Ppr -import GHC.Core.ConLike -import Control.Monad +import GHC.Utils.Monad + import GHC.Types.SrcLoc -import GHC.Utils.Error +import GHC.Types.Basic +import GHC.Types.Id +import GHC.Types.Var.Set import GHC.Types.Name.Set hiding (FreeVars) import GHC.Types.Name -import GHC.Data.Bag +import GHC.Types.HpcInfo import GHC.Types.CostCentre import GHC.Types.CostCentre.State -import GHC.Core -import GHC.Types.Id -import GHC.Types.Var.Set -import Data.List -import GHC.Data.FastString -import GHC.Driver.Types -import GHC.Core.TyCon -import GHC.Types.Basic -import GHC.Utils.Monad -import GHC.Data.Maybe -import GHC.Cmm.CLabel -import GHC.Utils.Misc +import Control.Monad +import Data.List +import Data.Array import Data.Time import System.Directory diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 24b4a76892..1fa2c5f98b 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -31,6 +31,7 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Arrows import GHC.HsToCore.Monad import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) +import GHC.Types.SourceText import GHC.Types.Name import GHC.Types.Name.Env import GHC.Core.FamInstEnv( topNormaliseType ) diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index 317c0b9477..56ec46cd99 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -30,6 +30,7 @@ import GHC.Core import GHC.HsToCore.Monad import GHC.Core.Utils import GHC.Core.Make +import GHC.Types.SourceText import GHC.Types.Id.Make import GHC.Types.ForeignCall import GHC.Core.DataCon diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index e707b75e1b..4d6abc4132 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -29,6 +29,8 @@ import GHC.Core.DataCon import GHC.Core.Unfold.Make import GHC.Types.Id import GHC.Types.Literal +import GHC.Types.ForeignStubs +import GHC.Types.SourceText import GHC.Unit.Module import GHC.Types.Name import GHC.Core.Type @@ -41,7 +43,6 @@ import GHC.Tc.Utils.TcType import GHC.Cmm.Expr import GHC.Cmm.Utils -import GHC.Driver.Types import GHC.Driver.Ppr import GHC.Types.ForeignCall import GHC.Builtin.Types diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 491191d6a7..6a9fa35111 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -28,6 +28,7 @@ import GHC.Platform import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr) import GHC.Types.Basic ( Origin(..) ) +import GHC.Types.SourceText import GHC.Driver.Session import GHC.Hs import GHC.Tc.Utils.Zonk @@ -60,7 +61,7 @@ import GHC.Utils.Misc import GHC.Types.Name import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Types.Basic ( isGenerated, il_value, fl_value, Boxity(..) ) +import GHC.Types.Basic ( isGenerated, Boxity(..) ) import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index a2bd2f1095..70acb36724 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -35,6 +35,7 @@ import GHC.HsToCore.Utils import GHC.Hs import GHC.Types.Id +import GHC.Types.SourceText import GHC.Core import GHC.Core.Make import GHC.Core.TyCon @@ -50,7 +51,6 @@ import GHC.Types.Literal import GHC.Types.SrcLoc import Data.Ratio import GHC.Utils.Outputable as Outputable -import GHC.Types.Basic import GHC.Driver.Session import GHC.Utils.Misc import GHC.Utils.Panic diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 46af48e15d..c8f45a307b 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -57,42 +57,58 @@ module GHC.HsToCore.Monad ( import GHC.Prelude -import GHC.Tc.Utils.Monad +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Ppr + +import GHC.Hs + +import GHC.HsToCore.Types +import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas) + import GHC.Core.FamInstEnv import GHC.Core import GHC.Core.Make ( unitExpr ) import GHC.Core.Utils ( exprType, isExprLevPoly ) -import GHC.Hs +import GHC.Core.DataCon +import GHC.Core.ConLike +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Multiplicity + import GHC.IfaceToCore + +import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr ) + import GHC.Builtin.Names -import GHC.Types.Name.Reader -import GHC.Driver.Types + import GHC.Data.Bag -import GHC.Types.Basic ( Origin ) -import GHC.Core.DataCon -import GHC.Core.ConLike -import GHC.Core.TyCon -import GHC.HsToCore.Types -import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas) -import GHC.Types.Id +import GHC.Data.FastString + +import GHC.Unit.External import GHC.Unit.Module +import GHC.Unit.Module.ModGuts import GHC.Unit.Home import GHC.Unit.State -import GHC.Utils.Outputable + +import GHC.Types.Name.Reader +import GHC.Types.Basic ( Origin ) +import GHC.Types.SourceFile +import GHC.Types.Id import GHC.Types.SrcLoc -import GHC.Core.Type -import GHC.Core.Multiplicity +import GHC.Types.TypeEnv import GHC.Types.Unique.Supply import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Utils.Error -import GHC.Utils.Panic -import GHC.Data.FastString +import GHC.Types.Name.Ppr import GHC.Types.Literal ( mkLitString ) import GHC.Types.CostCentre.State +import GHC.Types.TyThing + +import GHC.Utils.Outputable +import GHC.Utils.Error +import GHC.Utils.Panic import Data.IORef diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs index 6880fafa6a..e409c1fcae 100644 --- a/compiler/GHC/HsToCore/Pmc.hs +++ b/compiler/GHC/HsToCore/Pmc.hs @@ -54,7 +54,7 @@ import GHC.HsToCore.Pmc.Ppr import GHC.Types.Basic (Origin(..)) import GHC.Core (CoreExpr) import GHC.Driver.Session -import GHC.Driver.Types +import GHC.Driver.Env import GHC.Hs import GHC.Types.Id import GHC.Types.SrcLoc diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs index 2ac4404926..235ed08492 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -121,13 +121,13 @@ isInhabited (MkNablas ds) = pure (not (null ds)) -- See Note [Implementation of COMPLETE pragmas] -- | Update the COMPLETE sets of 'ResidualCompleteMatches'. -updRcm :: (ConLikeSet -> ConLikeSet) -> ResidualCompleteMatches -> ResidualCompleteMatches +updRcm :: (CompleteMatch -> CompleteMatch) -> ResidualCompleteMatches -> ResidualCompleteMatches updRcm f (RCM vanilla pragmas) = RCM (f <$> vanilla) (fmap f <$> pragmas) -- | A pseudo-'CompleteMatch' for the vanilla complete set of the given data -- 'TyCon'. -- Ex.: @vanillaCompleteMatchTC 'Maybe' ==> Just ("Maybe", {'Just','Nothing'})@ -vanillaCompleteMatchTC :: TyCon -> Maybe ConLikeSet +vanillaCompleteMatchTC :: TyCon -> Maybe CompleteMatch vanillaCompleteMatchTC tc = let -- | TYPE acts like an empty data type on the term-level (#14086), but -- it is a PrimTyCon, so tyConDataCons_maybe returns Nothing. Hence a @@ -1260,9 +1260,9 @@ varNeedsTesting old_ty_st MkNabla{nabla_ty_st=new_ty_st} vi = do -- | Returns (Just vi) if at least one member of each ConLike in the COMPLETE -- set satisfies the oracle -- --- Internally uses and updates the ConLikeSets in vi_rcm. +-- Internally uses and updates the CompleteMatchs in vi_rcm. -- --- NB: Does /not/ filter each ConLikeSet with the oracle; members may +-- NB: Does /not/ filter each CompleteMatch with the oracle; members may -- remain that do not statisfy it. This lazy approach just -- avoids doing unnecessary work. instantiate :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo @@ -1326,7 +1326,7 @@ anyConLikeSolution p = any (go . paca_con) -- original Nabla, not a proper refinement! No positive information will be -- added, only negative information from failed instantiation attempts, -- entirely as an optimisation. -instCompleteSet :: Int -> Nabla -> Id -> ConLikeSet -> MaybeT DsM Nabla +instCompleteSet :: Int -> Nabla -> Id -> CompleteMatch -> MaybeT DsM Nabla instCompleteSet fuel nabla x cs | anyConLikeSolution (`elementOfUniqDSet` cs) (vi_pos vi) -- No need to instantiate a constructor of this COMPLETE set if we already @@ -1337,7 +1337,7 @@ instCompleteSet fuel nabla x cs where vi = lookupVarInfo (nabla_tm_st nabla) x - sorted_candidates :: ConLikeSet -> [ConLike] + sorted_candidates :: CompleteMatch -> [ConLike] sorted_candidates cs -- If there aren't many candidates, we can try to sort them by number of -- strict fields, type constraints, etc., so that we are fast in the @@ -1705,7 +1705,7 @@ generateInhabitingPatterns (x:xs) n nabla = do other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls pure (con_nablas ++ other_cons_nablas) -pickApplicableCompleteSets :: Type -> ResidualCompleteMatches -> DsM [ConLikeSet] +pickApplicableCompleteSets :: Type -> ResidualCompleteMatches -> DsM [CompleteMatch] pickApplicableCompleteSets ty rcm = do env <- dsGetFamInstEnvs pure $ filter (all (is_valid env) . uniqDSetToList) (getRcm rcm) diff --git a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs index 0cefbebd54..7afb26fcc6 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs @@ -13,7 +13,7 @@ module GHC.HsToCore.Pmc.Solver.Types ( Nabla(..), Nablas(..), initNablas, -- ** Caching residual COMPLETE sets - ConLikeSet, ResidualCompleteMatches(..), getRcm, isRcmInitialised, + CompleteMatch, ResidualCompleteMatches(..), getRcm, isRcmInitialised, -- ** Representations for Literals and AltCons PmLit(..), PmLitValue(..), PmAltCon(..), pmLitType, pmAltConType, @@ -61,7 +61,7 @@ import GHC.Builtin.Types import GHC.Builtin.Types.Prim import GHC.Tc.Solver.Monad (InertSet, emptyInert) import GHC.Tc.Utils.TcType (isStringTy) -import GHC.Driver.Types (ConLikeSet) +import GHC.Types.CompleteMatch (CompleteMatch) import Numeric (fromRat) import Data.Foldable (find) @@ -249,19 +249,19 @@ initTmState = TmSt emptyUSDFM emptyCoreMap emptyDVarSet -- See also Note [Implementation of COMPLETE pragmas] data ResidualCompleteMatches = RCM - { rcm_vanilla :: !(Maybe ConLikeSet) + { rcm_vanilla :: !(Maybe CompleteMatch) -- ^ The residual set for the vanilla COMPLETE set from the data defn. -- Tracked separately from 'rcm_pragmas', because it might only be -- known much later (when we have enough type information to see the 'TyCon' -- of the match), or not at all even. Until that happens, it is 'Nothing'. - , rcm_pragmas :: !(Maybe [ConLikeSet]) + , rcm_pragmas :: !(Maybe [CompleteMatch]) -- ^ The residual sets for /all/ COMPLETE sets from pragmas that are -- visible when compiling this module. Querying that set with -- 'dsGetCompleteMatches' requires 'DsM', so we initialise it with 'Nothing' -- until first needed in a 'DsM' context. } -getRcm :: ResidualCompleteMatches -> [ConLikeSet] +getRcm :: ResidualCompleteMatches -> [CompleteMatch] getRcm (RCM vanilla pragmas) = maybeToList vanilla ++ fromMaybe [] pragmas isRcmInitialised :: ResidualCompleteMatches -> Bool @@ -363,7 +363,7 @@ eqConLike _ _ = PossiblyOverlap data PmAltCon = PmAltConLike ConLike | PmAltLit PmLit -data PmAltConSet = PACS !ConLikeSet ![PmLit] +data PmAltConSet = PACS !CompleteMatch ![PmLit] emptyPmAltConSet :: PmAltConSet emptyPmAltConSet = PACS emptyUniqDSet [] diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index ada90cab6b..fb2b78141b 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -34,49 +34,55 @@ module GHC.HsToCore.Quote( dsBracket ) where import GHC.Prelude import GHC.Platform -import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) +import GHC.Driver.Session +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) import GHC.HsToCore.Match.Literal import GHC.HsToCore.Monad +import GHC.HsToCore.Binds import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH import GHC.Hs -import GHC.Builtin.Names -import GHC.Unit.Module -import GHC.Types.Id -import GHC.Types.Name hiding( varName, tcName ) -import GHC.Builtin.Names.TH -import GHC.Types.Name.Env import GHC.Tc.Utils.TcType +import GHC.Tc.Types.Evidence + +import GHC.Core.Class +import GHC.Core.DataCon import GHC.Core.TyCon -import GHC.Builtin.Types import GHC.Core.Multiplicity ( pattern Many ) import GHC.Core import GHC.Core.Make import GHC.Core.Utils -import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Unique -import GHC.Types.Basic + +import GHC.Builtin.Names +import GHC.Builtin.Names.TH +import GHC.Builtin.Types + +import GHC.Unit.Module + import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Monad + import GHC.Data.Bag -import GHC.Driver.Session import GHC.Data.FastString -import GHC.Types.ForeignCall -import GHC.Utils.Misc import GHC.Data.Maybe -import GHC.Utils.Monad -import GHC.Tc.Types.Evidence -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class -import GHC.Core.Class -import GHC.Driver.Types ( MonadThings ) -import GHC.Core.DataCon + +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Unique +import GHC.Types.Basic +import GHC.Types.ForeignCall import GHC.Types.Var -import GHC.HsToCore.Binds +import GHC.Types.Id +import GHC.Types.SourceText +import GHC.Types.Fixity +import GHC.Types.TyThing +import GHC.Types.Name hiding( varName, tcName ) +import GHC.Types.Name.Env import GHC.TypeLits import Data.Kind (Constraint) @@ -85,6 +91,8 @@ import Data.ByteString ( unpack ) import Control.Monad import Data.List import Data.Function +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class data MetaWrappers = MetaWrappers { -- Applies its argument to a type argument `m` and dictionary `Quote m` diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs index 64fe4498a0..68da67d21e 100644 --- a/compiler/GHC/HsToCore/Types.hs +++ b/compiler/GHC/HsToCore/Types.hs @@ -22,7 +22,7 @@ import GHC.Utils.Outputable as Outputable import GHC.Unit.Module import GHC.Driver.Hooks (DsForeignsHook) import GHC.Data.OrdList (OrdList) -import GHC.Driver.Types (ForeignStubs) +import GHC.Types.ForeignStubs (ForeignStubs) {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index 64c041902b..bf0e77911e 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -11,22 +11,33 @@ module GHC.HsToCore.Usage ( import GHC.Prelude +import GHC.Driver.Env import GHC.Driver.Session + +import GHC.Platform import GHC.Platform.Ways -import GHC.Driver.Types + import GHC.Tc.Types -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Unit -import GHC.Unit.State + import GHC.Utils.Outputable import GHC.Utils.Misc -import GHC.Types.Unique.Set -import GHC.Types.Unique.FM import GHC.Utils.Fingerprint import GHC.Utils.Panic + +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Unique.Set +import GHC.Types.Unique.FM + +import GHC.Unit +import GHC.Unit.External +import GHC.Unit.State +import GHC.Unit.Finder +import GHC.Unit.Module.Imported +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Deps + import GHC.Data.Maybe -import GHC.Driver.Finder import Control.Monad (filterM) import Data.List @@ -175,7 +186,7 @@ mkPluginUsage hsc_env pluginModule -- search for the library files containing the plugin. let searchPaths = collectLibraryPaths (ways dflags) [pkg] useDyn = WayDyn `elem` ways dflags - suffix = if useDyn then soExt platform else "a" + suffix = if useDyn then platformSOExt platform else "a" libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix | searchPath <- searchPaths , libLoc <- packageHsLibs dflags pkg @@ -187,7 +198,7 @@ mkPluginUsage hsc_env pluginModule then libLocs else let dflags' = addWay' WayDyn dflags - dlibLocs = [ searchPath </> mkHsSOName platform dlibLoc + dlibLocs = [ searchPath </> platformHsSOName platform dlibLoc | searchPath <- searchPaths , dlibLoc <- packageHsLibs dflags' pkg ] diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs index 5eddac0373..e2a6f0a79b 100644 --- a/compiler/GHC/Iface/Binary.hs +++ b/compiler/GHC/Iface/Binary.hs @@ -39,8 +39,8 @@ import GHC.Prelude import GHC.Tc.Utils.Monad import GHC.Builtin.Utils ( isKnownKeyName, lookupKnownKeyName ) import GHC.Iface.Env -import GHC.Driver.Types import GHC.Unit +import GHC.Unit.Module.ModIface import GHC.Types.Name import GHC.Driver.Session import GHC.Platform.Profile diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs index 161384821b..4b4567289c 100644 --- a/compiler/GHC/Iface/Env.hs +++ b/compiler/GHC/Iface/Env.hs @@ -16,7 +16,7 @@ module GHC.Iface.Env ( ifaceExportNames, -- Name-cache stuff - allocateGlobalBinder, updNameCacheTc, + allocateGlobalBinder, updNameCacheTc, updNameCache, mkNameCacheUpdater, NameCacheUpdater(..), ) where @@ -24,22 +24,29 @@ module GHC.Iface.Env ( import GHC.Prelude +import GHC.Driver.Env + import GHC.Tc.Utils.Monad -import GHC.Driver.Types import GHC.Core.Type -import GHC.Types.Var -import GHC.Types.Name -import GHC.Types.Avail +import GHC.Iface.Type +import GHC.Runtime.Context + import GHC.Unit.Module +import GHC.Unit.Module.ModIface + import GHC.Data.FastString import GHC.Data.FastString.Env -import GHC.Iface.Type + +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Avail import GHC.Types.Name.Cache import GHC.Types.Unique.Supply import GHC.Types.SrcLoc import GHC.Utils.Outputable import Data.List ( partition ) +import Data.IORef {- ********************************************************* @@ -296,3 +303,20 @@ newIfaceNames occs = do { uniqs <- newUniqueSupply ; return [ mkInternalName uniq occ noSrcSpan | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } + +{- +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 + diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 01c5b6102f..f13cbf30b3 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -37,8 +37,7 @@ import GHC.Core.DataCon ( dataConNonlinearType ) import GHC.HsToCore ( deSugarExpr ) import GHC.Types.FieldLabel import GHC.Hs -import GHC.Driver.Types -import GHC.Unit.Module ( ModuleName, ml_hs_file ) +import GHC.Driver.Env import GHC.Utils.Monad ( concatMapM, liftIO ) import GHC.Types.Id ( isDataConId_maybe ) import GHC.Types.Name ( Name, nameSrcSpan, nameUnique ) @@ -62,6 +61,9 @@ import GHC.Data.FastString import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils +import GHC.Unit.Module ( ModuleName, ml_hs_file ) +import GHC.Unit.Module.ModSummary + import qualified Data.Array as A import qualified Data.ByteString as BS import qualified Data.Map as M diff --git a/compiler/GHC/Iface/Ext/Fields.hs b/compiler/GHC/Iface/Ext/Fields.hs new file mode 100644 index 0000000000..1cc1e94012 --- /dev/null +++ b/compiler/GHC/Iface/Ext/Fields.hs @@ -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 $ 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 + +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 diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 212bcb78ac..ed8ecf0e08 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -40,49 +40,69 @@ import {-# SOURCE #-} GHC.IfaceToCore ( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst , tcIfaceAnnotations, tcIfaceCompleteMatches ) +import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Ppr +import GHC.Driver.Hooks +import GHC.Driver.Plugins + import GHC.Iface.Syntax import GHC.Iface.Env -import GHC.Driver.Types +import GHC.Iface.Ext.Fields +import GHC.Iface.Binary +import GHC.Iface.Rename -import GHC.Types.Basic hiding (SuccessFlag(..)) import GHC.Tc.Utils.Monad import GHC.Utils.Binary ( BinData(..) ) +import GHC.Utils.Error +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc +import GHC.Utils.Fingerprint + import GHC.Settings.Constants + import GHC.Builtin.Names import GHC.Builtin.Utils import GHC.Builtin.PrimOps ( allThePrimOps, primOpFixity, primOpOcc ) -import GHC.Types.Id.Make ( seqId, EnableBignumRules(..) ) + import GHC.Core.Rules import GHC.Core.TyCon -import GHC.Types.Annotations import GHC.Core.InstEnv import GHC.Core.FamInstEnv + +import GHC.Types.Id.Make ( seqId, EnableBignumRules(..) ) +import GHC.Types.Annotations import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Avail -import GHC.Unit.Module -import GHC.Unit.State -import GHC.Data.Maybe -import GHC.Utils.Error -import GHC.Driver.Finder +import GHC.Types.Fixity +import GHC.Types.Fixity.Env +import GHC.Types.SourceError +import GHC.Types.SourceText +import GHC.Types.SourceFile +import GHC.Types.SafeHaskell +import GHC.Types.TypeEnv import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet import GHC.Types.SrcLoc -import GHC.Utils.Outputable as Outputable -import GHC.Iface.Binary -import GHC.Utils.Panic -import GHC.Utils.Misc -import GHC.Data.FastString -import GHC.Utils.Fingerprint -import GHC.Driver.Hooks import GHC.Types.FieldLabel -import GHC.Iface.Rename -import GHC.Types.Unique.DSet -import GHC.Driver.Plugins +import GHC.Types.TyThing + +import GHC.Unit.External +import GHC.Unit.Module +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Deps +import GHC.Unit.State import GHC.Unit.Home +import GHC.Unit.Home.ModInfo +import GHC.Unit.Finder + +import GHC.Data.Maybe +import GHC.Data.FastString import Control.Monad import Control.Exception @@ -873,7 +893,7 @@ Note [Home module load error] If the sought-for interface is in the current package (as determined by -package-name flag) then it jolly well should already be in the HPT because we process home-package modules in dependency order. (Except -in one-shot mode; see notes with hsc_HPT decl in GHC.Driver.Types). +in one-shot mode; see notes with hsc_HPT decl in GHC.Driver.Env). It is possible (though hard) to get this error through user behaviour. * Suppose package P (modules P1, P2) depends on package Q (modules Q1, diff --git a/compiler/GHC/Iface/Load.hs-boot b/compiler/GHC/Iface/Load.hs-boot index 78c5dd2e67..0e83000eba 100644 --- a/compiler/GHC/Iface/Load.hs-boot +++ b/compiler/GHC/Iface/Load.hs-boot @@ -2,7 +2,7 @@ module GHC.Iface.Load where import GHC.Unit.Module (Module) import GHC.Tc.Utils.Monad (IfM) -import GHC.Driver.Types (ModIface) +import GHC.Unit.Module.ModIface (ModIface) import GHC.Utils.Outputable (SDoc) loadSysInterface :: SDoc -> Module -> IfM lcl ModIface diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 27933fc18e..4c369e0bc4 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -23,15 +23,21 @@ where import GHC.Prelude +import GHC.Hs + +import GHC.StgToCmm.Types (CgInfos (..)) + +import GHC.Tc.Utils.TcType +import GHC.Tc.Utils.Monad + import GHC.Iface.Syntax import GHC.Iface.Recomp import GHC.Iface.Load +import GHC.Iface.Ext.Fields + import GHC.CoreToIface import qualified GHC.LanguageExtensions as LangExt -import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies ) -import GHC.Types.Id -import GHC.Types.Annotations import GHC.Core import GHC.Core.Class import GHC.Core.TyCon @@ -40,16 +46,19 @@ import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Multiplicity -import GHC.StgToCmm.Types (CgInfos (..)) -import GHC.Tc.Utils.TcType import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import GHC.Tc.Utils.Monad -import GHC.Hs -import GHC.Driver.Types + +import GHC.Driver.Env import GHC.Driver.Backend import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Driver.Plugins (LoadedPlugin(..)) + +import GHC.Types.Id +import GHC.Types.Fixity.Env +import GHC.Types.SafeHaskell +import GHC.Types.Annotations import GHC.Types.Var.Env import GHC.Types.Var import GHC.Types.Name @@ -58,21 +67,34 @@ import GHC.Types.Name.Reader import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Unique.DSet -import GHC.Unit +import GHC.Types.Basic hiding ( SuccessFlag(..) ) +import GHC.Types.TypeEnv +import GHC.Types.SourceFile +import GHC.Types.TyThing +import GHC.Types.HpcInfo + import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Types.Basic hiding ( SuccessFlag(..) ) import GHC.Utils.Misc hiding ( eqListBy ) + import GHC.Data.FastString import GHC.Data.Maybe + import GHC.HsToCore.Docs +import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies ) + +import GHC.Unit +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.Deps import Data.Function import Data.List ( findIndex, mapAccumL, sortBy ) import Data.Ord import Data.IORef -import GHC.Driver.Plugins (LoadedPlugin(..)) {- ************************************************************************ diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 68df3e2fbd..c810911509 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -14,45 +14,57 @@ where import GHC.Prelude +import GHC.Driver.Backend +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins ) + import GHC.Iface.Syntax import GHC.Iface.Recomp.Binary import GHC.Iface.Load import GHC.Iface.Recomp.Flags -import GHC.Types.Annotations import GHC.Core import GHC.Tc.Utils.Monad import GHC.Hs -import GHC.Driver.Backend -import GHC.Driver.Types -import GHC.Driver.Finder -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Unit.Module + +import GHC.Data.Graph.Directed +import GHC.Data.Maybe +import GHC.Data.FastString + import GHC.Utils.Error import GHC.Utils.Panic -import GHC.Data.Graph.Directed -import GHC.Types.SrcLoc import GHC.Utils.Outputable as Outputable -import GHC.Types.Unique import GHC.Utils.Misc as Utils hiding ( eqListBy ) -import GHC.Data.Maybe -import GHC.Data.FastString import GHC.Utils.Binary import GHC.Utils.Fingerprint import GHC.Utils.Exception + +import GHC.Types.Annotations +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.SrcLoc +import GHC.Types.Unique import GHC.Types.Unique.Set +import GHC.Types.Fixity.Env +import GHC.Types.SourceFile + +import GHC.Unit.External +import GHC.Unit.Finder import GHC.Unit.State import GHC.Unit.Home +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.Deps import Control.Monad import Data.Function import Data.List (find, sortBy, sort) import qualified Data.Map as Map import qualified Data.Set as Set -import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins ) --Qualified import so we can define a Semigroup instance -- but it doesn't clash with Outputable.<> diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs index 28419149b5..e73c061018 100644 --- a/compiler/GHC/Iface/Recomp/Flags.hs +++ b/compiler/GHC/Iface/Recomp/Flags.hs @@ -12,9 +12,9 @@ import GHC.Prelude import GHC.Utils.Binary import GHC.Driver.Session -import GHC.Driver.Types import GHC.Unit.Module import GHC.Types.Name +import GHC.Types.SafeHaskell import GHC.Utils.Fingerprint import GHC.Iface.Recomp.Binary -- import GHC.Utils.Outputable diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 63ca80af12..749914821a 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -18,35 +18,40 @@ module GHC.Iface.Rename ( import GHC.Prelude -import GHC.Types.SrcLoc -import GHC.Utils.Outputable -import GHC.Driver.Types +import GHC.Driver.Session +import GHC.Driver.Env + +import GHC.Tc.Utils.Monad + +import GHC.Iface.Syntax +import GHC.Iface.Env +import {-# SOURCE #-} GHC.Iface.Load -- a bit vexing + import GHC.Unit import GHC.Unit.State +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Deps + +import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Types.Avail -import GHC.Iface.Syntax import GHC.Types.FieldLabel import GHC.Types.Var -import GHC.Utils.Error - +import GHC.Types.Basic import GHC.Types.Name -import GHC.Tc.Utils.Monad +import GHC.Types.Name.Shape + +import GHC.Utils.Error +import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Fingerprint import GHC.Utils.Panic -import GHC.Types.Basic --- a bit vexing -import {-# SOURCE #-} GHC.Iface.Load -import GHC.Driver.Session +import GHC.Data.Bag import qualified Data.Traversable as T -import GHC.Data.Bag import Data.IORef -import GHC.Types.Name.Shape -import GHC.Iface.Env tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a tcRnMsgMaybe do_this = do diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 3def579fb7..72ff681c99 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -73,6 +73,7 @@ import GHC.Builtin.Types ( constraintKindTyConName ) 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 @@ data IfaceTyConParent | 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 @@ data IfaceFamTyConFlav | 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,10 +464,10 @@ ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] -- *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]) -- The order of the list does not matter. @@ -736,7 +737,7 @@ Note [Printing IfaceDecl binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 +807,7 @@ constraintIfaceKind = 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, diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 82f1c18920..10d0eb1d04 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -17,10 +17,13 @@ module GHC.Iface.Tidy ( import GHC.Prelude -import GHC.Tc.Types import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Ppr +import GHC.Driver.Env + +import GHC.Tc.Types + import GHC.Core import GHC.Core.Unfold import GHC.Core.Unfold.Make @@ -34,36 +37,47 @@ import GHC.Core.Rules import GHC.Core.PatSyn import GHC.Core.ConLike import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe ) +import GHC.Core.InstEnv +import GHC.Core.Type ( tidyTopType ) +import GHC.Core.DataCon +import GHC.Core.TyCon +import GHC.Core.Class + import GHC.Iface.Tidy.StaticPtrTable +import GHC.Iface.Env + +import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Monad + +import GHC.Utils.Outputable +import GHC.Utils.Misc( filterOut ) +import GHC.Utils.Panic +import qualified GHC.Utils.Error as Err + +import GHC.Types.ForeignStubs import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info -import GHC.Core.InstEnv -import GHC.Core.Type ( tidyTopType ) import GHC.Types.Demand ( appIsDeadEnd, isTopSig, isDeadEndSig ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Basic import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set import GHC.Types.Name.Cache +import GHC.Types.Name.Ppr import GHC.Types.Avail -import GHC.Iface.Env -import GHC.Tc.Utils.Env -import GHC.Tc.Utils.Monad -import GHC.Core.DataCon -import GHC.Core.TyCon -import GHC.Core.Class +import GHC.Types.Unique.Supply +import GHC.Types.TypeEnv + import GHC.Unit.Module -import GHC.Driver.Types +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.Deps + import GHC.Data.Maybe -import GHC.Types.Unique.Supply -import GHC.Utils.Outputable -import GHC.Utils.Misc( filterOut ) -import GHC.Utils.Panic -import qualified GHC.Utils.Error as Err import Control.Monad import Data.Function diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs index b4a0a3c5a4..8f83e35333 100644 --- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -124,23 +124,29 @@ Here is a running example: -} import GHC.Prelude +import GHC.Platform + +import GHC.Driver.Session +import GHC.Driver.Env -import GHC.Cmm.CLabel import GHC.Core import GHC.Core.Utils (collectMakeStaticArgs) import GHC.Core.DataCon -import GHC.Driver.Session -import GHC.Driver.Types -import GHC.Types.Id import GHC.Core.Make (mkStringExprFSWith) +import GHC.Core.Type + +import GHC.Cmm.CLabel + import GHC.Unit.Module -import GHC.Types.Name import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Platform import GHC.Builtin.Names import GHC.Tc.Utils.Env (lookupGlobal) -import GHC.Core.Type +import GHC.Runtime.Linker.Types + +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.TyThing import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 2e33770812..57889754fe 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -155,7 +155,7 @@ type IfaceKind = IfaceType -- | 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 @@ instance Outputable IfaceTyConSort where 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 diff --git a/compiler/GHC/Iface/UpdateIdInfos.hs b/compiler/GHC/Iface/UpdateIdInfos.hs index fcc93c110e..9c013cc320 100644 --- a/compiler/GHC/Iface/UpdateIdInfos.hs +++ b/compiler/GHC/Iface/UpdateIdInfos.hs @@ -8,13 +8,19 @@ import GHC.Prelude import GHC.Core import GHC.Core.InstEnv -import GHC.Driver.Types + import GHC.StgToCmm.Types (CgInfos (..)) + import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Var +import GHC.Types.TypeEnv +import GHC.Types.TyThing + +import GHC.Unit.Module.ModDetails + import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 381d0b08d2..ad7db247f7 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -27,22 +27,28 @@ module GHC.IfaceToCore ( import GHC.Prelude +import GHC.Driver.Env +import GHC.Driver.Session + import GHC.Builtin.Types.Literals(typeNatCoAxiomRules) +import GHC.Builtin.Types + import GHC.Iface.Syntax import GHC.Iface.Load import GHC.Iface.Env + import GHC.StgToCmm.Types + import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType + import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Coercion.Axiom import GHC.Core.FVs import GHC.Core.TyCo.Rep -- needs to build types & coercions in a knot import GHC.Core.TyCo.Subst ( substTyCoVars ) -import GHC.Driver.Types -import GHC.Types.Annotations import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core @@ -50,34 +56,46 @@ import GHC.Core.Utils import GHC.Core.Unfold.Make import GHC.Core.Lint import GHC.Core.Make -import GHC.Types.Id -import GHC.Types.Id.Make -import GHC.Types.Id.Info import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon -import GHC.Builtin.Types -import GHC.Types.Literal -import GHC.Types.Var as Var -import GHC.Types.Var.Set -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) + +import GHC.Unit.External import GHC.Unit.Module -import GHC.Types.Unique.FM -import GHC.Types.Unique.DSet ( mkUniqDSet ) -import GHC.Types.Unique.Supply +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.ModIface +import GHC.Unit.Home.ModInfo + import GHC.Utils.Outputable -import GHC.Data.Maybe -import GHC.Types.SrcLoc -import GHC.Driver.Session import GHC.Utils.Misc import GHC.Utils.Panic + +import GHC.Data.Maybe import GHC.Data.FastString -import GHC.Types.Basic hiding ( SuccessFlag(..) ) import GHC.Data.List.SetOps + +import GHC.Types.Annotations +import GHC.Types.SourceFile +import GHC.Types.SourceText +import GHC.Types.Basic hiding ( SuccessFlag(..) ) +import GHC.Types.SrcLoc +import GHC.Types.TypeEnv +import GHC.Types.Unique.FM +import GHC.Types.Unique.DSet ( mkUniqDSet ) +import GHC.Types.Unique.Supply +import GHC.Types.Literal +import GHC.Types.Var as Var +import GHC.Types.Var.Set +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Id +import GHC.Types.Id.Make +import GHC.Types.Id.Info +import GHC.Types.TyThing + import GHC.Fingerprint import qualified GHC.Data.BooleanFormula as BF diff --git a/compiler/GHC/IfaceToCore.hs-boot b/compiler/GHC/IfaceToCore.hs-boot index 349c629835..96daafae3c 100644 --- a/compiler/GHC/IfaceToCore.hs-boot +++ b/compiler/GHC/IfaceToCore.hs-boot @@ -3,12 +3,12 @@ module GHC.IfaceToCore where import GHC.Prelude import GHC.Iface.Syntax ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule , IfaceAnnotation, IfaceCompleteMatch ) -import GHC.Core.TyCo.Rep ( TyThing ) +import GHC.Types.TyThing ( TyThing ) import GHC.Tc.Types ( IfL ) import GHC.Core.InstEnv ( ClsInst ) import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core ( CoreRule ) -import GHC.Driver.Types ( CompleteMatch ) +import GHC.Types.CompleteMatch ( CompleteMatch ) import GHC.Types.Annotations ( Annotation ) tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 1d1ae49685..90d8ed10c8 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -42,42 +42,39 @@ where -- 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 import GHC.Prelude import GHC.Hs -import GHC.Hs.Doc -import GHC.Driver.Phases ( HscSource(..) ) import GHC.Driver.Backpack.Syntax -import GHC.Unit.Types ( IsBootInterface(..) ) import GHC.Unit.Info import GHC.Unit.Module +import GHC.Unit.Module.Warnings import GHC.Data.OrdList -import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue ) +import GHC.Data.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.Types.Name.Reader -import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, - occNameFS, startsWithUnderscore ) +import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS ) import GHC.Types.SrcLoc import GHC.Types.Basic +import GHC.Types.Fixity import GHC.Types.ForeignCall +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 ) +import GHC.Core.DataCon ( DataCon, dataConName ) import GHC.Parser.PostProcess import GHC.Parser.PostProcess.Haddock diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index c27fd7a773..33e48a1a50 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -237,7 +237,7 @@ getAndRemoveAnnotationComments anns span = -- AST. -- -- The annotations, together with original source comments are made available in --- the @'pm_annotations'@ field of @'GHC.Driver.Types.HsParsedModule'@. +-- 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 diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index c4bc3f13da..d9f2964638 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -26,28 +26,34 @@ where import GHC.Prelude import GHC.Platform + +import GHC.Driver.Session +import GHC.Driver.Config + import GHC.Parser.Errors.Ppr import GHC.Parser.Errors -import GHC.Driver.Types 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 ( Bag, emptyBag, listToBag, unitBag, isEmptyBag ) import GHC.Utils.Monad import GHC.Utils.Exception as Exception -import GHC.Types.Basic + +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 diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 17f6dd0e65..4d7b1ab157 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -104,9 +104,8 @@ import GHC.Data.OrdList import GHC.Utils.Misc ( readRational, readHexRational ) import GHC.Types.SrcLoc -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 diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index a4ac42d382..31e861a215 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -114,11 +114,14 @@ import GHC.Types.Name.Reader 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 ) @@ -2168,7 +2171,7 @@ mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation -- 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 diff --git a/compiler/GHC/Platform.hs b/compiler/GHC/Platform.hs index 856903bbd1..09c6ef37aa 100644 --- a/compiler/GHC/Platform.hs +++ b/compiler/GHC/Platform.hs @@ -31,19 +31,24 @@ module GHC.Platform , 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. @@ -212,3 +217,19 @@ data PlatformMisc = PlatformMisc , 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" + diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs index 87363c3a89..8af39b5743 100644 --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -33,7 +33,7 @@ module GHC.Plugins , module GHC.Core.TyCon , module GHC.Core.Coercion , module GHC.Builtin.Types - , module GHC.Driver.Types + , module GHC.Driver.Env , module GHC.Types.Basic , module GHC.Types.Var.Set , module GHC.Types.Var.Env @@ -51,6 +51,11 @@ module GHC.Plugins , module GHC.Types.Unique.Supply , module GHC.Data.FastString , module GHC.Tc.Errors.Hole.FitTypes -- for hole-fit plugins + , module GHC.Unit.Module.ModGuts + , module GHC.Unit.Module.ModSummary + , module GHC.Unit.Module.ModIface + , module GHC.Types.Meta + , module GHC.Types.SourceError , -- * Getting 'Name's thNameToGhcName ) @@ -60,6 +65,8 @@ where import GHC.Driver.Plugins -- Variable naming +import GHC.Types.TyThing +import GHC.Types.SourceError import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence hiding ( varName {- conflicts with Var.varName -} ) import GHC.Types.Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} ) @@ -78,23 +85,24 @@ import GHC.Core.FVs import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst ) -- These names are also exported by Type --- Core "extras" import GHC.Core.Rules import GHC.Types.Annotations +import GHC.Types.Meta --- Pipeline-related stuff import GHC.Driver.Session import GHC.Unit.State --- Important GHC types import GHC.Unit.Module +import GHC.Unit.Module.ModGuts +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface import GHC.Core.Type hiding {- conflict with GHC.Core.Subst -} ( substTy, extendTvSubst, extendTvSubstList, isInScope ) import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -} ( substCo ) import GHC.Core.TyCon import GHC.Builtin.Types -import GHC.Driver.Types +import GHC.Driver.Env import GHC.Types.Basic -- Collections and maps diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index f497792c33..621a01cb6c 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -56,7 +56,6 @@ import GHC.Iface.Load ( loadInterfaceForName, loadSrcInterface_maybe ) import GHC.Iface.Env import GHC.Hs import GHC.Types.Name.Reader -import GHC.Driver.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Parser.PostProcess ( setRdrNameSpace ) @@ -67,12 +66,14 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Avail import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Warnings ( WarningTxt, pprWarningTxtForMsg ) import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Utils.Error ( MsgDoc ) import GHC.Builtin.Names( rOOT_MAIN ) -import GHC.Types.Basic ( pprWarningTxtForMsg, TopLevelFlag(..), TupleSort(..) ) +import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..) ) import GHC.Types.SrcLoc as SrcLoc import GHC.Utils.Outputable as Outputable import GHC.Types.Unique.Set ( uniqSetAny ) diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 1c0b425165..e0855f8c24 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -47,11 +47,12 @@ import GHC.Rename.Pat import GHC.Driver.Session import GHC.Builtin.Names -import GHC.Types.Basic +import GHC.Types.Fixity import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.Unique.Set +import GHC.Types.SourceText import Data.List import Data.Maybe (isJust, isNothing) import GHC.Utils.Misc diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs index b3b195aa61..a66d9de5bf 100644 --- a/compiler/GHC/Rename/Fixity.hs +++ b/compiler/GHC/Rename/Fixity.hs @@ -16,21 +16,28 @@ import GHC.Prelude import GHC.Iface.Load import GHC.Hs -import GHC.Types.Name.Reader -import GHC.Driver.Types import GHC.Tc.Utils.Monad + +import GHC.Unit.Module +import GHC.Unit.Module.ModIface + +import GHC.Types.Fixity.Env import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Unit.Module -import GHC.Types.Basic ( Fixity(..), FixityDirection(..), minPrecedence, - defaultFixity, SourceText(..) ) +import GHC.Types.Name.Reader +import GHC.Types.Fixity +import GHC.Types.SourceText import GHC.Types.SrcLoc + import GHC.Utils.Outputable import GHC.Utils.Panic + import GHC.Data.Maybe + +import GHC.Rename.Unbound + import Data.List import Data.Function ( on ) -import GHC.Rename.Unbound {- ********************************************************* diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index e04846ddde..6deee41fea 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -57,9 +57,9 @@ import GHC.Types.Name.Set import GHC.Types.FieldLabel import GHC.Utils.Misc -import GHC.Types.Basic ( compareFixity, negateFixity - , Fixity(..), FixityDirection(..), LexicalFixity(..) - , TypeOrKind(..) ) +import GHC.Types.Fixity ( compareFixity, negateFixity + , Fixity(..), FixityDirection(..), LexicalFixity(..) ) +import GHC.Types.Basic ( TypeOrKind(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 0a4a3e5bdf..dbca13302c 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -42,6 +42,7 @@ import GHC.Tc.Utils.Monad import GHC.Types.ForeignCall ( CCallTarget(..) ) import GHC.Unit +import GHC.Unit.Module.Warnings import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName , monadClassName, returnMName, thenMName , semigroupClassName, sappendName @@ -59,7 +60,7 @@ import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session import GHC.Utils.Misc ( debugIsOn, lengthExceeds, partitionWith ) import GHC.Utils.Panic -import GHC.Driver.Types ( Warnings(..), plusWarns, HscEnv(..)) +import GHC.Driver.Env ( HscEnv(..)) import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses ) import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) , stronglyConnCompFromEdgedVerticesUniq ) diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 6778e6f868..5115d058d7 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -34,38 +34,54 @@ module GHC.Rename.Names ( import GHC.Prelude +import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr -import GHC.Core.TyCo.Ppr -import GHC.Hs -import GHC.Tc.Utils.Env + import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv ) -import GHC.Iface.Load ( loadSrcInterface ) + +import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad + +import GHC.Hs +import GHC.Iface.Load ( loadSrcInterface ) import GHC.Builtin.Names -import GHC.Unit +import GHC.Parser.PostProcess ( setRdrNameSpace ) +import GHC.Core.Type +import GHC.Core.PatSyn +import GHC.Core.TyCo.Ppr +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Misc as Utils +import GHC.Utils.Panic + +import GHC.Types.Fixity.Env +import GHC.Types.SafeHaskell import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set +import GHC.Types.Name.Reader import GHC.Types.Avail import GHC.Types.FieldLabel -import GHC.Driver.Types -import GHC.Types.Name.Reader -import GHC.Parser.PostProcess ( setRdrNameSpace ) -import GHC.Utils.Outputable as Outputable -import GHC.Data.Maybe +import GHC.Types.SourceFile import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Basic ( TopLevelFlag(..), StringLiteral(..) ) -import GHC.Utils.Misc as Utils -import GHC.Utils.Panic +import GHC.Types.Basic ( TopLevelFlag(..) ) +import GHC.Types.SourceText +import GHC.Types.Id +import GHC.Types.HpcInfo + +import GHC.Unit +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Imported +import GHC.Unit.Module.Deps + +import GHC.Data.Maybe import GHC.Data.FastString import GHC.Data.FastString.Env -import GHC.Types.Id -import GHC.Core.Type -import GHC.Core.PatSyn -import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Data.Either ( partitionEithers, isRight, rights ) @@ -552,7 +568,7 @@ created by its bindings. Note [Top-level Names in Template Haskell decl quotes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types +See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env Note [Looking up Exact RdrNames] in GHC.Rename.Env Consider a Template Haskell declaration quotation like this: diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 3a632c2705..4a85c898ff 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -66,6 +66,7 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.Basic +import GHC.Types.SourceText import GHC.Utils.Misc import GHC.Data.List.SetOps( removeDups ) import GHC.Utils.Outputable diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index b5bf6d22d7..c18074097d 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -26,7 +26,8 @@ import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn ) import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Module ( rnSrcDecls, findSplice ) import GHC.Rename.Pat ( rnPat ) -import GHC.Types.Basic ( TopLevelFlag, isTopLevel, SourceText(..) ) +import GHC.Types.Basic ( TopLevelFlag, isTopLevel ) +import GHC.Types.SourceText ( SourceText(..) ) import GHC.Utils.Outputable import GHC.Unit.Module import GHC.Types.SrcLoc diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index f9c8dc4e22..4147b9517f 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -20,22 +20,28 @@ where import GHC.Prelude -import GHC.Types.Name.Reader -import GHC.Driver.Types +import GHC.Driver.Session +import GHC.Driver.Ppr + import GHC.Tc.Utils.Monad -import GHC.Types.Name -import GHC.Unit.Module -import GHC.Types.SrcLoc as SrcLoc -import GHC.Utils.Outputable as Outputable import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique) +import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc + import GHC.Data.Maybe -import GHC.Driver.Session -import GHC.Driver.Ppr import GHC.Data.FastString + +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Name +import GHC.Types.Name.Reader +import GHC.Types.Unique.DFM (udfmToList) + +import GHC.Unit.Module +import GHC.Unit.Module.Imported +import GHC.Unit.Home.ModInfo + import Data.List import Data.Function ( on ) -import GHC.Types.Unique.DFM (udfmToList) {- ************************************************************************ diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 1b86fd9152..85dd2566ea 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -39,7 +39,6 @@ import GHC.Prelude import GHC.Core.Type import GHC.Hs import GHC.Types.Name.Reader -import GHC.Driver.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Types.Name @@ -47,6 +46,7 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Core.DataCon import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.SourceFile import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc diff --git a/compiler/GHC/Runtime/Context.hs b/compiler/GHC/Runtime/Context.hs new file mode 100644 index 0000000000..7220dea503 --- /dev/null +++ b/compiler/GHC/Runtime/Context.hs @@ -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 + diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs index 3def133bea..e86357a0ea 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -14,30 +14,35 @@ module GHC.Runtime.Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) import GHC.Prelude +import GHC + +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Driver.Monad +import GHC.Driver.Env + import GHC.Runtime.Linker import GHC.Runtime.Heap.Inspect - import GHC.Runtime.Interpreter -import GHCi.RemoteTypes -import GHC.Driver.Monad -import GHC.Driver.Types -import GHC.Types.Id +import GHC.Runtime.Context + import GHC.Iface.Syntax ( showToHeader ) import GHC.Iface.Env ( newInteractiveBinder ) -import GHC.Types.Name -import GHC.Types.Var hiding ( varName ) -import GHC.Types.Var.Set -import GHC.Types.Unique.Set import GHC.Core.Type -import GHC + import GHC.Utils.Outputable -import GHC.Core.Ppr.TyThing import GHC.Utils.Error import GHC.Utils.Monad -import GHC.Driver.Session -import GHC.Driver.Ppr import GHC.Utils.Exception +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Var hiding ( varName ) +import GHC.Types.Var.Set +import GHC.Types.Unique.Set +import GHC.Types.TyThing.Ppr +import GHC.Types.TyThing + import Control.Monad import Control.Monad.Catch as MC import Data.List ( (\\) ) diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index 68d2908dbb..337cd24d80 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -48,28 +48,57 @@ module GHC.Runtime.Eval ( import GHC.Prelude -import GHC.Runtime.Eval.Types +import GHC.Driver.Monad +import GHC.Driver.Main +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter as GHCi import GHC.Runtime.Interpreter.Types +import GHC.Runtime.Linker as Linker +import GHC.Runtime.Linker.Types +import GHC.Runtime.Heap.Inspect +import GHC.Runtime.Context import GHCi.Message import GHCi.RemoteTypes -import GHC.Driver.Monad -import GHC.Driver.Main +import GHC.ByteCode.Types + import GHC.Hs -import GHC.Driver.Types + +import GHC.Core.Predicate import GHC.Core.InstEnv -import GHC.Iface.Env ( newInteractiveBinder ) import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core.FVs ( orphNamesOfFamInst ) import GHC.Core.TyCon import GHC.Core.Type hiding( typeKind ) import qualified GHC.Core.Type as Type -import GHC.Types.RepType + +import GHC.Iface.Env ( newInteractiveBinder ) import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin -import GHC.Core.Predicate + +import GHC.Builtin.Names ( toDynName, pretendNameIsInScope ) +import GHC.Builtin.Types ( isCTupleTyConName ) + +import GHC.Data.Maybe +import GHC.Data.FastString +import GHC.Data.Bag + +import GHC.Utils.Monad +import GHC.Utils.Panic +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Misc + +import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, initParserState) +import GHC.Parser.Lexer (ParserOpts) +import qualified GHC.Parser as Parser (parseStmt, parseModule, parseDeclaration, parseImport) + +import GHC.Types.RepType +import GHC.Types.Fixity.Env import GHC.Types.Var import GHC.Types.Id as Id import GHC.Types.Name hiding ( varName ) @@ -77,28 +106,15 @@ import GHC.Types.Name.Set import GHC.Types.Avail import GHC.Types.Name.Reader import GHC.Types.Var.Env -import GHC.ByteCode.Types -import GHC.Runtime.Linker as Linker -import GHC.Driver.Session -import GHC.Driver.Ppr +import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Supply -import GHC.Utils.Monad +import GHC.Types.TyThing + import GHC.Unit -import GHC.Builtin.Names ( toDynName, pretendNameIsInScope ) -import GHC.Builtin.Types ( isCTupleTyConName ) -import GHC.Utils.Panic -import GHC.Data.Maybe -import GHC.Utils.Error -import GHC.Types.SrcLoc -import GHC.Runtime.Heap.Inspect -import GHC.Utils.Outputable -import GHC.Data.FastString -import GHC.Data.Bag -import GHC.Utils.Misc -import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, initParserState) -import GHC.Parser.Lexer (ParserOpts) -import qualified GHC.Parser as Parser (parseStmt, parseModule, parseDeclaration, parseImport) +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModSummary +import GHC.Unit.Home.ModInfo import System.Directory import Data.Dynamic diff --git a/compiler/GHC/Runtime/Eval/Types.hs b/compiler/GHC/Runtime/Eval/Types.hs index 9586947742..c72c5c89ff 100644 --- a/compiler/GHC/Runtime/Eval/Types.hs +++ b/compiler/GHC/Runtime/Eval/Types.hs @@ -18,9 +18,9 @@ import GHCi.RemoteTypes 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 diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index 7bcb1a364c..34c55760ac 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -30,7 +30,7 @@ import GHC.Platform import GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes -import GHC.Driver.Types +import GHC.Driver.Env import GHCi.Message ( fromSerializableException ) import GHC.Core.DataCon diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs index bcfd34ee15..b2df09f35f 100644 --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -55,28 +55,36 @@ module GHC.Runtime.Interpreter import GHC.Prelude +import GHC.Driver.Ppr (showSDoc) +import GHC.Driver.Env +import GHC.Driver.Session + import GHC.Runtime.Interpreter.Types import GHCi.Message import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray) -import GHC.Utils.Fingerprint -import GHC.Driver.Types +import GHC.Runtime.Eval.Types(BreakInfo(..)) +import GHC.Runtime.Linker.Types +import GHC.ByteCode.Types + +import GHC.Data.Maybe +import GHC.Data.FastString + +import GHC.Types.Unique +import GHC.Types.SrcLoc import GHC.Types.Unique.FM +import GHC.Types.Basic + import GHC.Utils.Panic -import GHC.Driver.Session import GHC.Utils.Exception as Ex -import GHC.Types.Basic -import GHC.Data.FastString -import GHC.Utils.Misc -import GHC.Runtime.Eval.Types(BreakInfo(..)) import GHC.Utils.Outputable(brackets, ppr) -import GHC.Driver.Ppr (showSDoc) -import GHC.Types.SrcLoc -import GHC.Data.Maybe +import GHC.Utils.Fingerprint +import GHC.Utils.Misc + import GHC.Unit.Module -import GHC.ByteCode.Types -import GHC.Types.Unique +import GHC.Unit.Module.ModIface +import GHC.Unit.Home.ModInfo #if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run diff --git a/compiler/GHC/Runtime/Linker.hs b/compiler/GHC/Runtime/Linker.hs index 4477a0ad2f..4203f741c6 100644 --- a/compiler/GHC/Runtime/Linker.hs +++ b/compiler/GHC/Runtime/Linker.hs @@ -31,40 +31,53 @@ where import GHC.Prelude +import GHC.Platform +import GHC.Platform.Ways + +import GHC.Driver.Phases +import GHC.Driver.Env +import GHC.Driver.Session +import GHC.Driver.Ppr + +import GHC.Tc.Utils.Monad + import GHC.Runtime.Interpreter import GHC.Runtime.Interpreter.Types +import GHC.Runtime.Linker.Types import GHCi.RemoteTypes + import GHC.Iface.Load + import GHC.ByteCode.Linker import GHC.ByteCode.Asm import GHC.ByteCode.Types -import GHC.Tc.Utils.Monad -import GHC.Unit.State as Packages -import GHC.Driver.Phases -import GHC.Driver.Finder -import GHC.Driver.Types -import GHC.Platform.Ways + +import GHC.SysTools +import GHC.SysTools.FileCleanup + +import GHC.Types.Basic import GHC.Types.Name import GHC.Types.Name.Env -import GHC.Unit.Module -import GHC.Unit.Home -import GHC.Data.List.SetOps -import GHC.Runtime.Linker.Types (DynLinker(..), PersistentLinkerState(..)) -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.Unique.DSet + import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Error -import GHC.Types.SrcLoc + +import GHC.Unit.Finder +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Deps +import GHC.Unit.Home +import GHC.Unit.Home.ModInfo +import GHC.Unit.State as Packages + +import qualified GHC.Data.ShortText as ST import qualified GHC.Data.Maybe as Maybes -import GHC.Types.Unique.DSet import GHC.Data.FastString -import qualified GHC.Data.ShortText as ST -import GHC.Platform -import GHC.SysTools -import GHC.SysTools.FileCleanup +import GHC.Data.List.SetOps -- Standard libraries import Control.Monad @@ -446,7 +459,7 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do return pls DLL dll_unadorned -> do - maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned) + maybe_errstr <- loadDLL hsc_env (platformSOName platform dll_unadorned) case maybe_errstr of Nothing -> maybePutStrLn dflags "done" Just mm | platformOS platform /= OSDarwin -> @@ -918,7 +931,7 @@ dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] (soFile, libPath , libName) <- - newTempLibName dflags TFL_CurrentModule (soExt platform) + newTempLibName dflags TFL_CurrentModule (platformSOExt platform) let dflags2 = dflags { -- We don't want the original ldInputs in @@ -1342,7 +1355,7 @@ linkPackage hsc_env pkg mapM_ (load_dyn hsc_env True) known_dlls -- For remaining `dlls` crash early only when there is surely -- no package's DLL around ... (not is_dyn) - mapM_ (load_dyn hsc_env (not is_dyn) . mkSOName platform) dlls + mapM_ (load_dyn hsc_env (not is_dyn) . platformSOName platform) dlls #endif -- After loading all the DLLs, we can load the static objects. -- Ordering isn't important here, because we do one final link @@ -1528,9 +1541,9 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib ] hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags - hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name + hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name - so_name = mkSOName platform lib + so_name = platformSOName platform lib lib_so_name = "lib" ++ so_name dyn_lib_file = case (arch, os) of (ArchX86_64, OSSolaris2) -> "64" </> so_name diff --git a/compiler/GHC/Runtime/Linker/Types.hs b/compiler/GHC/Runtime/Linker/Types.hs index 7899feae9e..e40de2b55e 100644 --- a/compiler/GHC/Runtime/Linker/Types.hs +++ b/compiler/GHC/Runtime/Linker/Types.hs @@ -6,26 +6,35 @@ -- ----------------------------------------------------------------------------- -module GHC.Runtime.Linker.Types ( - DynLinker(..), - PersistentLinkerState(..), - Linkable(..), - Unlinked(..), - SptEntry(..) - ) where - -import GHC.Prelude ( FilePath, String, show ) +module GHC.Runtime.Linker.Types + ( DynLinker(..) + , PersistentLinkerState(..) + , Linkable(..) + , Unlinked(..) + , SptEntry(..) + , isObjectLinkable + , linkableObjs + , isObject + , nameOfObject + , isInterpretable + , byteCodeOfObject + ) +where + +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) @@ -106,3 +115,39 @@ data SptEntry = SptEntry Id Fingerprint 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) diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index be89d86192..2a97e24edd 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -21,38 +21,45 @@ module GHC.Runtime.Loader ( ) where import GHC.Prelude + import GHC.Driver.Session import GHC.Driver.Ppr +import GHC.Driver.Hooks +import GHC.Driver.Plugins import GHC.Runtime.Linker ( linkModule, getHValue ) import GHC.Runtime.Interpreter ( wormhole, withInterp ) import GHC.Runtime.Interpreter.Types -import GHC.Types.SrcLoc ( noSrcSpan ) -import GHC.Driver.Finder ( findPluginModule, cannotFindModule ) + import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn ) import GHC.Iface.Load ( loadPluginInterface ) -import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..) - , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName - , gre_name, mkRdrQual ) -import GHC.Types.Name.Occurrence ( OccName, mkVarOcc ) import GHC.Rename.Names ( gresFromAvails ) -import GHC.Driver.Plugins import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName ) -import GHC.Driver.Types +import GHC.Driver.Env import GHCi.RemoteTypes ( HValue ) import GHC.Core.Type ( Type, eqType, mkTyConTy ) -import GHC.Core.TyCo.Ppr ( pprTyThingCategory ) import GHC.Core.TyCon ( TyCon ) + +import GHC.Types.SrcLoc ( noSrcSpan ) import GHC.Types.Name ( Name, nameModule_maybe ) import GHC.Types.Id ( idType ) +import GHC.Types.TyThing +import GHC.Types.Name.Occurrence ( OccName, mkVarOcc ) +import GHC.Types.Name.Reader ( RdrName, ImportSpec(..), ImpDeclSpec(..) + , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName + , gre_name, mkRdrQual ) + +import GHC.Unit.Finder ( findPluginModule, cannotFindModule, FindResult(..) ) import GHC.Unit.Module ( Module, ModuleName ) +import GHC.Unit.Module.ModIface + import GHC.Utils.Panic -import GHC.Data.FastString import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Exception -import GHC.Driver.Hooks + +import GHC.Data.FastString import Control.Monad ( unless ) import Data.Maybe ( mapMaybe ) diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 7447a1feeb..2bbf6deac7 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -16,6 +16,9 @@ module GHC.StgToCmm ( codeGen ) where import GHC.Prelude as Prelude +import GHC.Driver.Backend +import GHC.Driver.Session + import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) import GHC.StgToCmm.Monad import GHC.StgToCmm.Env @@ -31,32 +34,34 @@ import GHC.StgToCmm.Types (ModuleLFInfos) import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.CLabel +import GHC.Cmm.Graph import GHC.Stg.Syntax -import GHC.Driver.Session -import GHC.Utils.Error -import GHC.Driver.Types -import GHC.Driver.Backend import GHC.Types.CostCentre +import GHC.Types.HpcInfo import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.RepType +import GHC.Types.Basic +import GHC.Types.Var.Set ( isEmptyDVarSet ) +import GHC.Types.Unique.FM +import GHC.Types.Name.Env + import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Multiplicity + import GHC.Unit.Module + +import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Data.Stream -import GHC.Types.Basic -import GHC.Types.Var.Set ( isEmptyDVarSet ) + import GHC.SysTools.FileCleanup -import GHC.Types.Unique.FM -import GHC.Types.Name.Env +import GHC.Data.Stream import GHC.Data.OrdList -import GHC.Cmm.Graph import Data.IORef import Control.Monad (when,void) diff --git a/compiler/GHC/StgToCmm/Hpc.hs b/compiler/GHC/StgToCmm/Hpc.hs index 77b1e0af47..707fe9725a 100644 --- a/compiler/GHC/StgToCmm/Hpc.hs +++ b/compiler/GHC/StgToCmm/Hpc.hs @@ -9,18 +9,20 @@ module GHC.StgToCmm.Hpc ( initHpc, mkTickBox ) where import GHC.Prelude +import GHC.Platform + +import GHC.Driver.Session import GHC.StgToCmm.Monad +import GHC.StgToCmm.Utils -import GHC.Platform import GHC.Cmm.Graph import GHC.Cmm.Expr import GHC.Cmm.CLabel -import GHC.Unit.Module import GHC.Cmm.Utils -import GHC.StgToCmm.Utils -import GHC.Driver.Types -import GHC.Driver.Session + +import GHC.Unit.Module +import GHC.Types.HpcInfo import Control.Monad diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs index 7dc40cef04..4e78f52f34 100644 --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -9,26 +9,26 @@ ----------------------------------------------------------------------------- module GHC.SysTools.Tasks where -import GHC.Utils.Exception as Exception -import GHC.Utils.Error -import GHC.Driver.Types -import GHC.Driver.Session -import GHC.Utils.Outputable -import GHC.Platform -import GHC.Utils.Misc - -import Data.List - -import System.IO -import System.Process import GHC.Prelude +import GHC.Platform +import GHC.ForeignSrcLang import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersion, parseLlvmVersion) import GHC.SysTools.Process import GHC.SysTools.Info +import GHC.Driver.Session + +import GHC.Utils.Exception as Exception +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Misc + +import Data.List import Control.Monad (join, forM, filterM) +import System.IO +import System.Process import System.Directory (doesFileExist) import System.FilePath ((</>)) diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 400d4afbe7..33c0765c69 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -46,8 +46,10 @@ import GHC.Tc.Utils.Monad import GHC.Hs import GHC.Types.Name.Reader import GHC.Types.Basic +import GHC.Types.Fixity import GHC.Core.DataCon import GHC.Types.Name +import GHC.Types.SourceText import GHC.Driver.Session import GHC.Builtin.Utils diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs index 86a5cd7ba5..5a9e329ae2 100644 --- a/compiler/GHC/Tc/Deriv/Generics.hs +++ b/compiler/GHC/Tc/Deriv/Generics.hs @@ -37,6 +37,9 @@ import GHC.Unit.Module ( moduleName, moduleNameFS import GHC.Iface.Env ( newGlobalBinder ) import GHC.Types.Name hiding ( varName ) import GHC.Types.Name.Reader +import GHC.Types.Fixity.Env +import GHC.Types.SourceText +import GHC.Types.Fixity import GHC.Types.Basic import GHC.Builtin.Types.Prim import GHC.Builtin.Types @@ -44,7 +47,6 @@ import GHC.Builtin.Names import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Driver.Session -import GHC.Driver.Types import GHC.Utils.Error( Validity(..), andValid ) import GHC.Types.SrcLoc import GHC.Data.Bag diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs index 9cb56bf1c5..f4d71a38a1 100644 --- a/compiler/GHC/Tc/Deriv/Utils.hs +++ b/compiler/GHC/Tc/Deriv/Utils.hs @@ -30,12 +30,13 @@ import GHC.Core.Class import GHC.Core.DataCon import GHC.Driver.Session import GHC.Utils.Error -import GHC.Driver.Types (lookupFixity, mi_fix) +import GHC.Types.Fixity.Env (lookupFixity) import GHC.Hs import GHC.Tc.Utils.Instantiate import GHC.Core.InstEnv import GHC.Iface.Load (loadInterfaceForName) import GHC.Unit.Module (getModule) +import GHC.Unit.Module.ModIface (mi_fix) import GHC.Types.Name import GHC.Utils.Outputable import GHC.Utils.Panic diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index b50ff2e804..5ae117bf55 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -27,6 +27,7 @@ import GHC.Builtin.Names ( gHC_ERR ) import GHC.Types.Id import GHC.Types.Var.Set import GHC.Types.Var.Env +import GHC.Types.TyThing import GHC.Data.Bag import GHC.Core.ConLike ( ConLike(..) ) import GHC.Utils.Misc @@ -50,7 +51,7 @@ import GHC.Tc.Utils.Unify ( tcSubTypeSigma ) import GHC.HsToCore.Docs ( extractDocs ) import qualified Data.Map as Map import GHC.Hs.Doc ( unpackHDS, DeclDocMap(..) ) -import GHC.Driver.Types ( ModIface_(..) ) +import GHC.Unit.Module.ModIface ( ModIface_(..) ) import GHC.Iface.Load ( loadInterfaceForNameMaybe ) import GHC.Builtin.Utils (knownKeyNames) diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs index 6e9c7ac5ed..90a703b6b5 100644 --- a/compiler/GHC/Tc/Gen/Annotation.hs +++ b/compiler/GHC/Tc/Gen/Annotation.hs @@ -12,18 +12,23 @@ module GHC.Tc.Gen.Annotation ( tcAnnotations, annCtxt ) where import GHC.Prelude +import GHC.Driver.Session +import GHC.Driver.Env + import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation ) +import GHC.Tc.Utils.Monad + import GHC.Unit.Module -import GHC.Driver.Session -import Control.Monad ( when ) import GHC.Hs + +import GHC.Utils.Outputable + import GHC.Types.Name import GHC.Types.Annotations -import GHC.Tc.Utils.Monad import GHC.Types.SrcLoc -import GHC.Utils.Outputable -import GHC.Driver.Types + +import Control.Monad ( when ) -- Some platforms don't support the interpreter, and compilation on those -- platforms shouldn't fail just due to annotations diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 03ce1353a0..97d997897f 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -49,6 +49,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy) import GHC.Builtin.Types.Prim import GHC.Builtin.Types( mkBoxedTupleTy ) +import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.Var as Var import GHC.Types.Var.Set diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index 9b503da19c..d5420a4027 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -9,7 +9,6 @@ import GHC.Prelude import GHC.Hs import GHC.Builtin.Names -import GHC.Types.Name.Reader import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType @@ -17,26 +16,30 @@ import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Unbound ( reportUnboundName ) import GHC.Utils.Error -import GHC.Types.Id -import GHC.Types.Id.Info import GHC.Unit.Module -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Avail +import GHC.Unit.Module.Imported import GHC.Core.TyCon -import GHC.Types.SrcLoc as SrcLoc -import GHC.Driver.Types import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Data.Maybe -import GHC.Types.Unique.Set import GHC.Utils.Misc (capitalise) import GHC.Data.FastString (fsLit) +import GHC.Types.Unique.Set +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.SourceFile +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.TyThing +import GHC.Types.Name.Reader + import Control.Monad import GHC.Driver.Session import GHC.Parser.PostProcess ( setRdrNameSpace ) diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index a64154facf..564ad46660 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -36,6 +36,7 @@ import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic +import GHC.Types.SourceText import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Tc.Utils.Instantiate diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index ff01093a34..1b9e0185f3 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -40,8 +40,6 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC , tcCheckMonoExpr, tcCheckMonoExprNC , tcCheckPolyExpr ) -import GHC.Types.Basic (LexicalFixity(..)) -import GHC.Hs import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Pat @@ -51,21 +49,27 @@ import GHC.Tc.Utils.TcType import GHC.Tc.Gen.Bind import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence + import GHC.Core.Multiplicity import GHC.Core.UsageEnv -import GHC.Types.Name -import GHC.Builtin.Types -import GHC.Types.Id import GHC.Core.TyCon +-- Create chunkified tuple tybes for monad comprehensions +import GHC.Core.Make + +import GHC.Hs + +import GHC.Builtin.Types import GHC.Builtin.Types.Prim -import GHC.Tc.Types.Evidence + import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Types.SrcLoc --- Create chunkified tuple tybes for monad comprehensions -import GHC.Core.Make +import GHC.Types.Fixity (LexicalFixity(..)) +import GHC.Types.Name +import GHC.Types.Id +import GHC.Types.SrcLoc import Control.Monad import Control.Arrow ( second ) diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index c83890b1ae..c9c134dfbe 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -34,89 +34,98 @@ module GHC.Tc.Gen.Splice( import GHC.Prelude +import GHC.Driver.Plugins +import GHC.Driver.Main +import GHC.Driver.Session +import GHC.Driver.Env +import GHC.Driver.Hooks + import GHC.Hs -import GHC.Types.Annotations -import GHC.Driver.Finder -import GHC.Types.Name + import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType -import GHC.Core.Multiplicity - -import GHC.Utils.Outputable import GHC.Tc.Gen.Expr -import GHC.Types.SrcLoc -import GHC.Builtin.Names.TH import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Env import GHC.Tc.Types.Origin +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Zonk +import GHC.Tc.Solver +import GHC.Tc.Utils.TcMType +import GHC.Tc.Gen.HsType +import GHC.Tc.Instance.Family +import GHC.Tc.Utils.Instantiate + +import GHC.Core.Multiplicity import GHC.Core.Coercion( etaExpandCoAxBranch ) -import GHC.SysTools.FileCleanup ( newTempName, TempFileLifetime(..) ) +import GHC.Core.Type as Type +import GHC.Core.TyCo.Rep as TyCoRep +import GHC.Core.FamInstEnv +import GHC.Core.InstEnv as InstEnv -import Control.Monad +import GHC.Builtin.Names.TH +import GHC.Builtin.Names +import GHC.Builtin.Types + +import GHC.ThToHs +import GHC.HsToCore.Expr +import GHC.HsToCore.Monad +import GHC.IfaceToCore +import GHC.Iface.Load import GHCi.Message import GHCi.RemoteTypes import GHC.Runtime.Interpreter import GHC.Runtime.Interpreter.Types -import GHC.Driver.Main - -- These imports are the reason that GHC.Tc.Gen.Splice - -- is very high up the module hierarchy + import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) -import GHC.Types.Name.Reader -import GHC.Driver.Types -import GHC.ThToHs import GHC.Rename.Expr import GHC.Rename.Env import GHC.Rename.Utils ( HsDocContext(..) ) import GHC.Rename.Fixity ( lookupFixityRn_help ) import GHC.Rename.HsType -import GHC.Tc.Utils.Zonk -import GHC.Tc.Solver -import GHC.Core.Type as Type -import GHC.Types.Name.Set -import GHC.Tc.Utils.TcMType -import GHC.Tc.Gen.HsType -import GHC.IfaceToCore -import GHC.Core.TyCo.Rep as TyCoRep -import GHC.Tc.Instance.Family -import GHC.Core.FamInstEnv -import GHC.Core.InstEnv as InstEnv -import GHC.Tc.Utils.Instantiate -import GHC.Types.Name.Env -import GHC.Builtin.Names -import GHC.Builtin.Types -import GHC.Types.Name.Occurrence as OccName -import GHC.Driver.Hooks -import GHC.Types.Var -import GHC.Unit.Module -import GHC.Iface.Load + import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.PatSyn import GHC.Core.ConLike import GHC.Core.DataCon as DataCon -import GHC.Tc.Types.Evidence + +import GHC.Types.SrcLoc +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Name.Reader +import GHC.Types.Name.Occurrence as OccName +import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info -import GHC.HsToCore.Expr -import GHC.HsToCore.Monad +import GHC.Types.Unique +import GHC.Types.Var.Set +import GHC.Types.Meta +import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Types.Fixity as Hs +import GHC.Types.Annotations +import GHC.Types.Name import GHC.Serialized + +import GHC.Unit.Finder +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.Deps + import GHC.Utils.Error import GHC.Utils.Misc -import GHC.Types.Unique -import GHC.Types.Var.Set -import Data.List ( find ) -import Data.Maybe -import GHC.Data.FastString -import GHC.Types.Basic as BasicTypes hiding( SuccessFlag(..) ) -import GHC.Data.Maybe( MaybeErr(..) ) -import GHC.Driver.Session import GHC.Utils.Panic as Panic import GHC.Utils.Lexeme -import qualified GHC.Data.EnumSet as EnumSet -import GHC.Driver.Plugins +import GHC.Utils.Outputable + +import GHC.SysTools.FileCleanup ( newTempName, TempFileLifetime(..) ) + import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.Maybe( MaybeErr(..) ) +import qualified GHC.Data.EnumSet as EnumSet import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types @@ -128,9 +137,12 @@ import GHC.Desugar ( AnnotationWrapper(..) ) import Unsafe.Coerce ( unsafeCoerce ) #endif +import Control.Monad import Control.Exception import Data.Binary import Data.Binary.Get +import Data.List ( find ) +import Data.Maybe import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Dynamic ( fromDynamic, toDyn ) @@ -2295,10 +2307,10 @@ reifyFixity name = do { (found, fix) <- lookupFixityRn_help name ; return (if found then Just (conv_fix fix) else Nothing) } where - conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d) - conv_dir BasicTypes.InfixR = TH.InfixR - conv_dir BasicTypes.InfixL = TH.InfixL - conv_dir BasicTypes.InfixN = TH.InfixN + conv_fix (Hs.Fixity _ i d) = TH.Fixity i (conv_dir d) + conv_dir Hs.InfixR = TH.InfixR + conv_dir Hs.InfixL = TH.InfixL + conv_dir Hs.InfixN = TH.InfixN reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index 94a170692a..2e94d477b1 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -13,6 +13,8 @@ module GHC.Tc.Instance.Class ( import GHC.Prelude +import GHC.Driver.Session + import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType @@ -20,30 +22,32 @@ import GHC.Tc.Utils.Instantiate( tcInstType ) import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence -import GHC.Core.Predicate -import GHC.Rename.Env( addUsedGRE ) -import GHC.Types.Name.Reader( lookupGRE_FieldLabel ) -import GHC.Core.InstEnv import GHC.Tc.Utils.Instantiate( instDFunType ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst ) +import GHC.Rename.Env( addUsedGRE ) import GHC.Builtin.Types import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon ) import GHC.Builtin.Names +import GHC.Types.Name.Reader( lookupGRE_FieldLabel ) +import GHC.Types.SafeHaskell +import GHC.Types.Name ( Name, pprDefinedAt ) +import GHC.Types.Var.Env ( VarEnv ) import GHC.Types.Id + +import GHC.Core.Predicate +import GHC.Core.InstEnv import GHC.Core.Type import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr ) - -import GHC.Types.Name ( Name, pprDefinedAt ) -import GHC.Types.Var.Env ( VarEnv ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class -import GHC.Driver.Session + import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 ) + import Data.Maybe {- ******************************************************************* diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs index 8a2c5b0e7a..620e585f8f 100644 --- a/compiler/GHC/Tc/Instance/Family.hs +++ b/compiler/GHC/Tc/Instance/Family.hs @@ -14,33 +14,46 @@ module GHC.Tc.Instance.Family ( import GHC.Prelude -import GHC.Driver.Types +import GHC.Driver.Session +import GHC.Driver.Env + import GHC.Core.FamInstEnv import GHC.Core.InstEnv( roughMatchTcs ) import GHC.Core.Coercion -import GHC.Tc.Types.Evidence -import GHC.Iface.Load -import GHC.Tc.Utils.Monad -import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX ) -import GHC.Types.SrcLoc as SrcLoc import GHC.Core.TyCon -import GHC.Tc.Utils.TcType import GHC.Core.Coercion.Axiom -import GHC.Driver.Session -import GHC.Unit.Module -import GHC.Utils.Outputable -import GHC.Utils.Misc -import GHC.Types.Name.Reader import GHC.Core.DataCon ( dataConName ) -import GHC.Data.Maybe import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen ) + +import GHC.Iface.Load + +import GHC.Tc.Types.Evidence +import GHC.Tc.Utils.Monad +import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX ) +import GHC.Tc.Utils.TcType + +import GHC.Unit.External +import GHC.Unit.Module +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.Deps +import GHC.Unit.Home.ModInfo + +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Name.Reader import GHC.Types.Name -import GHC.Utils.Panic import GHC.Types.Var.Set + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic import GHC.Utils.FV + import GHC.Data.Bag( Bag, unionBags, unitBag ) +import GHC.Data.Maybe + import Control.Monad import Data.List ( sortBy ) import Data.List.NonEmpty ( NonEmpty(..) ) @@ -215,7 +228,7 @@ two modules are consistent--because we checked that when we compiled M. For every other pair of family instance modules we import (directly or indirectly), we check that they are consistent now. (So that we can be -certain that the modules in our `GHC.Driver.Types.dep_finsts' are consistent.) +certain that the modules in our `GHC.Driver.Env.dep_finsts' are consistent.) There is some fancy footwork regarding hs-boot module loops, see Note [Don't check hs-boot type family instances too early] diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs index 7758caf712..09f90567db 100644 --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -15,14 +15,15 @@ module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where import GHC.Prelude import GHC.Platform -import GHC.Types.Basic ( Boxity(..), neverInlinePragma, SourceText(..) ) +import GHC.Types.Basic ( Boxity(..), neverInlinePragma ) +import GHC.Types.SourceText ( SourceText(..) ) import GHC.Iface.Env( newGlobalBinder ) import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) import GHC.Tc.Utils.Env import GHC.Tc.Types.Evidence ( mkWpTyApps ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType -import GHC.Driver.Types ( lookupId ) +import GHC.Types.TyThing ( lookupId ) import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( primTyCons ) import GHC.Builtin.Types diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 37b399bdd1..94582b00a9 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -48,28 +48,16 @@ module GHC.Tc.Module ( import GHC.Prelude +import GHC.Driver.Env +import GHC.Driver.Plugins +import GHC.Driver.Session + +import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) ) import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) -import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) -import GHC.Iface.Env ( externaliseName ) import GHC.Tc.Gen.HsType import GHC.Tc.Validity( checkValidType ) import GHC.Tc.Gen.Match import GHC.Tc.Utils.Unify( checkConstraints ) -import GHC.Rename.HsType -import GHC.Rename.Expr -import GHC.Rename.Utils ( HsDocContext(..) ) -import GHC.Rename.Fixity ( lookupFixityRn ) -import GHC.Builtin.Types ( unitTy, mkListTy ) -import GHC.Driver.Plugins -import GHC.Driver.Session -import GHC.Hs -import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) -import GHC.Iface.Type ( ShowForAllFlag(..) ) -import GHC.Core.PatSyn ( pprPatSynType ) -import GHC.Core.Predicate ( classMethodTy ) -import GHC.Builtin.Names -import GHC.Builtin.Utils -import GHC.Types.Name.Reader import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Expr import GHC.Tc.Errors( reportAllUnsolved ) @@ -79,24 +67,14 @@ import GHC.Tc.Gen.Export import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin -import qualified GHC.Data.BooleanFormula as BF -import GHC.Core.Ppr.TyThing ( pprTyThingInContext ) -import GHC.Core.FVs ( orphNamesOfFamInst ) import GHC.Tc.Instance.Family -import GHC.Core.InstEnv -import GHC.Core.FamInstEnv - ( FamInst, pprFamInst, famInstsRepTyCons - , famInstEnvElts, extendFamInstEnvList, normaliseType ) import GHC.Tc.Gen.Annotation import GHC.Tc.Gen.Bind -import GHC.Iface.Make ( coAxiomToIfaceDecl ) -import GHC.Parser.Header ( mkPrelImports ) import GHC.Tc.Gen.Default import GHC.Tc.Utils.Env import GHC.Tc.Gen.Rule import GHC.Tc.Gen.Foreign import GHC.Tc.TyCl.Instance -import GHC.IfaceToCore import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Instantiate (tcGetInsts) @@ -104,50 +82,97 @@ import GHC.Tc.Solver import GHC.Tc.TyCl import GHC.Tc.Instance.Typeable ( mkTypeableBinds ) import GHC.Tc.Utils.Backpack -import GHC.Iface.Load + +import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) +import GHC.Rename.HsType +import GHC.Rename.Expr +import GHC.Rename.Utils ( HsDocContext(..) ) +import GHC.Rename.Fixity ( lookupFixityRn ) import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Module + +import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) +import GHC.Iface.Type ( ShowForAllFlag(..) ) +import GHC.Iface.Env ( externaliseName ) +import GHC.Iface.Make ( coAxiomToIfaceDecl ) +import GHC.Iface.Load + +import GHC.Builtin.Types ( unitTy, mkListTy ) +import GHC.Builtin.Names +import GHC.Builtin.Utils + +import GHC.Hs +import GHC.Hs.Dump + +import GHC.Core.PatSyn ( pprPatSynType ) +import GHC.Core.Predicate ( classMethodTy ) +import GHC.Core.FVs ( orphNamesOfFamInst ) +import GHC.Core.InstEnv +import GHC.Core.TyCon +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.Class +import GHC.Core.Coercion.Axiom +import GHC.Core.FamInstEnv + ( FamInst, pprFamInst, famInstsRepTyCons + , famInstEnvElts, extendFamInstEnvList, normaliseType ) + +import GHC.Parser.Header ( mkPrelImports ) + +import GHC.IfaceToCore + +import GHC.Runtime.Context + import GHC.Utils.Error +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Types.Name.Reader +import GHC.Types.Fixity.Env import GHC.Types.Id as Id import GHC.Types.Id.Info( IdDetails(..) ) import GHC.Types.Var.Env -import GHC.Unit +import GHC.Types.TypeEnv import GHC.Types.Unique.FM import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Avail -import GHC.Core.TyCon -import GHC.Types.SrcLoc -import GHC.Driver.Types -import GHC.Data.List.SetOps -import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic -import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.Type -import GHC.Core.Class import GHC.Types.Basic hiding( SuccessFlag(..) ) -import GHC.Core.Coercion.Axiom import GHC.Types.Annotations -import Data.List ( find, sortBy, sort ) -import Data.Ord +import GHC.Types.SrcLoc +import GHC.Types.SourceText +import GHC.Types.SourceFile +import GHC.Types.TyThing.Ppr ( pprTyThingInContext ) +import qualified GHC.LanguageExtensions as LangExt + +import GHC.Unit.External +import GHC.Unit.Types +import GHC.Unit.State +import GHC.Unit.Home +import GHC.Unit.Module +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModSummary +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.Deps + import GHC.Data.FastString import GHC.Data.Maybe -import GHC.Utils.Misc +import GHC.Data.List.SetOps import GHC.Data.Bag -import qualified GHC.LanguageExtensions as LangExt +import qualified GHC.Data.BooleanFormula as BF + +import Data.List ( find, sortBy, sort ) +import Data.Ord import Data.Data ( Data ) -import GHC.Hs.Dump import qualified Data.Set as S - import Control.DeepSeq import Control.Monad -import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) ) - - #include "HsVersions.h" {- @@ -2099,7 +2124,7 @@ tcRnStmt hsc_env rdr_stmt traceTc "tcs 1" empty ; this_mod <- getModule ; global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ; - -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types + -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env {- --------------------------------------------- At one stage I removed any shadowed bindings from the type_env; @@ -2170,7 +2195,7 @@ runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p -- -- By 'lift' and 'environment we mean that the code is changed to -- execute properly in an IO monad. See Note [Interactively-bound Ids --- in GHCi] in GHC.Driver.Types for more details. We do this lifting by trying +-- in GHCi] in GHC.Driver.Env for more details. We do this lifting by trying -- different ways ('plans') of lifting the code into the IO monad and -- type checking each plan until one succeeds. tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv) diff --git a/compiler/GHC/Tc/Module.hs-boot b/compiler/GHC/Tc/Module.hs-boot index 90d775a4e2..2748c769e4 100644 --- a/compiler/GHC/Tc/Module.hs-boot +++ b/compiler/GHC/Tc/Module.hs-boot @@ -1,7 +1,7 @@ module GHC.Tc.Module where import GHC.Prelude -import GHC.Core.Type(TyThing) +import GHC.Types.TyThing(TyThing) import GHC.Tc.Types (TcM) import GHC.Utils.Outputable (SDoc) import GHC.Types.Name (Name) diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs index db9c3a1b81..b27168a1fc 100644 --- a/compiler/GHC/Tc/Plugin.hs +++ b/compiler/GHC/Tc/Plugin.hs @@ -10,7 +10,7 @@ module GHC.Tc.Plugin ( unsafeTcPluginTcM, -- * Finding Modules and Names - FindResult(..), + Finder.FindResult(..), findImportedModule, lookupOrig, @@ -52,13 +52,13 @@ module GHC.Tc.Plugin ( import GHC.Prelude -import qualified GHC.Tc.Utils.Monad as TcM +import qualified GHC.Tc.Utils.Monad as TcM import qualified GHC.Tc.Solver.Monad as TcS -import qualified GHC.Tc.Utils.Env as TcM +import qualified GHC.Tc.Utils.Env as TcM import qualified GHC.Tc.Utils.TcMType as TcM import qualified GHC.Tc.Instance.Family as TcM import qualified GHC.Iface.Env as IfaceEnv -import qualified GHC.Driver.Finder as Finder +import qualified GHC.Unit.Finder as Finder import GHC.Core.FamInstEnv ( FamInstEnv ) import GHC.Tc.Utils.Monad ( TcGblEnv, TcLclEnv, TcPluginM @@ -73,10 +73,11 @@ import GHC.Types.Var ( EvVar ) import GHC.Unit.Module import GHC.Types.Name +import GHC.Types.TyThing import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.Class -import GHC.Driver.Types +import GHC.Driver.Env import GHC.Utils.Outputable import GHC.Core.Type import GHC.Core.Coercion ( BlockSubstFlag(..) ) @@ -95,7 +96,7 @@ tcPluginTrace :: String -> SDoc -> TcPluginM () tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b) -findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult +findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM Finder.FindResult findImportedModule mod_name mb_pkg = do hsc_env <- getTopEnv tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 4c20eed977..1d8ccb7933 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -129,7 +129,7 @@ module GHC.Tc.Solver.Monad ( import GHC.Prelude -import GHC.Driver.Types +import GHC.Driver.Env import qualified GHC.Tc.Utils.Instantiate as TcM import GHC.Core.InstEnv @@ -155,6 +155,7 @@ import GHC.Core.TyCon import GHC.Tc.Errors ( solverDepthErrorTcS ) import GHC.Types.Name +import GHC.Types.TyThing import GHC.Unit.Module ( HasModule, getModule ) import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt ) import qualified GHC.Rename.Env as TcM diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index bd47bf7bd9..ae30b9d870 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -28,8 +28,11 @@ module GHC.Tc.TyCl ( import GHC.Prelude +import GHC.Driver.Env +import GHC.Driver.Session + import GHC.Hs -import GHC.Driver.Types + import GHC.Tc.TyCl.Build import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX , reportUnsolvedEqualities ) @@ -44,14 +47,17 @@ import GHC.Tc.Deriv (DerivInfo(..)) import GHC.Tc.Gen.HsType import GHC.Tc.Instance.Class( AssocInstInfo(..) ) import GHC.Tc.Utils.TcMType -import GHC.Builtin.Types (oneDataConTy, unitTy, makeRecoveryTyCon ) import GHC.Tc.Utils.TcType -import GHC.Core.Multiplicity -import GHC.Rename.Env( lookupConstructorFields ) import GHC.Tc.Instance.Family +import GHC.Tc.Types.Origin + +import GHC.Builtin.Types (oneDataConTy, unitTy, makeRecoveryTyCon ) + +import GHC.Rename.Env( lookupConstructorFields ) + +import GHC.Core.Multiplicity import GHC.Core.FamInstEnv import GHC.Core.Coercion -import GHC.Tc.Types.Origin import GHC.Core.Type import GHC.Core.TyCo.Rep -- for checkValidRoles import GHC.Core.TyCo.Ppr( pprTyVars ) @@ -59,27 +65,31 @@ import GHC.Core.Class import GHC.Core.Coercion.Axiom import GHC.Core.TyCon import GHC.Core.DataCon +import GHC.Core.Unify + import GHC.Types.Id import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set -import GHC.Data.FastString -import GHC.Unit import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Data.Maybe -import GHC.Core.Unify -import GHC.Utils.Misc import GHC.Types.SrcLoc -import GHC.Data.List.SetOps -import GHC.Driver.Session +import GHC.Types.SourceFile import GHC.Types.Unique import GHC.Types.Basic import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.FastString +import GHC.Data.Maybe +import GHC.Data.List.SetOps + +import GHC.Unit + +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Misc + import Control.Monad import Data.Function ( on ) import Data.Functor.Identity diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs index 93f5eedb50..52a5592d67 100644 --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -34,6 +34,7 @@ import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Type import GHC.Types.Id +import GHC.Types.SourceText import GHC.Tc.Utils.TcType import GHC.Core.Multiplicity diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index baad1622c0..92be85fa06 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -45,7 +45,6 @@ import GHC.Core.Multiplicity import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad -import GHC.Driver.Phases (HscSource(..)) import GHC.Tc.TyCl.Build( TcMethInfo ) import GHC.Core.Class import GHC.Core.Coercion ( pprCoAxiom ) @@ -58,6 +57,7 @@ import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Var import GHC.Types.Var.Env +import GHC.Types.SourceFile (HscSource(..)) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SrcLoc diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 4cc8a79e1e..cc47d1e348 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -67,11 +67,13 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Data.Bag import GHC.Types.Basic +import GHC.Types.Fixity import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Utils.Error import GHC.Data.FastString import GHC.Types.Id +import GHC.Types.SourceText import GHC.Data.List.SetOps import GHC.Types.Name import GHC.Types.Name.Set diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index a225fbdd6d..8755fbf762 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -34,40 +34,49 @@ import GHC.Prelude import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Bind( tcValBinds ) +import GHC.Tc.Utils.TcType + +import GHC.Builtin.Types( unitTy ) +import GHC.Builtin.Uniques ( mkBuiltinUnique ) + +import GHC.Hs + import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) ) import GHC.Core.Multiplicity -import GHC.Tc.Utils.TcType import GHC.Core.Predicate -import GHC.Builtin.Types( unitTy ) import GHC.Core.Make( rEC_SEL_ERROR_ID ) -import GHC.Hs import GHC.Core.Class import GHC.Core.Type -import GHC.Driver.Types import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Reader ( mkVarUnqual ) -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Types.Unique.Set import GHC.Core.TyCon.Set import GHC.Core.Coercion ( ltRole ) -import GHC.Types.Basic -import GHC.Types.SrcLoc -import GHC.Builtin.Uniques ( mkBuiltinUnique ) + import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.FV as FV + import GHC.Data.Maybe import GHC.Data.Bag import GHC.Data.FastString -import GHC.Utils.FV as FV + import GHC.Unit.Module + +import GHC.Types.Basic +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +import GHC.Types.SourceText +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Reader ( mkVarUnqual ) +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.Var.Env +import GHC.Types.Var.Set +import GHC.Types.Unique.Set +import GHC.Types.TyThing import qualified GHC.LanguageExtensions as LangExt import Control.Monad diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 24b4905399..3cda5de56f 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -87,23 +87,30 @@ module GHC.Tc.Types( 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 @@ -111,26 +118,36 @@ import GHC.Types.Name.Set 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 ) @@ -139,8 +156,6 @@ import Data.Maybe ( mapMaybe ) 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 @@ -297,7 +312,7 @@ data IfLclEnv -- 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 @@ -367,7 +382,7 @@ data TcGblEnv 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 @@ -378,7 +393,7 @@ data TcGblEnv -- 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 @@ -501,7 +516,8 @@ data TcGblEnv -- 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 @@ -1285,8 +1301,8 @@ data ImportAvails -- = 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 diff --git a/compiler/GHC/Tc/Types/EvTerm.hs b/compiler/GHC/Tc/Types/EvTerm.hs index 61738f431e..d1a0f56531 100644 --- a/compiler/GHC/Tc/Types/EvTerm.hs +++ b/compiler/GHC/Tc/Types/EvTerm.hs @@ -6,19 +6,25 @@ where import GHC.Prelude -import GHC.Data.FastString +import GHC.Driver.Session + +import GHC.Tc.Types.Evidence + +import GHC.Unit + +import GHC.Builtin.Names + import GHC.Core.Type import GHC.Core import GHC.Core.Make -import GHC.Types.Literal ( Literal(..) ) -import GHC.Tc.Types.Evidence -import GHC.Driver.Types -import GHC.Driver.Session -import GHC.Types.Name -import GHC.Unit import GHC.Core.Utils -import GHC.Builtin.Names + +import GHC.Types.Literal ( Literal(..) ) import GHC.Types.SrcLoc +import GHC.Types.Name +import GHC.Types.TyThing + +import GHC.Data.FastString -- Used with Opt_DeferTypeErrors -- See Note [Deferring coercion errors to runtime] diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 7919f8cc4c..ecdc4ae624 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -18,57 +18,75 @@ module GHC.Tc.Utils.Backpack ( import GHC.Prelude -import GHC.Types.Basic (defaultFixity, TypeOrKind(..)) -import GHC.Unit -import GHC.Tc.Gen.Export +import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr -import GHC.Hs + +import GHC.Types.Basic (TypeOrKind(..)) +import GHC.Types.Fixity (defaultFixity) +import GHC.Types.Fixity.Env +import GHC.Types.TypeEnv import GHC.Types.Name.Reader -import GHC.Tc.Utils.Monad +import GHC.Types.Id +import GHC.Types.Name +import GHC.Types.Name.Env +import GHC.Types.Name.Set +import GHC.Types.Avail +import GHC.Types.SrcLoc +import GHC.Types.SourceFile +import GHC.Types.Var +import GHC.Types.Unique.DSet +import GHC.Types.Name.Shape + +import GHC.Unit +import GHC.Unit.State +import GHC.Unit.Finder +import GHC.Unit.Module.Warnings +import GHC.Unit.Module.ModIface +import GHC.Unit.Module.ModDetails +import GHC.Unit.Module.Imported +import GHC.Unit.Module.Deps + +import GHC.Tc.Gen.Export import GHC.Tc.TyCl.Utils -import GHC.Core.InstEnv -import GHC.Core.FamInstEnv +import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Instantiate -import GHC.IfaceToCore import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Solver import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin -import GHC.Iface.Load -import GHC.Rename.Names -import GHC.Utils.Error -import GHC.Types.Id -import GHC.Types.Name -import GHC.Types.Name.Env -import GHC.Types.Name.Set -import GHC.Types.Avail -import GHC.Types.SrcLoc -import GHC.Driver.Types -import GHC.Utils.Outputable -import GHC.Utils.Panic + +import GHC.Hs + +import GHC.Core.InstEnv +import GHC.Core.FamInstEnv import GHC.Core.Type import GHC.Core.Multiplicity -import GHC.Data.FastString -import GHC.Rename.Fixity ( lookupFixityRn ) -import GHC.Data.Maybe -import GHC.Tc.Utils.Env -import GHC.Types.Var + +import GHC.IfaceToCore +import GHC.Iface.Load +import GHC.Iface.Rename import GHC.Iface.Syntax -import qualified Data.Map as Map -import GHC.Driver.Finder -import GHC.Types.Unique.DSet -import GHC.Types.Name.Shape +import GHC.Rename.Names +import GHC.Rename.Fixity ( lookupFixityRn ) + +import GHC.Tc.Utils.Env import GHC.Tc.Errors import GHC.Tc.Utils.Unify -import GHC.Iface.Rename + import GHC.Utils.Misc -import GHC.Unit.State +import GHC.Utils.Error +import GHC.Utils.Outputable +import GHC.Utils.Panic + +import GHC.Data.FastString +import GHC.Data.Maybe import Control.Monad import Data.List (find) +import qualified Data.Map as Map import {-# SOURCE #-} GHC.Tc.Module diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 2bcc8af641..7755d3370d 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -74,21 +74,27 @@ module GHC.Tc.Utils.Env( import GHC.Prelude +import GHC.Driver.Env +import GHC.Driver.Session + +import GHC.Builtin.Names +import GHC.Builtin.Types + +import GHC.Runtime.Context + import GHC.Hs + import GHC.Iface.Env +import GHC.Iface.Load + import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType -import GHC.Core.UsageEnv import GHC.Tc.Types.Evidence (HsWrapper, idHsWrapper) import {-# SOURCE #-} GHC.Tc.Utils.Unify ( tcSubMult ) import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) ) -import GHC.Iface.Load -import GHC.Builtin.Names -import GHC.Builtin.Types -import GHC.Types.Id -import GHC.Types.Var -import GHC.Types.Name.Reader + +import GHC.Core.UsageEnv import GHC.Core.InstEnv import GHC.Core.DataCon ( DataCon ) import GHC.Core.PatSyn ( PatSyn ) @@ -97,26 +103,35 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion.Axiom import GHC.Core.Class -import GHC.Types.Name -import GHC.Types.Name.Set -import GHC.Types.Name.Env -import GHC.Types.Var.Env -import GHC.Driver.Types -import GHC.Driver.Session -import GHC.Types.SrcLoc -import GHC.Types.Basic hiding( SuccessFlag(..) ) + import GHC.Unit.Module import GHC.Unit.Home +import GHC.Unit.External + import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Encoding +import GHC.Utils.Error +import GHC.Utils.Misc ( HasDebugCallStack ) + import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.List.SetOps -import GHC.Utils.Error import GHC.Data.Maybe( MaybeErr(..), orElse ) + +import GHC.Types.SrcLoc +import GHC.Types.Basic hiding( SuccessFlag(..) ) +import GHC.Types.TypeEnv +import GHC.Types.SourceFile +import GHC.Types.Name +import GHC.Types.Name.Set +import GHC.Types.Name.Env +import GHC.Types.Id +import GHC.Types.Var +import GHC.Types.Var.Env +import GHC.Types.Name.Reader +import GHC.Types.TyThing import qualified GHC.LanguageExtensions as LangExt -import GHC.Utils.Misc ( HasDebugCallStack ) import Data.IORef import Data.List (intercalate) diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index a47e913d17..5416e29692 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -41,47 +41,53 @@ module GHC.Tc.Utils.Instantiate ( import GHC.Prelude -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp ) -import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType, unifyKind ) +import GHC.Driver.Session + +import GHC.Builtin.Types ( heqDataCon, eqDataCon, integerTyConName ) +import GHC.Builtin.Names -import GHC.Types.Basic ( IntegralLit(..), SourceText(..) ) import GHC.Hs + +import GHC.Core.InstEnv +import GHC.Core.Predicate +import GHC.Core ( isOrphan ) +import GHC.Core.Type +import GHC.Core.Multiplicity +import GHC.Core.TyCo.Rep +import GHC.Core.TyCo.Ppr ( debugPprType ) +import GHC.Core.Class( Class ) +import GHC.Core( Expr(..) ) -- For the Coercion constructor +import GHC.Core.DataCon + +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp ) +import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType, unifyKind ) import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Types.Constraint -import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.Env import GHC.Tc.Types.Evidence -import GHC.Core.InstEnv -import GHC.Builtin.Types ( heqDataCon, eqDataCon, integerTyConName ) -import GHC.Core ( isOrphan ) import GHC.Tc.Instance.FunDeps import GHC.Tc.Utils.TcMType -import GHC.Core.Type -import GHC.Core.Multiplicity -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr ( debugPprType ) import GHC.Tc.Utils.TcType -import GHC.Driver.Types -import GHC.Core.Class( Class ) + import GHC.Types.Id.Make( mkDictFunId ) -import GHC.Core( Expr(..) ) -- For the Coercion constructor +import GHC.Types.Basic ( TypeOrKind(..) ) +import GHC.Types.SourceText +import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Var.Env +import GHC.Types.Var.Set import GHC.Types.Id import GHC.Types.Name import GHC.Types.Var -import GHC.Core.DataCon -import GHC.Types.Var.Env -import GHC.Types.Var.Set -import GHC.Builtin.Names -import GHC.Types.SrcLoc as SrcLoc -import GHC.Driver.Session +import qualified GHC.LanguageExtensions as LangExt + import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable -import GHC.Types.Basic ( TypeOrKind(..) ) -import qualified GHC.LanguageExtensions as LangExt + import GHC.Unit.State +import GHC.Unit.External import Data.List ( sortBy, mapAccumL ) import Control.Monad( unless ) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 9910101424..e42fe42799 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -151,47 +151,61 @@ module GHC.Tc.Utils.Monad( import GHC.Prelude -import GHC.Driver.Ppr + +import GHC.Builtin.Names import GHC.Tc.Types -- Re-export all -import GHC.Data.IOEnv -- Re-export all import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin +import GHC.Tc.Utils.TcType import GHC.Hs hiding (LIE) -import GHC.Driver.Types + import GHC.Unit -import GHC.Types.Name.Reader -import GHC.Types.Name +import GHC.Unit.External +import GHC.Unit.Module.Warnings +import GHC.Unit.Home.ModInfo + import GHC.Core.UsageEnv import GHC.Core.Multiplicity -import GHC.Core.Type - -import GHC.Tc.Utils.TcType import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import GHC.Builtin.Names +import GHC.Driver.Env +import GHC.Driver.Ppr +import GHC.Driver.Session + +import GHC.Runtime.Context + +import GHC.Data.IOEnv -- Re-export all +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.Maybe + +import GHC.Utils.Outputable as Outputable +import GHC.Utils.Error +import GHC.Utils.Panic +import GHC.Utils.Misc + +import GHC.Types.Fixity.Env +import GHC.Types.Name.Reader +import GHC.Types.Name +import GHC.Types.SafeHaskell import GHC.Types.Id +import GHC.Types.TypeEnv import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Utils.Error import GHC.Types.SrcLoc import GHC.Types.Name.Env import GHC.Types.Name.Set -import GHC.Data.Bag -import GHC.Utils.Outputable as Outputable +import GHC.Types.Name.Ppr import GHC.Types.Unique (uniqFromMask) import GHC.Types.Unique.Supply -import GHC.Driver.Session -import GHC.Data.FastString -import GHC.Utils.Panic -import GHC.Utils.Misc import GHC.Types.Annotations import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) ) -import GHC.Data.Maybe import GHC.Types.CostCentre.State +import GHC.Types.SourceFile import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index 54258c7e52..412fc5aa43 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -182,7 +182,7 @@ module GHC.Tc.Utils.TcType ( -------------------------------- pprKind, pprParendKind, pprSigmaType, - pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory, + pprType, pprParendType, pprTypeApp, pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred, pprTCvBndr, pprTCvBndrs, diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index a47b75adc2..85587c29f8 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -47,43 +47,52 @@ module GHC.Tc.Utils.Zonk ( import GHC.Prelude +import GHC.Platform + +import GHC.Builtin.Types +import GHC.Builtin.Types.Prim +import GHC.Builtin.Names + import GHC.Hs -import GHC.Types.Id -import GHC.Types.Id.Info -import GHC.Core.Predicate + +import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) import GHC.Tc.Utils.Monad -import GHC.Builtin.Names import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Env ( tcLookupGlobalOnly ) import GHC.Tc.Types.Evidence + import GHC.Core.TyCo.Ppr ( pprTyVar ) -import GHC.Builtin.Types.Prim import GHC.Core.TyCon -import GHC.Builtin.Types import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.ConLike import GHC.Core.DataCon -import GHC.Driver.Types + +import GHC.Utils.Outputable +import GHC.Utils.Misc +import GHC.Utils.Panic + +import GHC.Core.Multiplicity +import GHC.Core +import GHC.Core.Predicate + import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Var import GHC.Types.Var.Env -import GHC.Platform +import GHC.Types.Id +import GHC.Types.Id.Info +import GHC.Types.TypeEnv +import GHC.Types.SourceText import GHC.Types.Basic -import GHC.Data.Maybe import GHC.Types.SrcLoc -import GHC.Data.Bag -import GHC.Utils.Outputable -import GHC.Utils.Misc -import GHC.Utils.Panic import GHC.Types.Unique.FM -import GHC.Core.Multiplicity -import GHC.Core +import GHC.Types.TyThing -import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) +import GHC.Data.Maybe +import GHC.Data.Bag import Control.Monad import Data.List ( partition ) diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 83ffbaa831..2ff30da251 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -42,8 +42,10 @@ import GHC.Core.Type as Hs import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import GHC.Builtin.Types import GHC.Types.Basic as Hs +import GHC.Types.Fixity as Hs import GHC.Types.ForeignCall import GHC.Types.Unique +import GHC.Types.SourceText import GHC.Utils.Error import GHC.Data.Bag import GHC.Utils.Lexeme diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 5942f24d56..e4705fdc9a 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -33,14 +33,6 @@ module GHC.Types.Basic ( 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 @@ module GHC.Types.Basic ( 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 @@ instance Outputable LeftOrRight where 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 @@ instance Outputable PromotionFlag where 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 @@ instance Outputable FunctionOrData where 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,81 +449,6 @@ type RuleName = FastString 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" {- ************************************************************************ @@ -637,6 +524,17 @@ instance Outputable RecFlag where ppr Recursive = text "Recursive" ppr NonRecursive = text "NonRecursive" +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 + {- ************************************************************************ * * @@ -775,6 +673,31 @@ instance Outputable OverlapMode where 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 @@ instance Outputable TupleSort where 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 -> do return BoxedTuple + 1 -> do return UnboxedTuple + _ -> do return ConstraintTuple + + tupleSortBoxity :: TupleSort -> Boxity tupleSortBoxity BoxedTuple = Boxed tupleSortBoxity UnboxedTuple = Unboxed @@ -1226,83 +1161,6 @@ failed Failed = True {- ************************************************************************ * * -\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} * * ************************************************************************ @@ -1624,19 +1482,87 @@ instance Outputable Activation where ppr (ActiveAfter _ n) = brackets (int n) ppr FinalActive = text "[final]" +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 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 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 @@ -1663,99 +1589,6 @@ pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation -{- ********************************************************************* -* * - 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)) - {- ************************************************************************ * * diff --git a/compiler/GHC/Types/CompleteMatch.hs b/compiler/GHC/Types/CompleteMatch.hs new file mode 100644 index 0000000000..7ad521f738 --- /dev/null +++ b/compiler/GHC/Types/CompleteMatch.hs @@ -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] + diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs new file mode 100644 index 0000000000..52fe3837b7 --- /dev/null +++ b/compiler/GHC/Types/Error.hs @@ -0,0 +1,241 @@ +{-# 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 _) = 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 } + diff --git a/compiler/GHC/Types/Fixity.hs b/compiler/GHC/Types/Fixity.hs new file mode 100644 index 0000000000..fb8807ab9d --- /dev/null +++ b/compiler/GHC/Types/Fixity.hs @@ -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 = 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 + +------------------------ +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" diff --git a/compiler/GHC/Types/Fixity/Env.hs b/compiler/GHC/Types/Fixity/Env.hs new file mode 100644 index 0000000000..3f3c38d860 --- /dev/null +++ b/compiler/GHC/Types/Fixity/Env.hs @@ -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 + diff --git a/compiler/GHC/Types/ForeignCall.hs b/compiler/GHC/Types/ForeignCall.hs index e811604efb..bf10a9a197 100644 --- a/compiler/GHC/Types/ForeignCall.hs +++ b/compiler/GHC/Types/ForeignCall.hs @@ -25,7 +25,7 @@ import GHC.Utils.Binary 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 @@ playInterruptible _ = False 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 @@ data CCallTarget -- 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 @@ instance Outputable CCallSpec where = 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 @@ instance Outputable Header where -- '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) diff --git a/compiler/GHC/Types/ForeignStubs.hs b/compiler/GHC/Types/ForeignStubs.hs new file mode 100644 index 0000000000..eb4e45243e --- /dev/null +++ b/compiler/GHC/Types/ForeignStubs.hs @@ -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) diff --git a/compiler/GHC/Types/HpcInfo.hs b/compiler/GHC/Types/HpcInfo.hs new file mode 100644 index 0000000000..12b4020422 --- /dev/null +++ b/compiler/GHC/Types/HpcInfo.hs @@ -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 + diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 85b9b06ad9..7a0990ee48 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -57,6 +57,7 @@ import GHC.Core.Utils ( mkCast, mkDefaultCase ) 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 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 diff --git a/compiler/GHC/Types/Meta.hs b/compiler/GHC/Types/Meta.hs new file mode 100644 index 0000000000..9160988a3e --- /dev/null +++ b/compiler/GHC/Types/Meta.hs @@ -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) + diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs index fa38678896..0b834cbe2b 100644 --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -81,7 +81,7 @@ module GHC.Types.Name ( import GHC.Prelude -import {-# SOURCE #-} GHC.Core.TyCo.Rep( TyThing ) +import {-# SOURCE #-} GHC.Types.TyThing ( TyThing ) import GHC.Platform import GHC.Types.Name.Occurrence @@ -308,7 +308,7 @@ nameIsLocalOrFrom :: Module -> Name -> Bool -- 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 @@ -624,7 +624,7 @@ pprSystem debug sty uniq occ 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 diff --git a/compiler/GHC/Types/Name/Ppr.hs b/compiler/GHC/Types/Name/Ppr.hs new file mode 100644 index 0000000000..3b64e4bbdf --- /dev/null +++ b/compiler/GHC/Types/Name/Ppr.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE CPP #-} + +module GHC.Types.Name.Ppr + ( mkPrintUnqualified + , mkQualModule + , mkQualPackage + , pkgQual + ) +where + +#include "HsVersions.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 } diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs index a978abb467..733a5472b8 100644 --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -1061,7 +1061,7 @@ There are two reasons for shadowing: 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. diff --git a/compiler/GHC/Types/Name/Shape.hs b/compiler/GHC/Types/Name/Shape.hs index 96b7073cce..9228a15fa8 100644 --- a/compiler/GHC/Types/Name/Shape.hs +++ b/compiler/GHC/Types/Name/Shape.hs @@ -15,19 +15,22 @@ where import GHC.Prelude -import GHC.Utils.Outputable -import GHC.Driver.Types +import GHC.Driver.Env + import GHC.Unit.Module + import GHC.Types.Unique.FM import GHC.Types.Avail import GHC.Types.FieldLabel - import GHC.Types.Name import GHC.Types.Name.Env + import GHC.Tc.Utils.Monad +import GHC.Iface.Env + +import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Iface.Env import Control.Monad diff --git a/compiler/GHC/Types/SafeHaskell.hs b/compiler/GHC/Types/SafeHaskell.hs new file mode 100644 index 0000000000..853676a9db --- /dev/null +++ b/compiler/GHC/Types/SafeHaskell.hs @@ -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) diff --git a/compiler/GHC/Types/SourceError.hs b/compiler/GHC/Types/SourceError.hs new file mode 100644 index 0000000000..657178cc51 --- /dev/null +++ b/compiler/GHC/Types/SourceError.hs @@ -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) + diff --git a/compiler/GHC/Types/SourceFile.hs b/compiler/GHC/Types/SourceFile.hs new file mode 100644 index 0000000000..e8faec7a58 --- /dev/null +++ b/compiler/GHC/Types/SourceFile.hs @@ -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. + diff --git a/compiler/GHC/Types/SourceText.hs b/compiler/GHC/Types/SourceText.hs new file mode 100644 index 0000000000..320abbea27 --- /dev/null +++ b/compiler/GHC/Types/SourceText.hs @@ -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) + diff --git a/compiler/GHC/Types/Target.hs b/compiler/GHC/Types/Target.hs new file mode 100644 index 0000000000..8f2c0649d4 --- /dev/null +++ b/compiler/GHC/Types/Target.hs @@ -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 + diff --git a/compiler/GHC/Types/TyThing.hs b/compiler/GHC/Types/TyThing.hs new file mode 100644 index 0000000000..eebcf3796d --- /dev/null +++ b/compiler/GHC/Types/TyThing.hs @@ -0,0 +1,315 @@ +-- | 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.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)] + +-- | 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 + + diff --git a/compiler/GHC/Types/TyThing.hs-boot b/compiler/GHC/Types/TyThing.hs-boot new file mode 100644 index 0000000000..94ecee24b4 --- /dev/null +++ b/compiler/GHC/Types/TyThing.hs-boot @@ -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 diff --git a/compiler/GHC/Core/Ppr/TyThing.hs b/compiler/GHC/Types/TyThing/Ppr.hs index 5a7a60acd2..aad90365a7 100644 --- a/compiler/GHC/Core/Ppr/TyThing.hs +++ b/compiler/GHC/Types/TyThing/Ppr.hs @@ -7,7 +7,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE CPP #-} -module GHC.Core.Ppr.TyThing ( +module GHC.Types.TyThing.Ppr ( pprTyThing, pprTyThingInContext, pprTyThingLoc, @@ -21,17 +21,21 @@ module GHC.Core.Ppr.TyThing ( import GHC.Prelude -import GHC.Core.Type ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType ) -import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..) - , showToHeader, pprIfaceDecl ) +import GHC.Driver.Ppr (warnPprTrace) + +import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe ) +import GHC.Types.Name +import GHC.Types.Var.Env( emptyTidyEnv ) + +import GHC.Core.Type ( Type, ArgFlag(..), mkTyVarBinders, tidyOpenType ) import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) -import GHC.Driver.Types( tyThingParent_maybe ) -import GHC.Driver.Ppr -import GHC.Iface.Make ( tyThingToIfaceDecl ) import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) ) import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType ) -import GHC.Types.Name -import GHC.Types.Var.Env( emptyTidyEnv ) + +import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..) + , showToHeader, pprIfaceDecl ) +import GHC.Iface.Make ( tyThingToIfaceDecl ) + import GHC.Utils.Outputable -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Types/TypeEnv.hs b/compiler/GHC/Types/TypeEnv.hs new file mode 100644 index 0000000000..b7811a5721 --- /dev/null +++ b/compiler/GHC/Types/TypeEnv.hs @@ -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 + diff --git a/compiler/GHC/Unit/External.hs b/compiler/GHC/Unit/External.hs new file mode 100644 index 0000000000..2ee6191ec9 --- /dev/null +++ b/compiler/GHC/Unit/External.hs @@ -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 } + diff --git a/compiler/GHC/Driver/Finder.hs b/compiler/GHC/Unit/Finder.hs index 57a9551b0f..da5c589024 100644 --- a/compiler/GHC/Driver/Finder.hs +++ b/compiler/GHC/Unit/Finder.hs @@ -1,15 +1,17 @@ {- (c) The University of Glasgow, 2000-2006 -\section[Finder]{Module Finder} -} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -module GHC.Driver.Finder ( - flushFinderCaches, +-- | Module finder +module GHC.Unit.Finder ( FindResult(..), + InstalledFindResult(..), + FinderCache, + flushFinderCaches, findImportedModule, findPluginModule, findExactModule, @@ -36,21 +38,28 @@ module GHC.Driver.Finder ( import GHC.Prelude +import GHC.Driver.Env +import GHC.Driver.Session + +import GHC.Platform.Ways + +import GHC.Builtin.Names ( gHC_PRIM ) + import GHC.Unit.Types import GHC.Unit.Module import GHC.Unit.Home import GHC.Unit.State +import GHC.Unit.Finder.Types -import GHC.Driver.Types import GHC.Data.FastString +import GHC.Data.Maybe ( expectJust ) import qualified GHC.Data.ShortText as ST + import GHC.Utils.Misc -import GHC.Builtin.Names ( gHC_PRIM ) -import GHC.Driver.Session -import GHC.Platform.Ways import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Data.Maybe ( expectJust ) + +import GHC.Runtime.Linker.Types import Data.IORef ( IORef, readIORef, atomicModifyIORef' ) import System.Directory diff --git a/compiler/GHC/Unit/Finder/Types.hs b/compiler/GHC/Unit/Finder/Types.hs new file mode 100644 index 0000000000..094f77be3a --- /dev/null +++ b/compiler/GHC/Unit/Finder/Types.hs @@ -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 + } + diff --git a/compiler/GHC/Unit/Home/ModInfo.hs b/compiler/GHC/Unit/Home/ModInfo.hs new file mode 100644 index 0000000000..9732955521 --- /dev/null +++ b/compiler/GHC/Unit/Home/ModInfo.hs @@ -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 ] + diff --git a/compiler/GHC/Unit/Module/Deps.hs b/compiler/GHC/Unit/Module/Deps.hs new file mode 100644 index 0000000000..5bdd23239b --- /dev/null +++ b/compiler/GHC/Unit/Module/Deps.hs @@ -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) diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs new file mode 100644 index 0000000000..faa3ae9b1a --- /dev/null +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -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 + diff --git a/compiler/GHC/Unit/Module/Imported.hs b/compiler/GHC/Unit/Module/Imported.hs new file mode 100644 index 0000000000..d6cd3ac88f --- /dev/null +++ b/compiler/GHC/Unit/Module/Imported.hs @@ -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 + } + diff --git a/compiler/GHC/Unit/Module/ModDetails.hs b/compiler/GHC/Unit/Module/ModDetails.hs new file mode 100644 index 0000000000..31b3bdb9a0 --- /dev/null +++ b/compiler/GHC/Unit/Module/ModDetails.hs @@ -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 = [] + } diff --git a/compiler/GHC/Unit/Module/ModGuts.hs b/compiler/GHC/Unit/Module/ModGuts.hs new file mode 100644 index 0000000000..4b75dff099 --- /dev/null +++ b/compiler/GHC/Unit/Module/ModGuts.hs @@ -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" + } diff --git a/compiler/GHC/Unit/Module/ModIface.hs b/compiler/GHC/Unit/Module/ModIface.hs new file mode 100644 index 0000000000..83bc565b6f --- /dev/null +++ b/compiler/GHC/Unit/Module/ModIface.hs @@ -0,0 +1,537 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# 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 + + + diff --git a/compiler/GHC/Unit/Module/ModSummary.hs b/compiler/GHC/Unit/Module/ModSummary.hs new file mode 100644 index 0000000000..a0b42fc2a4 --- /dev/null +++ b/compiler/GHC/Unit/Module/ModSummary.hs @@ -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 diff --git a/compiler/GHC/Unit/Module/Status.hs b/compiler/GHC/Unit/Module/Status.hs new file mode 100644 index 0000000000..d7fb83e582 --- /dev/null +++ b/compiler/GHC/Unit/Module/Status.hs @@ -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. + } diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs new file mode 100644 index 0000000000..d8847be72c --- /dev/null +++ b/compiler/GHC/Unit/Module/Warnings.hs @@ -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) + diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs index 2975ab2d0d..dbc2cdc195 100644 --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -77,7 +77,6 @@ import GHC.Utils.Panic.Plain 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 +89,11 @@ import Data.IORef 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,184 +864,7 @@ instance Binary (Bin a) where put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32) get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) --- ----------------------------------------------------------------------------- --- 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 +1029,10 @@ instance Binary FastString where 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 NoUserInlinePrag = putByte bh 0 - put_ bh Inline = putByte bh 1 - put_ bh Inlinable = putByte bh 2 - put_ bh NoInline = putByte bh 3 - - get bh = do h <- getByte bh - case h of - 0 -> return NoUserInlinePrag - 1 -> return Inline - 2 -> return Inlinable - _ -> return NoInline - -instance Binary RecFlag where - put_ bh Recursive = do - putByte bh 0 - put_ bh NonRecursive = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return Recursive - _ -> do return NonRecursive - -instance Binary OverlapMode where - put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s - put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s - put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s - put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s - put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s - get bh = do - h <- getByte bh - case h of - 0 -> (get bh) >>= \s -> return $ NoOverlap s - 1 -> (get bh) >>= \s -> return $ Overlaps s - 2 -> (get bh) >>= \s -> return $ Incoherent s - 3 -> (get bh) >>= \s -> return $ Overlapping s - 4 -> (get bh) >>= \s -> return $ Overlappable s - _ -> panic ("get OverlapMode" ++ show h) - - -instance Binary OverlapFlag where - put_ bh flag = do put_ bh (overlapMode flag) - put_ bh (isSafeOverlap flag) - get bh = do - h <- get bh - b <- get bh - return OverlapFlag { overlapMode = h, isSafeOverlap = b } - -instance Binary FixityDirection where - put_ bh InfixL = do - putByte bh 0 - put_ bh InfixR = do - putByte bh 1 - put_ bh InfixN = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return InfixL - 1 -> do return InfixR - _ -> do return InfixN - -instance Binary Fixity where - put_ bh (Fixity src aa ab) = do - put_ bh src - put_ bh aa - put_ bh ab - get bh = do - src <- get bh - aa <- get bh - ab <- get bh - return (Fixity src aa ab) - -instance Binary WarningTxt where - put_ bh (WarningTxt s w) = do - putByte bh 0 - put_ bh s - put_ bh w - put_ bh (DeprecatedTxt s d) = do - putByte bh 1 - put_ bh s - put_ bh d - - get bh = do - h <- getByte bh - case h of - 0 -> do s <- get bh - w <- get bh - return (WarningTxt s w) - _ -> do s <- get bh - d <- get bh - return (DeprecatedTxt s d) - -instance Binary StringLiteral where - put_ bh (StringLiteral st fs) = do - put_ bh st - put_ bh fs - get bh = do - st <- get bh - fs <- get bh - return (StringLiteral st fs) - instance Binary a => Binary (Located a) where put_ bh (L l x) = do put_ bh l @@ -1488,27 +1108,3 @@ instance Binary SrcSpan where 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 diff --git a/compiler/GHC/Utils/Binary/Typeable.hs b/compiler/GHC/Utils/Binary/Typeable.hs new file mode 100644 index 0000000000..580b245ded --- /dev/null +++ b/compiler/GHC/Utils/Binary/Typeable.hs @@ -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 "HsVersions.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) + diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 1bd3e57f56..2db4672f07 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -58,24 +58,27 @@ module GHC.Utils.Error ( debugTraceMsg, ghcExit, prettyPrintGhcErrors, - traceCmd + traceCmd, + + -- * Compilation errors and warnings + printOrThrowWarnings, handleFlagWarnings, shouldPrintWarning ) where #include "HsVersions.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 ) @@ -91,12 +94,9 @@ import Control.Monad 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,209 +126,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. @@ -993,3 +790,44 @@ dumpAction dflags = dump_action dflags dflags -- | 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 + diff --git a/compiler/GHC/Utils/Error.hs-boot b/compiler/GHC/Utils/Error.hs-boot index 20c6930fa5..a455e730f2 100644 --- a/compiler/GHC/Utils/Error.hs-boot +++ b/compiler/GHC/Utils/Error.hs-boot @@ -4,8 +4,6 @@ module GHC.Utils.Error where 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 @@ data DumpFormat | 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 diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index ea9c8daecd..489c20cd75 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -198,7 +198,7 @@ type QueryQualifyModule = Module -> Bool -- 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 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index f653c154b0..78f23a4b8b 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -155,249 +155,308 @@ Library ,MonoLocalBinds Exposed-Modules: - GHC.Iface.Ext.Types - GHC.Iface.Ext.Debug - GHC.Iface.Ext.Binary - GHC.Iface.Ext.Utils - GHC.Iface.Ext.Ast - GHC.SysTools.Ar - GHC.SysTools.FileCleanup - GHC.Driver.Backend - GHC.Driver.Backpack - GHC.Driver.Backpack.Syntax - GHC.Types.Name.Shape - GHC.Iface.Rename - GHC.Types.Avail - GHC.Utils.Asm - GHC.Types.Basic - GHC.Core.ConLike - GHC.Core.DataCon - GHC.Core.PatSyn - GHC.Types.Demand - GHC.Types.Cpr - GHC.Cmm.DebugBlock - GHC.Utils.Exception - GHC.Utils.GlobalVars - GHC.Types.FieldLabel - GHC.Driver.Monad - GHC.Driver.Hooks - GHC.Driver.Flags - GHC.Driver.Ppr - GHC.Types.Id - GHC.Types.Id.Info - GHC.Core.Predicate - GHC.Utils.Lexeme - GHC.Types.Literal - GHC.Llvm - GHC.Llvm.Syntax - GHC.Llvm.MetaData - GHC.Llvm.Ppr - GHC.Llvm.Types - GHC.CmmToLlvm - GHC.CmmToLlvm.Base - GHC.CmmToLlvm.CodeGen - GHC.CmmToLlvm.Data - GHC.CmmToLlvm.Ppr - GHC.CmmToLlvm.Regs - GHC.CmmToLlvm.Mangler - GHC.Types.Id.Make - GHC.Unit - GHC.Unit.Home - GHC.Unit.Parser - GHC.Unit.Ppr - GHC.Unit.Types - GHC.Unit.Module - GHC.Unit.Module.Name - GHC.Unit.Module.Location - GHC.Unit.Module.Env - GHC.Types.Name - GHC.Types.Name.Env - GHC.Types.Name.Set - GHC.Types.Name.Occurrence - GHC.Types.Name.Reader - GHC.Types.Name.Cache - GHC.Types.SrcLoc - GHC.Types.Unique.Supply - GHC.Types.Unique - GHC.Iface.UpdateIdInfos - GHC.Types.Var - GHC.Types.Var.Env - GHC.Types.Var.Set - GHC.Data.Graph.UnVar - GHC.Cmm.BlockId - GHC.Cmm.CLabel + GHC + GHC.Builtin.Names + GHC.Builtin.Names.TH + GHC.Builtin.PrimOps + GHC.Builtin.RebindableNames + GHC.Builtin.Types + GHC.Builtin.Types.Literals + GHC.Builtin.Types.Prim + GHC.Builtin.Uniques + GHC.Builtin.Utils + GHC.ByteCode.Asm + GHC.ByteCode.InfoTable + GHC.ByteCode.Instr + GHC.ByteCode.Linker + GHC.ByteCode.Types GHC.Cmm - GHC.Cmm.Info.Build - GHC.Cmm.Pipeline + GHC.Cmm.BlockId GHC.Cmm.CallConv + GHC.Cmm.CLabel GHC.Cmm.CommonBlockElim - GHC.Cmm.Switch.Implement GHC.Cmm.ContFlowOpt + GHC.Cmm.Dataflow + GHC.Cmm.Dataflow.Block + GHC.Cmm.Dataflow.Collections + GHC.Cmm.Dataflow.Graph + GHC.Cmm.Dataflow.Label + GHC.Cmm.DebugBlock GHC.Cmm.Expr + GHC.Cmm.Graph GHC.Cmm.Info + GHC.Cmm.Info.Build + GHC.Cmm.LayoutStack GHC.Cmm.Lexer GHC.Cmm.Lint GHC.Cmm.Liveness GHC.Cmm.MachOp - GHC.Cmm.Parser.Monad - GHC.Cmm.Switch GHC.Cmm.Node GHC.Cmm.Opt GHC.Cmm.Parser + GHC.Cmm.Parser.Monad + GHC.Cmm.Pipeline + GHC.Cmm.Ppr + GHC.Cmm.Ppr.Decl + GHC.Cmm.Ppr.Expr GHC.Cmm.ProcPoint GHC.Cmm.Sink - GHC.Cmm.Type - GHC.Cmm.Utils - GHC.Cmm.LayoutStack - GHC.Utils.CliOption - GHC.Data.EnumSet - GHC.Cmm.Graph - GHC.CmmToAsm.Ppr + GHC.Cmm.Switch + GHC.Cmm.Switch.Implement + GHC.CmmToAsm + GHC.CmmToAsm.BlockLayout + GHC.CmmToAsm.CFG + GHC.CmmToAsm.CFG.Dominators + GHC.CmmToAsm.CFG.Weight GHC.CmmToAsm.Config + GHC.CmmToAsm.CPrim + GHC.CmmToAsm.Dwarf + GHC.CmmToAsm.Dwarf.Constants + GHC.CmmToAsm.Dwarf.Types + GHC.CmmToAsm.Format + GHC.CmmToAsm.Instr + GHC.CmmToAsm.Monad + GHC.CmmToAsm.PIC + GHC.CmmToAsm.PPC + GHC.CmmToAsm.PPC.CodeGen + GHC.CmmToAsm.PPC.Cond + GHC.CmmToAsm.PPC.Instr + GHC.CmmToAsm.PPC.Ppr + GHC.CmmToAsm.PPC.RegInfo + GHC.CmmToAsm.PPC.Regs + GHC.CmmToAsm.Ppr + GHC.CmmToAsm.Reg.Graph + GHC.CmmToAsm.Reg.Graph.Base + GHC.CmmToAsm.Reg.Graph.Coalesce + GHC.CmmToAsm.Reg.Graph.Spill + GHC.CmmToAsm.Reg.Graph.SpillClean + GHC.CmmToAsm.Reg.Graph.SpillCost + GHC.CmmToAsm.Reg.Graph.Stats + GHC.CmmToAsm.Reg.Graph.TrivColorable + GHC.CmmToAsm.Reg.Graph.X86 + GHC.CmmToAsm.Reg.Linear + GHC.CmmToAsm.Reg.Linear.Base + GHC.CmmToAsm.Reg.Linear.FreeRegs + GHC.CmmToAsm.Reg.Linear.JoinToTargets + GHC.CmmToAsm.Reg.Linear.PPC + GHC.CmmToAsm.Reg.Linear.SPARC + GHC.CmmToAsm.Reg.Linear.StackMap + GHC.CmmToAsm.Reg.Linear.State + GHC.CmmToAsm.Reg.Linear.Stats + GHC.CmmToAsm.Reg.Linear.X86 + GHC.CmmToAsm.Reg.Linear.X86_64 + GHC.CmmToAsm.Reg.Liveness + GHC.CmmToAsm.Reg.Target + GHC.CmmToAsm.Reg.Utils + GHC.CmmToAsm.SPARC + GHC.CmmToAsm.SPARC.AddrMode + GHC.CmmToAsm.SPARC.Base + GHC.CmmToAsm.SPARC.CodeGen + GHC.CmmToAsm.SPARC.CodeGen.Amode + GHC.CmmToAsm.SPARC.CodeGen.Base + GHC.CmmToAsm.SPARC.CodeGen.CondCode + GHC.CmmToAsm.SPARC.CodeGen.Expand + GHC.CmmToAsm.SPARC.CodeGen.Gen32 + GHC.CmmToAsm.SPARC.CodeGen.Gen64 + GHC.CmmToAsm.SPARC.CodeGen.Sanity + GHC.CmmToAsm.SPARC.Cond + GHC.CmmToAsm.SPARC.Imm + GHC.CmmToAsm.SPARC.Instr + GHC.CmmToAsm.SPARC.Ppr + GHC.CmmToAsm.SPARC.Regs + GHC.CmmToAsm.SPARC.ShortcutJump + GHC.CmmToAsm.SPARC.Stack + GHC.CmmToAsm.Types + GHC.CmmToAsm.Utils + GHC.CmmToAsm.X86 + GHC.CmmToAsm.X86.CodeGen + GHC.CmmToAsm.X86.Cond + GHC.CmmToAsm.X86.Instr + GHC.CmmToAsm.X86.Ppr + GHC.CmmToAsm.X86.RegInfo + GHC.CmmToAsm.X86.Regs GHC.CmmToC - GHC.Cmm.Ppr - GHC.Cmm.Ppr.Decl - GHC.Cmm.Ppr.Expr - GHC.Data.Bitmap - GHC.Platform - GHC.Platform.Constants - GHC.Platform.Ways - GHC.Platform.Profile - GHC.Platform.Regs - GHC.Platform.ARM - GHC.Platform.ARM64 - GHC.Platform.NoRegs - GHC.Platform.PPC - GHC.Platform.S390X - GHC.Platform.SPARC - GHC.Platform.X86 - GHC.Platform.X86_64 - GHC.StgToCmm.CgUtils - GHC.StgToCmm - GHC.StgToCmm.Bind - GHC.StgToCmm.Closure - GHC.StgToCmm.DataCon - GHC.StgToCmm.Env - GHC.StgToCmm.Expr - GHC.StgToCmm.Foreign - GHC.StgToCmm.Heap - GHC.StgToCmm.Hpc - GHC.StgToCmm.ArgRep - GHC.StgToCmm.Layout - GHC.StgToCmm.Monad - GHC.StgToCmm.Prim - GHC.StgToCmm.Prof - GHC.StgToCmm.Ticky - GHC.StgToCmm.Utils - GHC.StgToCmm.ExtCode - GHC.StgToCmm.Types - GHC.Runtime.Heap.Layout - GHC.Core.Opt.Arity + GHC.CmmToLlvm + GHC.CmmToLlvm.Base + GHC.CmmToLlvm.CodeGen + GHC.CmmToLlvm.Data + GHC.CmmToLlvm.Mangler + GHC.CmmToLlvm.Ppr + GHC.CmmToLlvm.Regs + GHC.Cmm.Type + GHC.Cmm.Utils + GHC.Core + GHC.Core.Class + GHC.Core.Coercion + GHC.Core.Coercion.Axiom + GHC.Core.Coercion.Opt + GHC.Core.ConLike + GHC.Core.DataCon + GHC.Core.FamInstEnv GHC.Core.FVs + GHC.Core.InstEnv GHC.Core.Lint - GHC.Core.Subst + GHC.Core.Make + GHC.Core.Map + GHC.Core.Multiplicity + GHC.Core.Opt.Arity + GHC.Core.Opt.CallArity + GHC.Core.Opt.ConstantFold + GHC.Core.Opt.CprAnal + GHC.Core.Opt.CSE + GHC.Core.Opt.DmdAnal + GHC.Core.Opt.Exitify + GHC.Core.Opt.FloatIn + GHC.Core.Opt.FloatOut + GHC.Core.Opt.LiberateCase + GHC.Core.Opt.Monad + GHC.Core.Opt.OccurAnal + GHC.Core.Opt.Pipeline + GHC.Core.Opt.SetLevels + GHC.Core.Opt.Simplify + GHC.Core.Opt.Simplify.Env + GHC.Core.Opt.Simplify.Monad + GHC.Core.Opt.Simplify.Utils + GHC.Core.Opt.SpecConstr + GHC.Core.Opt.Specialise + GHC.Core.Opt.StaticArgs + GHC.Core.Opt.WorkWrap + GHC.Core.Opt.WorkWrap.Utils + GHC.Core.PatSyn + GHC.Core.Ppr + GHC.Types.TyThing.Ppr + GHC.Core.Predicate + GHC.Core.Rules + GHC.Core.Seq GHC.Core.SimpleOpt - GHC.Core - GHC.Data.TrieMap + GHC.Core.Stats + GHC.Core.Subst GHC.Core.Tidy + GHC.CoreToByteCode + GHC.CoreToIface + GHC.CoreToStg + GHC.CoreToStg.Prep + GHC.Core.TyCo.FVs + GHC.Core.TyCon + GHC.Core.TyCon.Env + GHC.Core.TyCon.RecWalk + GHC.Core.TyCon.Set + GHC.Core.TyCo.Ppr + GHC.Core.TyCo.Rep + GHC.Core.TyCo.Subst + GHC.Core.TyCo.Tidy + GHC.Core.Type GHC.Core.Unfold GHC.Core.Unfold.Make + GHC.Core.Unify + GHC.Core.UsageEnv GHC.Core.Utils - GHC.Core.Map - GHC.Core.Seq - GHC.Core.Stats - GHC.Core.Make - GHC.Core.Ppr - GHC.HsToCore.Pmc - GHC.HsToCore.Pmc.Types - GHC.HsToCore.Pmc.Utils - GHC.HsToCore.Pmc.Desugar - GHC.HsToCore.Pmc.Check - GHC.HsToCore.Pmc.Solver.Types - GHC.HsToCore.Pmc.Solver - GHC.HsToCore.Pmc.Ppr - GHC.HsToCore.Coverage + GHC.Data.Bag + GHC.Data.Bitmap + GHC.Data.BooleanFormula + GHC.Data.EnumSet + GHC.Data.FastMutInt + GHC.Data.FastString + GHC.Data.FastString.Env + GHC.Data.FiniteMap + GHC.Data.Graph.Base + GHC.Data.Graph.Color + GHC.Data.Graph.Directed + GHC.Data.Graph.Ops + GHC.Data.Graph.Ppr + GHC.Data.Graph.UnVar + GHC.Data.IOEnv + GHC.Data.List.SetOps + GHC.Data.Maybe + GHC.Data.OrdList + GHC.Data.Pair + GHC.Data.Stream + GHC.Data.StringBuffer + GHC.Data.TrieMap + GHC.Driver.Backend + GHC.Driver.Backpack + GHC.Driver.Backpack.Syntax + GHC.Driver.CmdLine + GHC.Driver.CodeOutput + GHC.Driver.Config + GHC.Driver.Env + GHC.Driver.Flags + GHC.Driver.Hooks + GHC.Driver.Main + GHC.Driver.Make + GHC.Driver.MakeFile + GHC.Driver.Monad + GHC.Driver.Phases + GHC.Driver.Pipeline + GHC.Driver.Pipeline.Monad + GHC.Driver.Plugins + GHC.Driver.Ppr + GHC.Driver.Session + GHC.Hs + GHC.Hs.Binds + GHC.Hs.Decls + GHC.Hs.Doc + GHC.Hs.Dump + GHC.Hs.Expr + GHC.Hs.Extension + GHC.Hs.ImpExp + GHC.Hs.Instances + GHC.Hs.Lit + GHC.Hs.Pat + GHC.Hs.Stats GHC.HsToCore - GHC.HsToCore.Types GHC.HsToCore.Arrows GHC.HsToCore.Binds - GHC.HsToCore.Foreign.Call + GHC.HsToCore.Coverage + GHC.HsToCore.Docs GHC.HsToCore.Expr + GHC.HsToCore.Foreign.Call GHC.HsToCore.Foreign.Decl GHC.HsToCore.GuardedRHSs GHC.HsToCore.ListComp - GHC.HsToCore.Monad - GHC.HsToCore.Usage - GHC.HsToCore.Utils - GHC.HsToCore.Docs GHC.HsToCore.Match GHC.HsToCore.Match.Constructor GHC.HsToCore.Match.Literal - GHC.Hs - GHC.Hs.Binds - GHC.Hs.Decls - GHC.Hs.Doc - GHC.Hs.Expr - GHC.Hs.ImpExp - GHC.Hs.Lit - GHC.Hs.Extension - GHC.Hs.Instances - GHC.Hs.Pat + GHC.HsToCore.Monad + GHC.HsToCore.Pmc + GHC.HsToCore.Pmc.Check + GHC.HsToCore.Pmc.Desugar + GHC.HsToCore.Pmc.Ppr + GHC.HsToCore.Pmc.Solver + GHC.HsToCore.Pmc.Solver.Types + GHC.HsToCore.Pmc.Types + GHC.HsToCore.Pmc.Utils + GHC.HsToCore.Quote + GHC.HsToCore.Types + GHC.HsToCore.Usage + GHC.HsToCore.Utils GHC.Hs.Type GHC.Hs.Utils - GHC.Hs.Dump GHC.Iface.Binary - GHC.Iface.Recomp.Binary - GHC.Tc.TyCl.Build GHC.Iface.Env - GHC.Iface.Syntax - GHC.Iface.Type - GHC.CoreToIface + GHC.Iface.Ext.Ast + GHC.Iface.Ext.Binary + GHC.Iface.Ext.Debug + GHC.Iface.Ext.Fields + GHC.Iface.Ext.Types + GHC.Iface.Ext.Utils GHC.Iface.Load GHC.Iface.Make GHC.Iface.Recomp - GHC.IfaceToCore + GHC.Iface.Recomp.Binary GHC.Iface.Recomp.Flags - GHC.Types.Annotations - GHC.Driver.CmdLine - GHC.Driver.Config - GHC.Driver.CodeOutput - GHC.Settings.Config - GHC.Settings.Constants - GHC.Driver.MakeFile - GHC.Driver.Phases - GHC.Driver.Pipeline.Monad - GHC.Driver.Pipeline - GHC.Driver.Session - GHC.Utils.Error - GHC.Driver.Finder - GHC - GHC.Driver.Make - GHC.Plugins - GHC.Prelude - GHC.Driver.Main - GHC.Hs.Stats - GHC.Driver.Types - GHC.Runtime.Eval - GHC.Runtime.Eval.Types - GHC.Runtime.Loader - GHC.Unit.Info - GHC.Unit.State - GHC.Driver.Plugins - GHC.Tc.Plugin - GHC.Core.Ppr.TyThing - GHC.Settings - GHC.Iface.Tidy.StaticPtrTable - GHC.SysTools - GHC.SysTools.BaseDir - GHC.SysTools.Terminal - GHC.SysTools.ExtraObj - GHC.SysTools.Info - GHC.SysTools.Process - GHC.SysTools.Tasks - GHC.Settings.IO - GHC.SysTools.Elf + GHC.Iface.Rename + GHC.Iface.Syntax GHC.Iface.Tidy + GHC.Iface.Tidy.StaticPtrTable + GHC.IfaceToCore + GHC.Iface.Type + GHC.Iface.UpdateIdInfos + GHC.Llvm + GHC.Llvm.MetaData + GHC.Llvm.Ppr + GHC.Llvm.Syntax + GHC.Llvm.Types GHC.Parser GHC.Parser.Annotation GHC.Parser.CharClass @@ -408,270 +467,239 @@ Library GHC.Parser.PostProcess GHC.Parser.PostProcess.Haddock GHC.Parser.Types - GHC.Core.Coercion.Opt - GHC.Types.ForeignCall - GHC.Builtin.Uniques - GHC.Builtin.Utils - GHC.Builtin.Names - GHC.Core.Opt.ConstantFold - GHC.Builtin.PrimOps - GHC.Builtin.RebindableNames - GHC.Builtin.Types.Prim - GHC.Builtin.Types - GHC.Types.CostCentre - GHC.Types.CostCentre.State + GHC.Platform + GHC.Platform.ARM + GHC.Platform.ARM64 + GHC.Platform.Constants + GHC.Platform.NoRegs + GHC.Platform.PPC + GHC.Platform.Profile + GHC.Platform.Reg + GHC.Platform.Reg.Class + GHC.Platform.Regs + GHC.Platform.S390X + GHC.Platform.SPARC + GHC.Platform.Ways + GHC.Platform.X86 + GHC.Platform.X86_64 + GHC.Plugins + GHC.Prelude GHC.Rename.Bind GHC.Rename.Env GHC.Rename.Expr + GHC.Rename.Fixity + GHC.Rename.HsType + GHC.Rename.Module GHC.Rename.Names GHC.Rename.Pat - GHC.Rename.Module GHC.Rename.Splice - GHC.Rename.HsType - GHC.Rename.Fixity - GHC.Rename.Utils GHC.Rename.Unbound - GHC.Core.Opt.Monad - GHC.Core.Opt.CSE - GHC.Core.Opt.FloatIn - GHC.Core.Opt.FloatOut - GHC.Core.Opt.LiberateCase - GHC.Core.Opt.OccurAnal - GHC.Core.Opt.StaticArgs - GHC.Core.Opt.SetLevels - GHC.Core.Opt.Pipeline - GHC.Core.Opt.Simplify.Env - GHC.Core.Opt.Simplify.Monad - GHC.Core.Opt.Simplify.Utils - GHC.Core.Opt.Simplify - GHC.Stg.Pipeline - GHC.Stg.Stats + GHC.Rename.Utils + GHC.Runtime.Context + GHC.Runtime.Debugger + GHC.Runtime.Eval + GHC.Runtime.Eval.Types + GHC.Runtime.Heap.Inspect + GHC.Runtime.Heap.Layout + GHC.Runtime.Interpreter + GHC.Runtime.Interpreter.Types + GHC.Runtime.Linker + GHC.Runtime.Linker.Types + GHC.Runtime.Loader + GHC.Settings + GHC.Settings.Config + GHC.Settings.Constants + GHC.Settings.IO GHC.Stg.CSE + GHC.Stg.DepAnal + GHC.Stg.FVs GHC.Stg.Lift GHC.Stg.Lift.Analysis GHC.Stg.Lift.Monad - GHC.Stg.Subst - GHC.Stg.Unarise GHC.Stg.Lint + GHC.Stg.Pipeline + GHC.Stg.Stats + GHC.Stg.Subst GHC.Stg.Syntax - GHC.Stg.FVs - GHC.Stg.DepAnal - GHC.CoreToStg - GHC.CoreToStg.Prep - GHC.Types.RepType - GHC.Core.Rules - GHC.Core.Opt.SpecConstr - GHC.Core.Opt.Specialise - GHC.Core.Opt.CallArity - GHC.Core.Opt.DmdAnal - GHC.Core.Opt.CprAnal - GHC.Core.Opt.Exitify - GHC.Core.Opt.WorkWrap - GHC.Core.Opt.WorkWrap.Utils - GHC.Tc.Instance.Family - GHC.Tc.Instance.Class - GHC.Tc.Utils.Instantiate + GHC.StgToCmm + GHC.StgToCmm.ArgRep + GHC.StgToCmm.Bind + GHC.StgToCmm.CgUtils + GHC.StgToCmm.Closure + GHC.StgToCmm.DataCon + GHC.StgToCmm.Env + GHC.StgToCmm.Expr + GHC.StgToCmm.ExtCode + GHC.StgToCmm.Foreign + GHC.StgToCmm.Heap + GHC.StgToCmm.Hpc + GHC.StgToCmm.Layout + GHC.StgToCmm.Monad + GHC.StgToCmm.Prim + GHC.StgToCmm.Prof + GHC.StgToCmm.Ticky + GHC.StgToCmm.Types + GHC.StgToCmm.Utils + GHC.Stg.Unarise + GHC.SysTools + GHC.SysTools.Ar + GHC.SysTools.BaseDir + GHC.SysTools.Elf + GHC.SysTools.ExtraObj + GHC.SysTools.FileCleanup + GHC.SysTools.Info + GHC.SysTools.Process + GHC.SysTools.Tasks + GHC.SysTools.Terminal + GHC.Tc.Deriv + GHC.Tc.Deriv.Functor + GHC.Tc.Deriv.Generate + GHC.Tc.Deriv.Generics + GHC.Tc.Deriv.Infer + GHC.Tc.Deriv.Utils + GHC.Tc.Errors + GHC.Tc.Errors.Hole + GHC.Tc.Errors.Hole.FitTypes GHC.Tc.Gen.Annotation + GHC.Tc.Gen.App GHC.Tc.Gen.Arrow GHC.Tc.Gen.Bind - GHC.Tc.Gen.Sig - GHC.Tc.TyCl.Class GHC.Tc.Gen.Default - GHC.Tc.Deriv - GHC.Tc.Deriv.Infer - GHC.Tc.Deriv.Utils - GHC.Tc.Utils.Env + GHC.Tc.Gen.Export GHC.Tc.Gen.Expr - GHC.Tc.Gen.App - GHC.Tc.Gen.Head GHC.Tc.Gen.Foreign - GHC.Tc.Deriv.Generate - GHC.Tc.Deriv.Functor - GHC.Tc.Deriv.Generics - GHC.Tc.Utils.Zonk - GHC.Tc.Utils.TcType - GHC.Tc.TyCl.Instance - GHC.Tc.Utils.TcMType - GHC.Tc.Validity + GHC.Tc.Gen.Head + GHC.Tc.Gen.HsType GHC.Tc.Gen.Match GHC.Tc.Gen.Pat - GHC.Tc.TyCl.PatSyn - GHC.Tc.Module - GHC.Tc.Utils.Backpack - GHC.Tc.Gen.Export - GHC.Tc.Utils.Monad - GHC.Tc.Types - GHC.Tc.Types.Constraint - GHC.Tc.Types.Origin GHC.Tc.Gen.Rule - GHC.Tc.Errors.Hole - GHC.Tc.Errors.Hole.FitTypes - GHC.Tc.Errors - GHC.Tc.TyCl - GHC.Tc.TyCl.Utils + GHC.Tc.Gen.Sig + GHC.Tc.Gen.Splice + GHC.Tc.Instance.Class + GHC.Tc.Instance.Family + GHC.Tc.Instance.FunDeps GHC.Tc.Instance.Typeable - GHC.Tc.Gen.HsType - GHC.Tc.Types.Evidence - GHC.Tc.Types.EvTerm - GHC.Tc.Utils.Unify + GHC.Tc.Module + GHC.Tc.Plugin GHC.Tc.Solver - GHC.Tc.Solver.Interact GHC.Tc.Solver.Canonical GHC.Tc.Solver.Flatten + GHC.Tc.Solver.Interact GHC.Tc.Solver.Monad - GHC.Builtin.Types.Literals - GHC.Tc.Gen.Splice - GHC.Core.Class - GHC.Core.Coercion - GHC.HsToCore.Quote - GHC.Builtin.Names.TH - GHC.Core.FamInstEnv - GHC.Tc.Instance.FunDeps - GHC.Core.InstEnv - GHC.Core.Multiplicity - GHC.Core.UsageEnv - GHC.Core.TyCon - GHC.Core.TyCon.Env - GHC.Core.TyCon.Set - GHC.Core.TyCon.RecWalk - GHC.Core.Coercion.Axiom - GHC.Core.Type - GHC.Core.TyCo.Rep - GHC.Core.TyCo.FVs - GHC.Core.TyCo.Subst - GHC.Core.TyCo.Ppr - GHC.Core.TyCo.Tidy - GHC.Core.Unify - GHC.Data.Bag + GHC.Tc.TyCl + GHC.Tc.TyCl.Build + GHC.Tc.TyCl.Class + GHC.Tc.TyCl.Instance + GHC.Tc.TyCl.PatSyn + GHC.Tc.TyCl.Utils + GHC.Tc.Types + GHC.Tc.Types.Constraint + GHC.Tc.Types.Evidence + GHC.Tc.Types.EvTerm + GHC.Tc.Types.Origin + GHC.Tc.Utils.Backpack + GHC.Tc.Utils.Env + GHC.Tc.Utils.Instantiate + GHC.Tc.Utils.Monad + GHC.Tc.Utils.TcMType + GHC.Tc.Utils.TcType + GHC.Tc.Utils.Unify + GHC.Tc.Utils.Zonk + GHC.Tc.Validity + GHC.ThToHs + 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.Reader + GHC.Types.Name.Set + GHC.Types.Name.Shape + GHC.Types.Name.Ppr + GHC.Types.RepType + GHC.Types.SafeHaskell + GHC.Types.SourceError + GHC.Types.SourceFile + GHC.Types.SourceText + GHC.Types.SrcLoc + GHC.Types.Target + GHC.Types.TypeEnv + GHC.Types.TyThing + GHC.Types.Unique + GHC.Types.Unique.DFM + GHC.Types.Unique.DSet + GHC.Types.Unique.FM + GHC.Types.Unique.SDFM + GHC.Types.Unique.Set + GHC.Types.Unique.Supply + GHC.Types.Var + GHC.Types.Var.Env + GHC.Types.Var.Set + GHC.Unit + GHC.Unit.External + GHC.Unit.Finder + 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.Asm GHC.Utils.Binary - GHC.Data.BooleanFormula + GHC.Utils.Binary.Typeable GHC.Utils.BufHandle - GHC.Data.Graph.Directed - GHC.Utils.IO.Unsafe - GHC.Data.FastMutInt - GHC.Data.FastString - GHC.Data.FastString.Env + GHC.Utils.CliOption + GHC.Utils.Error + GHC.Utils.Exception GHC.Utils.Fingerprint - GHC.Data.FiniteMap GHC.Utils.FV - GHC.Data.Graph.Base - GHC.Data.Graph.Color - GHC.Data.Graph.Ops - GHC.Data.Graph.Ppr - GHC.Data.IOEnv + GHC.Utils.GlobalVars + GHC.Utils.IO.Unsafe GHC.Utils.Json - GHC.Data.List.SetOps - GHC.Data.Maybe + GHC.Utils.Lexeme + GHC.Utils.Misc GHC.Utils.Monad - GHC.Data.OrdList + GHC.Utils.Monad.State GHC.Utils.Outputable - GHC.Data.Pair GHC.Utils.Panic GHC.Utils.Panic.Plain - GHC.Utils.Ppr.Colour GHC.Utils.Ppr - GHC.Utils.Monad.State - GHC.Data.Stream - GHC.Data.StringBuffer - GHC.Types.Unique.DFM - GHC.Types.Unique.SDFM - GHC.Types.Unique.DSet - GHC.Types.Unique.FM - GHC.Types.Unique.Set - GHC.Utils.Misc - GHC.Cmm.Dataflow - GHC.Cmm.Dataflow.Block - GHC.Cmm.Dataflow.Collections - GHC.Cmm.Dataflow.Graph - GHC.Cmm.Dataflow.Label + GHC.Utils.Ppr.Colour reexported-modules: GHC.Platform.ArchOS , GHC.Platform.Host - - Exposed-Modules: - GHC.CmmToAsm - GHC.CmmToAsm.Reg.Target - GHC.CmmToAsm.Monad - GHC.CmmToAsm.Instr - GHC.CmmToAsm.BlockLayout - GHC.CmmToAsm.CFG - GHC.CmmToAsm.CFG.Weight - GHC.CmmToAsm.CFG.Dominators - GHC.CmmToAsm.Format - GHC.Platform.Reg - GHC.Platform.Reg.Class - GHC.CmmToAsm.PIC - GHC.CmmToAsm.CPrim - GHC.CmmToAsm.Types - GHC.CmmToAsm.Utils - GHC.CmmToAsm.X86 - GHC.CmmToAsm.X86.Regs - GHC.CmmToAsm.X86.RegInfo - GHC.CmmToAsm.X86.Instr - GHC.CmmToAsm.X86.Cond - GHC.CmmToAsm.X86.Ppr - GHC.CmmToAsm.X86.CodeGen - GHC.CmmToAsm.PPC - GHC.CmmToAsm.PPC.Regs - GHC.CmmToAsm.PPC.RegInfo - GHC.CmmToAsm.PPC.Instr - GHC.CmmToAsm.PPC.Cond - GHC.CmmToAsm.PPC.Ppr - GHC.CmmToAsm.PPC.CodeGen - GHC.CmmToAsm.SPARC - GHC.CmmToAsm.SPARC.Base - GHC.CmmToAsm.SPARC.Regs - GHC.CmmToAsm.SPARC.Imm - GHC.CmmToAsm.SPARC.AddrMode - GHC.CmmToAsm.SPARC.Cond - GHC.CmmToAsm.SPARC.Instr - GHC.CmmToAsm.SPARC.Stack - GHC.CmmToAsm.SPARC.ShortcutJump - GHC.CmmToAsm.SPARC.Ppr - GHC.CmmToAsm.SPARC.CodeGen - GHC.CmmToAsm.SPARC.CodeGen.Amode - GHC.CmmToAsm.SPARC.CodeGen.Base - GHC.CmmToAsm.SPARC.CodeGen.CondCode - GHC.CmmToAsm.SPARC.CodeGen.Gen32 - GHC.CmmToAsm.SPARC.CodeGen.Gen64 - GHC.CmmToAsm.SPARC.CodeGen.Sanity - GHC.CmmToAsm.SPARC.CodeGen.Expand - GHC.CmmToAsm.Reg.Liveness - GHC.CmmToAsm.Reg.Graph - GHC.CmmToAsm.Reg.Graph.Stats - GHC.CmmToAsm.Reg.Graph.Base - GHC.CmmToAsm.Reg.Graph.X86 - GHC.CmmToAsm.Reg.Graph.Coalesce - GHC.CmmToAsm.Reg.Graph.Spill - GHC.CmmToAsm.Reg.Graph.SpillClean - GHC.CmmToAsm.Reg.Graph.SpillCost - GHC.CmmToAsm.Reg.Graph.TrivColorable - GHC.CmmToAsm.Reg.Linear - GHC.CmmToAsm.Reg.Linear.JoinToTargets - GHC.CmmToAsm.Reg.Linear.State - GHC.CmmToAsm.Reg.Linear.Stats - GHC.CmmToAsm.Reg.Linear.FreeRegs - GHC.CmmToAsm.Reg.Linear.StackMap - GHC.CmmToAsm.Reg.Linear.Base - GHC.CmmToAsm.Reg.Linear.X86 - GHC.CmmToAsm.Reg.Linear.X86_64 - GHC.CmmToAsm.Reg.Linear.PPC - GHC.CmmToAsm.Reg.Linear.SPARC - GHC.CmmToAsm.Reg.Utils - GHC.CmmToAsm.Dwarf - GHC.CmmToAsm.Dwarf.Types - GHC.CmmToAsm.Dwarf.Constants - GHC.ThToHs - GHC.ByteCode.Types - GHC.ByteCode.Asm - GHC.ByteCode.Instr - GHC.ByteCode.InfoTable - GHC.ByteCode.Linker - GHC.CoreToByteCode - GHC.Runtime.Debugger - GHC.Runtime.Linker.Types - GHC.Runtime.Linker - GHC.Runtime.Heap.Inspect - GHC.Runtime.Interpreter - GHC.Runtime.Interpreter.Types diff --git a/ghc/GHCi/Leak.hs b/ghc/GHCi/Leak.hs index 88c64ecc15..99f49fddb9 100644 --- a/ghc/GHCi/Leak.hs +++ b/ghc/GHCi/Leak.hs @@ -11,10 +11,13 @@ import Foreign.Ptr (ptrToIntPtr, intPtrToPtr) import GHC import GHC.Ptr (Ptr (..)) import GHCi.Util -import GHC.Driver.Types +import GHC.Driver.Env import GHC.Driver.Ppr import GHC.Utils.Outputable +import GHC.Unit.Module.ModDetails +import GHC.Unit.Home.ModInfo import GHC.Platform (target32Bit) +import GHC.Runtime.Linker.Types import Prelude import System.Mem import System.Mem.Weak diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index ac96def464..d41f46a4a2 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -44,34 +44,40 @@ import GHC.Runtime.Interpreter import GHC.Runtime.Interpreter.Types import GHCi.RemoteTypes import GHCi.BreakArray -import GHC.Unit.State +import GHC.ByteCode.Types +import GHC.Driver.Phases import GHC.Driver.Session as DynFlags import GHC.Driver.Ppr hiding (printForUser) import GHC.Utils.Error hiding (traceCmd) -import GHC.Driver.Finder as Finder import GHC.Driver.Monad ( modifySession ) import GHC.Driver.Config import qualified GHC -import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), - TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, +import GHC ( LoadHowMuch(..), Target(..), TargetId(..), + Resume, SingleStep, Ghc, GetDocsFailure(..), getModuleGraph, handleSourceError, ms_mod ) import GHC.Driver.Main (hscParseDeclsWithLocation, hscParseStmtWithLocation) import GHC.Hs.ImpExp import GHC.Hs -import GHC.Driver.Types ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, - setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc, - hsc_dynLinker, hsc_interp, emptyModBreaks ) -import GHC.Unit +import GHC.Driver.Env +import GHC.Runtime.Context +import GHC.Types.TyThing +import GHC.Types.TyThing.Ppr +import GHC.Types.SafeHaskell ( getSafeMode ) import GHC.Types.Name +import GHC.Types.SourceText import GHC.Iface.Syntax ( showToHeader ) -import GHC.Core.Ppr.TyThing import GHC.Builtin.Names import GHC.Builtin.Types( stringTyCon_RDR ) import GHC.Types.Name.Reader as RdrName ( getGRE_NameQualifier_maybes, getRdrName ) import GHC.Types.SrcLoc as SrcLoc import qualified GHC.Parser.Lexer as Lexer +import GHC.Unit +import GHC.Unit.State +import GHC.Unit.Finder as Finder +import GHC.Unit.Module.ModSummary + import GHC.Data.StringBuffer import GHC.Utils.Outputable diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index aec9149c4c..87de1a83cb 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -44,12 +44,14 @@ import qualified GHC.Driver.Ppr as Ppr import GHC.Types.Name.Occurrence import GHC.Driver.Session import GHC.Data.FastString -import GHC.Driver.Types +import GHC.Driver.Env import GHC.Types.SrcLoc +import GHC.Types.SafeHaskell import GHC.Unit import GHC.Types.Name.Reader as RdrName (mkOrig) import GHC.Builtin.Names (gHC_GHCI_HELPERS) import GHC.Runtime.Interpreter +import GHC.Runtime.Context import GHCi.RemoteTypes import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl) import GHC.Hs.Utils diff --git a/ghc/Main.hs b/ghc/Main.hs index c079cb6893..41a2f9340a 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -18,58 +18,61 @@ module Main (main) where import qualified GHC import GHC (parseTargetFiles, Ghc, GhcMonad(..), Backend (..), LoadHowMuch(..) ) -import GHC.Driver.CmdLine --- Implementations of the various modes (--show-iface, mkdependHS. etc.) -import GHC.Iface.Load ( showIface ) +import GHC.Driver.CmdLine +import GHC.Driver.Env +import GHC.Driver.Phases +import GHC.Driver.Session hiding (WarnReason(..)) +import GHC.Driver.Ppr import GHC.Driver.Main ( newHscEnv ) import GHC.Driver.Pipeline ( oneShot, compileFile ) import GHC.Driver.MakeFile ( doMkDependHS ) import GHC.Driver.Backpack ( doBackpack ) +import GHC.Driver.Plugins + +import GHC.Platform import GHC.Platform.Ways -#if defined(HAVE_INTERNAL_INTERPRETER) -import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) -#endif +import GHC.Platform.Host --- Frontend plugins -import GHC.Runtime.Loader ( loadFrontendPlugin ) -import GHC.Driver.Plugins #if defined(HAVE_INTERNAL_INTERPRETER) +import GHCi.UI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) import GHC.Runtime.Loader ( initializePlugins ) #endif -import GHC.Unit.Module ( ModuleName, mkModuleName ) +import GHC.Runtime.Loader ( loadFrontendPlugin ) + +import GHC.Unit.Module ( ModuleName, mkModuleName ) +import GHC.Unit.Module.ModIface +import GHC.Unit.State ( pprUnits, pprUnitsSimple ) +import GHC.Unit.Finder ( findImportedModule, cannotFindModule, FindResult(..) ) +import GHC.Unit.Types ( IsBootInterface(..) ) --- Various other random stuff that we need -import GHC.HandleEncoding -import GHC.Platform -import GHC.Platform.Host -import GHC.Settings.Config -import GHC.Settings.Constants -import GHC.Driver.Types -import GHC.Unit.State ( pprUnits, pprUnitsSimple ) -import GHC.Driver.Phases import GHC.Types.Basic ( failed ) -import GHC.Driver.Session hiding (WarnReason(..)) -import GHC.Driver.Ppr -import GHC.Utils.Error -import GHC.Data.FastString -import GHC.Utils.Outputable as Outputable -import GHC.SysTools.BaseDir -import GHC.Settings.IO import GHC.Types.SrcLoc +import GHC.Types.SourceError +import GHC.Types.Unique.Supply + +import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Panic -import GHC.Types.Unique.Supply +import GHC.Utils.Outputable as Outputable import GHC.Utils.Monad ( liftIO ) +import GHC.Utils.Binary ( openBinMem, put_ ) + +import GHC.Settings.Config +import GHC.Settings.Constants +import GHC.Settings.IO + +import GHC.HandleEncoding +import GHC.Data.FastString +import GHC.SysTools.BaseDir --- Imports for --abi-hash +import GHC.Iface.Load ( showIface ) import GHC.Iface.Load ( loadUserInterface ) -import GHC.Driver.Finder ( findImportedModule, cannotFindModule ) -import GHC.Tc.Utils.Monad ( initIfaceCheck ) -import GHC.Utils.Binary ( openBinMem, put_ ) import GHC.Iface.Recomp.Binary ( fingerprintBinMem ) +import GHC.Tc.Utils.Monad ( initIfaceCheck ) + -- Standard Haskell libraries import System.IO import System.Environment diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs index 8b31eb683d..f669bfbd6d 100644 --- a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs +++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs @@ -11,8 +11,8 @@ import GHC.Utils.Outputable import GHC.Tc.Module import GHC.Tc.Utils.Zonk import GHC.Utils.Error -import GHC.Driver.Types import GHC.Driver.Ppr +import GHC.Driver.Env import GHC import qualified GHC.LanguageExtensions as LangExt diff --git a/testsuite/tests/ghc-api/T4891/T4891.hs b/testsuite/tests/ghc-api/T4891/T4891.hs index 201293178d..89a8403b94 100644 --- a/testsuite/tests/ghc-api/T4891/T4891.hs +++ b/testsuite/tests/ghc-api/T4891/T4891.hs @@ -7,7 +7,6 @@ import Data.Array import GHC.Core.DataCon import GHC import GHC.Exts.Heap -import GHC.Driver.Types import GHC.Driver.Ppr import GHC.Runtime.Linker import GHC.Runtime.Heap.Inspect diff --git a/testsuite/tests/ghc-api/annotations-literals/parsed.hs b/testsuite/tests/ghc-api/annotations-literals/parsed.hs index 3b35373f93..a97a067ce5 100644 --- a/testsuite/tests/ghc-api/annotations-literals/parsed.hs +++ b/testsuite/tests/ghc-api/annotations-literals/parsed.hs @@ -4,6 +4,7 @@ module Main where import GHC.Types.Basic +import GHC.Types.SourceText import Data.Data import Data.List (intercalate) import System.IO diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs index e281186dc9..b07b00a2ce 100644 --- a/testsuite/tests/ghc-api/annotations/stringSource.hs +++ b/testsuite/tests/ghc-api/annotations/stringSource.hs @@ -12,6 +12,8 @@ import Data.List (intercalate) import System.IO import GHC import GHC.Types.Basic +import GHC.Types.SourceText +import GHC.Unit.Module.Warnings import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Data.FastString diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs index a3a76dda96..0e702769c2 100644 --- a/testsuite/tests/ghc-api/annotations/t11430.hs +++ b/testsuite/tests/ghc-api/annotations/t11430.hs @@ -12,6 +12,8 @@ import Data.List (intercalate) import System.IO import GHC import GHC.Types.Basic +import GHC.Types.SourceText +import GHC.Types.Fixity import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Data.FastString diff --git a/testsuite/tests/ghc-api/downsweep/OldModLocation.hs b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs index d3aeddd0bc..76338b0f1e 100644 --- a/testsuite/tests/ghc-api/downsweep/OldModLocation.hs +++ b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs @@ -3,7 +3,7 @@ import GHC import GHC.Driver.Make import GHC.Driver.Session -import GHC.Driver.Finder +import GHC.Unit.Finder import Control.Monad.IO.Class (liftIO) import Data.List (sort, stripPrefix) diff --git a/testsuite/tests/ghc-api/target-contents/TargetContents.hs b/testsuite/tests/ghc-api/target-contents/TargetContents.hs index f21b84ca87..4d8ecf1596 100644 --- a/testsuite/tests/ghc-api/target-contents/TargetContents.hs +++ b/testsuite/tests/ghc-api/target-contents/TargetContents.hs @@ -14,7 +14,8 @@ import Data.Time.Calendar import Data.Time.Clock import GHC.Utils.Exception import GHC.Parser.Header -import GHC.Driver.Types +import GHC.Types.Target +import GHC.Types.SourceError import GHC.Utils.Outputable import GHC.Data.StringBuffer import System.Directory diff --git a/testsuite/tests/parser/should_run/CountParserDeps.hs b/testsuite/tests/parser/should_run/CountParserDeps.hs index bf84f2a0ac..a676fe79cc 100644 --- a/testsuite/tests/parser/should_run/CountParserDeps.hs +++ b/testsuite/tests/parser/should_run/CountParserDeps.hs @@ -10,7 +10,7 @@ module Main(main) where -- provided with as small a number of modules as possible for when the -- need exists to produce ASTs and nothing more. -import GHC.Driver.Types +import GHC.Driver.Env import GHC.Unit.Module import GHC.Driver.Session import GHC.Driver.Main @@ -22,13 +22,14 @@ import Control.Monad.IO.Class import System.Environment import System.Exit import GHC.Types.Unique.Set +import GHC.Unit.Module.Deps main :: IO () main = do [libdir] <- getArgs modules <- parserDeps libdir let num = sizeUniqSet modules - max_num = 205 + max_num = 234 min_num = max_num - 10 -- so that we don't forget to change the number -- when the number of dependencies decreases -- putStrLn $ "Found " ++ show num ++ " parser module dependencies" diff --git a/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs b/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs index a74ac8cac3..616d202d29 100644 --- a/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs +++ b/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -Wall #-} module Hooks.Plugin (plugin) where -import GHC.Types.Basic +import GHC.Types.SourceText import GHC.Plugins import GHC.Hs.Expr import GHC.Hs.Extension diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs index 1dba8ff3c0..13f5611948 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs @@ -4,8 +4,8 @@ module Simple.RemovePlugin where import Control.Monad.IO.Class import Data.List (intercalate) import GHC.Driver.Plugins +import GHC.Plugins import GHC.Data.Bag -import GHC.Driver.Types import GHC.Tc.Types import GHC.Hs.Extension import GHC.Hs.Expr diff --git a/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs index dfadc4bc8b..6c11eba246 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs @@ -5,11 +5,11 @@ import Data.List (intercalate) import Data.Maybe (isJust) import GHC.Driver.Plugins import GHC.Driver.Session -import GHC.Driver.Types -import GHC.Driver.Ppr +import GHC.Plugins import GHC.Tc.Types import GHC.Hs.Extension import GHC.Types.Avail +import GHC.Hs import GHC.Hs.Expr import GHC.Utils.Outputable import GHC.Hs.ImpExp diff --git a/testsuite/tests/plugins/static-plugins.hs b/testsuite/tests/plugins/static-plugins.hs index 47cbb462a2..f3433aa0ac 100644 --- a/testsuite/tests/plugins/static-plugins.hs +++ b/testsuite/tests/plugins/static-plugins.hs @@ -11,7 +11,6 @@ import GHC.Hs.Doc import GHC.Hs.Expr import GHC.Hs.Extension import GHC.Hs.ImpExp -import GHC.Driver.Types import GHC.Utils.Outputable import GHC.Driver.Plugins import System.Environment diff --git a/utils/haddock b/utils/haddock -Subproject a7d1d8e034d25612d5d08ed8fdbf6f472aded4a +Subproject 904a3c276643d15da24303493b62e95dfb0b772 |