diff options
Diffstat (limited to 'compiler')
32 files changed, 1166 insertions, 339 deletions
diff --git a/compiler/.hlint.yaml b/compiler/.hlint.yaml index 14a5ec1164..4b821ffd27 100644 --- a/compiler/.hlint.yaml +++ b/compiler/.hlint.yaml @@ -24,3 +24,11 @@ - ignore: {name: Use fewer imports, within: [GHC.Parser, GHC.Cmm.Parser ] } - ignore: {name: Redundant return, within: [GHC.Data.FastString] } - ignore: {within: [GHC.Parser, GHC.Parser.Lexer, GHC.Parser.HaddockLex] } + + +## Restricted modules + +- warn: {name: Avoid restricted module} +# see comments in affected modules +- modules: + - {name: [GHC.Driver.Backend.Internal], within: [GHC.Driver.Backend], message: "This module is for clients of the GHC API only. Do not use it within the compiler."} diff --git a/compiler/GHC.hs b/compiler/GHC.hs index b532a2fa97..5d57c0d2fa 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -27,7 +27,8 @@ module GHC ( handleSourceError, -- * Flags and settings - DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt, + DynFlags(..), GeneralFlag(..), Severity(..), Backend, gopt, + ncgBackend, llvmBackend, viaCBackend, interpreterBackend, noBackend, GhcMode(..), GhcLink(..), parseDynamicFlags, parseTargetFiles, getSessionDynFlags, diff --git a/compiler/GHC/Cmm/Switch.hs b/compiler/GHC/Cmm/Switch.hs index f8c6c674ef..b0f22ce1b3 100644 --- a/compiler/GHC/Cmm/Switch.hs +++ b/compiler/GHC/Cmm/Switch.hs @@ -8,7 +8,7 @@ module GHC.Cmm.Switch ( switchTargetsToList, eqSwitchTargetWith, SwitchPlan(..), - backendSupportsSwitch, + backendHasNativeSwitch, createSwitchPlan, ) where @@ -312,13 +312,6 @@ and slowed down all other cases making it not worthwhile. -} --- | Does the backend support switch out of the box? Then leave this to the --- backend! -backendSupportsSwitch :: Backend -> Bool -backendSupportsSwitch ViaC = True -backendSupportsSwitch LLVM = True -backendSupportsSwitch _ = False - -- | This function creates a SwitchPlan from a SwitchTargets value, breaking it -- down into smaller pieces suitable for code generation. createSwitchPlan :: SwitchTargets -> SwitchPlan diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs index 338aa3a927..f72411c4ec 100644 --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -35,8 +34,6 @@ module GHC.CmmToLlvm.Base ( aliasify, llvmDefLabel ) where -#include "ghc-llvm-version.h" - import GHC.Prelude import GHC.Utils.Panic diff --git a/compiler/GHC/CmmToLlvm/Config.hs b/compiler/GHC/CmmToLlvm/Config.hs index f516b9787b..649a33c2f6 100644 --- a/compiler/GHC/CmmToLlvm/Config.hs +++ b/compiler/GHC/CmmToLlvm/Config.hs @@ -133,4 +133,3 @@ llvmVersionStr = intercalate "." . map show . llvmVersionList llvmVersionList :: LlvmVersion -> [Int] llvmVersionList = NE.toList . llvmVersionNE - diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index 8c372d3396..1904344788 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/compiler/GHC/Core/Opt/ConstantFold.hs @@ -1415,8 +1415,8 @@ as follows: in ... This was originally done in the fix to #16449 but this breaks the let-can-float -invariant (see Note [Core let-can-float invariant] in GHC.Core) as noted in -#16742. For the reasons discussed in Note [Checking versus non-checking +invariant (see Note [Core let-can-float invariant] in GHC.Core) as noted in #16742. +For the reasons discussed in Note [Checking versus non-checking primops] (in the PrimOp module) there is no safe way to rewrite the argument of I# such that it bottoms. diff --git a/compiler/GHC/Driver/Backend.hs b/compiler/GHC/Driver/Backend.hs index 2642a2a9af..a27a2e7b4a 100644 --- a/compiler/GHC/Driver/Backend.hs +++ b/compiler/GHC/Driver/Backend.hs @@ -1,95 +1,205 @@ {-# LANGUAGE MultiWayIf #-} --- | Code generation backends +{-| +Module : GHC.Driver.Backend +Description : Back ends for code generation + +This module exports the `Backend` type and all the available values +of that type. The type is abstract, and GHC assumes a "closed world": +all the back ends are known and are known here. The compiler driver +chooses a `Backend` value based on how it is asked to generate code. + +A `Backend` value encapsulates the knowledge needed to take Cmm, STG, +or Core and write assembly language to a file. A back end also +provides a function that enables the compiler driver to run an +assembler on the code that is written, if any (the "post-backend +pipeline"). Finally, a back end has myriad /properties/. Properties +mediate interactions between a back end and the rest of the compiler, +especially the driver. Examples include the following: + + * Property `backendValidityOfCImport` says whether the back end can + import foreign C functions. + + * Property `backendForcesOptimization0` says whether the back end can + be used with optimization levels higher than `-O0`. + + * Property `backendCDefs` tells the compiler driver, "if you're using + this back end, then these are the command-line flags you should add + to any invocation of the C compiler." + +These properties are use elsewhere in GHC, primarily in the driver, to +fine-tune operations according to the capabilities of the chosen back +end. You might use a property to make GHC aware of a potential +limitation of certain back ends, or a special feature available only +in certain back ends. If your client code needs to know a fact that +is not exposed in an existing property, you would define and export a +new property. Conditioning client code on the /identity/ or /name/ of +a back end is Not Done. + +For full details, see the documentation of each property. +-} + module GHC.Driver.Backend - ( Backend (..) + ( -- * The @Backend@ type + Backend -- note: type is abstract + -- * Available back ends + , ncgBackend + , llvmBackend + , viaCBackend + , interpreterBackend + , noBackend + , allBackends + + -- * Types used to specify properties of back ends + , PrimitiveImplementation(..) + -- ** Properties that stand for functions + -- *** Back-end function for code generation + , DefunctionalizedCodeOutput(..) + -- *** Back-end functions for assembly + , DefunctionalizedPostHscPipeline(..) + , DefunctionalizedAssemblerProg(..) + , DefunctionalizedAssemblerInfoGetter(..) + -- *** Other back-end functions + , DefunctionalizedCDefs(..) + -- ** Names of back ends (for API clients of version 9.4 or earlier) + , BackendName + + + + -- * Properties of back ends + , backendDescription + , backendWritesFiles + , backendPipelineOutput + , backendCanReuseLoadedCode + , backendGeneratesCode + , backendSupportsInterfaceWriting + , backendRespectsSpecialise + , backendWantsGlobalBindings + , backendHasNativeSwitch + , backendPrimitiveImplementation + , backendSimdValidity + , backendSupportsEmbeddedBlobs + , backendNeedsPlatformNcgSupport + , backendSupportsUnsplitProcPoints + , backendSwappableWithViaC + , backendUnregisterisedAbiOnly + , backendGeneratesHc + , backendSptIsDynamic + , backendWantsBreakpointTicks + , backendForcesOptimization0 + , backendNeedsFullWays + , backendSpecialModuleSource + , backendSupportsHpc + , backendSupportsCImport + , backendSupportsCExport + , backendAssemblerProg + , backendAssemblerInfoGetter + , backendCDefs + , backendCodeOutput + , backendPostHscPipeline + , backendNormalSuccessorPhase + , backendName + , backendValidityOfCImport + , backendValidityOfCExport + + -- * Other functions of back ends , platformDefaultBackend , platformNcgSupported - , backendProducesObject - , backendRetainsAllBindings ) + where + import GHC.Prelude + +import GHC.Driver.Backend.Internal (BackendName(..)) +import GHC.Driver.Phases + + +import GHC.Utils.Error +import GHC.Utils.Panic + +import GHC.Driver.Pipeline.Monad import GHC.Platform --- | Code generation backends. --- --- GHC supports several code generation backends serving different purposes --- (producing machine code, producing ByteCode for the interpreter) and --- supporting different platforms. --- -data Backend - = NCG -- ^ Native code generator backend. - -- - -- Compiles Cmm code into textual assembler, then relies on - -- an external assembler toolchain to produce machine code. - -- - -- Only supports a few platforms (X86, PowerPC, SPARC). - -- - -- See "GHC.CmmToAsm". - - - | LLVM -- ^ LLVM backend. - -- - -- Compiles Cmm code into LLVM textual IR, then relies on - -- LLVM toolchain to produce machine code. - -- - -- It relies on LLVM support for the calling convention used - -- by the NCG backend to produce code objects ABI compatible - -- with it (see "cc 10" or "ghccc" calling convention in - -- https://llvm.org/docs/LangRef.html#calling-conventions). - -- - -- Support a few platforms (X86, AArch64, s390x, ARM). - -- - -- See "GHC.CmmToLlvm" - - - | ViaC -- ^ Via-C backend. - -- - -- Compiles Cmm code into C code, then relies on a C compiler - -- to produce machine code. - -- - -- It produces code objects that are *not* ABI compatible - -- with those produced by NCG and LLVM backends. - -- - -- Produced code is expected to be less efficient than the - -- one produced by NCG and LLVM backends because STG - -- registers are not pinned into real registers. On the - -- other hand, it supports more target platforms (those - -- having a valid C toolchain). - -- - -- See "GHC.CmmToC" - - - | Interpreter -- ^ ByteCode interpreter. - -- - -- Produce ByteCode objects (BCO, see "GHC.ByteCode") that - -- can be interpreted. It is used by GHCi. - -- - -- Currently some extensions are not supported - -- (foreign primops). - -- - -- See "GHC.StgToByteCode" - - - | NoBackend -- ^ No code generated. - -- - -- Use this to disable code generation. It is particularly - -- useful when GHC is used as a library for other purpose - -- than generating code (e.g. to generate documentation with - -- Haddock) or when the user requested it (via -fno-code) for - -- some reason. - - deriving (Eq,Ord,Show,Read) - --- | Default backend to use for the given platform. + +--------------------------------------------------------------------------------- +-- +-- DESIGN CONSIDERATIONS +-- +-- +-- +-- The `Backend` type is made abstract in order to make it possible to +-- add new back ends without having to inspect or modify much code +-- elsewhere in GHC. Adding a new back end would be /easiest/ if +-- `Backend` were represented as a record type, but in peer review, +-- the clear will of the majority was to use a sum type. As a result, +-- when adding a new back end it is necessary to modify /every/ +-- function in this module that expects `Backend` as its first argument. +-- **By design, these functions have no default/wildcard cases.** This +-- design forces the author of a new back end to consider the semantics +-- in every case, rather than relying on a default that may be wrong. +-- The names and documentation of the functions defined in the `Backend` +-- record are sufficiently descriptive that the author of a new back +-- end will be able to identify correct result values without having to go +-- spelunking throughout the compiler. +-- +-- While the design localizes /most/ back-end logic in this module, +-- the author of a new back end will still have to make changes +-- elsewhere in the compiler: +-- +-- * For reasons described in Note [Backend Defunctionalization], +-- code-generation and post-backend pipeline functions, among other +-- functions, cannot be placed in the `Backend` record itself. +-- Instead, the /names/ of those functions are placed. Each name is +-- a value constructor in one of the algebraic data types defined in +-- this module. The named function is then defined near its point +-- of use. +-- +-- The author of a new back end will have to consider whether an +-- existing function will do or whether a new function needs to be +-- defined. When a new function needs to be defined, the author +-- must take two steps: +-- +-- - Add a value constructor to the relevant data type here +-- in the `Backend` module +-- +-- - Add a case to the location in the compiler (there should be +-- exactly one) where the value constructors of the relevant +-- data type are used +-- +-- * When a new back end is defined, it's quite possible that the +-- compiler driver will have to be changed in some way. Just because +-- the driver supports five back ends doesn't mean it will support a sixth +-- without changes. +-- +-- The collection of functions exported from this module hasn't +-- really been "designed"; it's what emerged from a refactoring of +-- older code. The real design criterion was "make it crystal clear +-- what has to be done to add a new back end." +-- +-- One issue remains unresolved: some of the error messages and +-- warning messages used in the driver assume a "closed world": they +-- think they know all the back ends that exist, and they are not shy +-- about enumerating them. Just one set of error messages has been +-- ported to have an open-world assumption: these are the error +-- messages associated with type checking of foreign imports and +-- exports. To allow other errors to be issued with an open-world +-- assumption, use functions `backendValidityOfCImport` and +-- `backendValidityOfCExport` as models, and have a look at how the +-- 'expected back ends' are used in modules "GHC.Tc.Gen.Foreign" and +-- "GHC.Tc.Errors.Ppr" +-- +--------------------------------------------------------------------------------- + + + + platformDefaultBackend :: Platform -> Backend platformDefaultBackend platform = if - | platformUnregisterised platform -> ViaC - | platformNcgSupported platform -> NCG - | otherwise -> LLVM - + | platformUnregisterised platform -> viaCBackend + | platformNcgSupported platform -> ncgBackend + | otherwise -> llvmBackend -- | Is the platform supported by the Native Code Generator? platformNcgSupported :: Platform -> Bool @@ -106,26 +216,706 @@ platformNcgSupported platform = if ArchAArch64 -> True _ -> False --- | Will this backend produce an object file on the disk? -backendProducesObject :: Backend -> Bool -backendProducesObject ViaC = True -backendProducesObject NCG = True -backendProducesObject LLVM = True -backendProducesObject Interpreter = False -backendProducesObject NoBackend = False - --- | Does this backend retain *all* top-level bindings for a module, --- rather than just the exported bindings, in the TypeEnv and compiled --- code (if any)? --- --- Interpreter backend does this, so that GHCi can call functions inside a --- module. --- --- When no backend is used we also do it, so that Haddock can get access to the --- GlobalRdrEnv for a module after typechecking it. -backendRetainsAllBindings :: Backend -> Bool -backendRetainsAllBindings Interpreter = True -backendRetainsAllBindings NoBackend = True -backendRetainsAllBindings ViaC = False -backendRetainsAllBindings NCG = False -backendRetainsAllBindings LLVM = False + + +-- | A value of type @Backend@ represents one of GHC's back ends. +-- The set of back ends cannot be extended except by modifying the +-- definition of @Backend@ in this module. +-- +-- The @Backend@ type is abstract; that is, its value constructors are +-- not exported. It's crucial that they not be exported, because a +-- value of type @Backend@ carries only the back end's /name/, not its +-- behavior or properties. If @Backend@ were not abstract, then code +-- elsewhere in the compiler could depend directly on the name, not on +-- the semantics, which would make it challenging to create a new back end. +-- Because @Backend@ /is/ abstract, all the obligations of a new back +-- end are enumerated in this module, in the form of functions that +-- take @Backend@ as an argument. +-- +-- The issue of abstraction is discussed at great length in #20927 and !7442. + + +newtype Backend = Named BackendName + -- Must be a newtype so that it has no `Eq` instance and + -- a different `Show` instance. + +-- | The Show instance is for messages /only/. If code depends on +-- what's in the string, you deserve what happens to you. + +instance Show Backend where + show = backendDescription + + +ncgBackend, llvmBackend, viaCBackend, interpreterBackend, noBackend + :: Backend + +-- | The native code generator. +-- Compiles Cmm code into textual assembler, then relies on +-- an external assembler toolchain to produce machine code. +-- +-- Only supports a few platforms (X86, PowerPC, SPARC). +-- +-- See "GHC.CmmToAsm". +ncgBackend = Named NCG + +-- | The LLVM backend. +-- +-- Compiles Cmm code into LLVM textual IR, then relies on +-- LLVM toolchain to produce machine code. +-- +-- It relies on LLVM support for the calling convention used +-- by the NCG backend to produce code objects ABI compatible +-- with it (see "cc 10" or "ghccc" calling convention in +-- https://llvm.org/docs/LangRef.html#calling-conventions). +-- +-- Supports a few platforms (X86, AArch64, s390x, ARM). +-- +-- See "GHC.CmmToLlvm" +llvmBackend = Named LLVM + +-- | Via-C ("unregisterised") backend. +-- +-- Compiles Cmm code into C code, then relies on a C compiler +-- to produce machine code. +-- +-- It produces code objects that are /not/ ABI compatible +-- with those produced by NCG and LLVM backends. +-- +-- Produced code is expected to be less efficient than the +-- one produced by NCG and LLVM backends because STG +-- registers are not pinned into real registers. On the +-- other hand, it supports more target platforms (those +-- having a valid C toolchain). +-- +-- See "GHC.CmmToC" +viaCBackend = Named ViaC + +-- | The ByteCode interpreter. +-- +-- Produce ByteCode objects (BCO, see "GHC.ByteCode") that +-- can be interpreted. It is used by GHCi. +-- +-- Currently some extensions are not supported +-- (foreign primops). +-- +-- See "GHC.StgToByteCode" +interpreterBackend = Named Interpreter + +-- | A dummy back end that generates no code. +-- +-- Use this back end to disable code generation. It is particularly +-- useful when GHC is used as a library for other purpose than +-- generating code (e.g. to generate documentation with Haddock) or +-- when the user requested it (via `-fno-code`) for some reason. +noBackend = Named NoBackend + +--------------------------------------------------------------------------------- + + + + +-- | This enumeration type specifies how the back end wishes GHC's +-- primitives to be implemented. (Module "GHC.StgToCmm.Prim" provides +-- a generic implementation of every primitive, but some primitives, +-- like `IntQuotRemOp`, can be implemented more efficiently by +-- certain back ends on certain platforms. For example, by using a +-- machine instruction that simultaneously computes quotient and remainder.) +-- +-- For the meaning of each alternative, consult +-- "GHC.StgToCmm.Config". (In a perfect world, type +-- `PrimitiveImplementation` would be defined there, in the module +-- that determines its meaning. But I could not figure out how to do +-- it without mutual recursion across module boundaries.) + +data PrimitiveImplementation + = LlvmPrimitives -- ^ Primitives supported by LLVM + | NcgPrimitives -- ^ Primitives supported by the native code generator + | GenericPrimitives -- ^ Primitives supported by all back ends + deriving Show + + +-- | Names a function that runs the assembler, of this type: +-- +-- > Logger -> DynFlags -> Platform -> [Option] -> IO () +-- +-- The functions so named are defined in "GHC.Driver.Pipeline.Execute". + +data DefunctionalizedAssemblerProg + = StandardAssemblerProg + -- ^ Use the standard system assembler + | DarwinClangAssemblerProg + -- ^ If running on Darwin, use the assembler from the @clang@ + -- toolchain. Otherwise use the standard system assembler. + + + +-- | Names a function that discover from what toolchain the assembler +-- is coming, of this type: +-- +-- > Logger -> DynFlags -> Platform -> IO CompilerInfo +-- +-- The functions so named are defined in "GHC.Driver.Pipeline.Execute". + +data DefunctionalizedAssemblerInfoGetter + = StandardAssemblerInfoGetter + -- ^ Interrogate the standard system assembler + | DarwinClangAssemblerInfoGetter + -- ^ If running on Darwin, return `Clang`; otherwise + -- interrogate the standard system assembler. + + +-- | Names a function that generates code and writes the results to a +-- file, of this type: +-- +-- > Logger +-- > -> DynFlags +-- > -> Module -- ^ module being compiled +-- > -> ModLocation +-- > -> FilePath -- ^ Where to write output +-- > -> Set UnitId -- ^ dependencies +-- > -> Stream IO RawCmmGroup a -- results from `StgToCmm` +-- > -> IO a +-- +-- The functions so named are defined in "GHC.Driver.CodeOutput". +-- +-- We expect one function per back end—or more precisely, one function +-- for each back end that writes code to a file. (The interpreter +-- does not write to files; its output lives only in memory.) + +data DefunctionalizedCodeOutput + = NcgCodeOutput + | ViaCCodeOutput + | LlvmCodeOutput + + +-- | Names a function that tells the driver what should happen after +-- assembly code is written. This might include running a C compiler, +-- running LLVM, running an assembler, or various similar activities. +-- The function named normally has this type: +-- +-- > TPipelineClass TPhase m +-- > => PipeEnv +-- > -> HscEnv +-- > -> Maybe ModLocation +-- > -> FilePath +-- > -> m (Maybe FilePath) +-- +-- The functions so named are defined in "GHC.Driver.Pipeline". + +data DefunctionalizedPostHscPipeline + = NcgPostHscPipeline + | ViaCPostHscPipeline + | LlvmPostHscPipeline + | NoPostHscPipeline -- ^ After code generation, nothing else need happen. + +-- | Names a function that tells the driver what command-line options +-- to include when invoking a C compiler. It's meant for @-D@ options that +-- define symbols for the C preprocessor. Because the exact symbols +-- defined might depend on versions of tools located in the file +-- system (/cough/ LLVM /cough/), the function requires an `IO` action. +-- The function named has this type: +-- +-- > Logger -> DynFlags -> IO [String] + +data DefunctionalizedCDefs + = NoCDefs -- ^ No additional command-line options are needed + + | LlvmCDefs -- ^ Return command-line options that tell GHC about the + -- LLVM version. + +--------------------------------------------------------------------------------- + + + +-- | An informal description of the back end, for use in +-- issuing warning messages /only/. If code depends on +-- what's in the string, you deserve what happens to you. +backendDescription :: Backend -> String +backendDescription (Named NCG) = "native code generator" +backendDescription (Named LLVM) = "LLVM" +backendDescription (Named ViaC) = "compiling via C" +backendDescription (Named Interpreter) = "byte-code interpreter" +backendDescription (Named NoBackend) = "no code generated" + +-- | This flag tells the compiler driver whether the back +-- end will write files: interface files and object files. +-- It is typically true for "real" back ends that generate +-- code into the filesystem. (That means, not the interpreter.) +backendWritesFiles :: Backend -> Bool +backendWritesFiles (Named NCG) = True +backendWritesFiles (Named LLVM) = True +backendWritesFiles (Named ViaC) = True +backendWritesFiles (Named Interpreter) = False +backendWritesFiles (Named NoBackend) = False + +-- | When the back end does write files, this value tells +-- the compiler in what manner of file the output should go: +-- temporary, persistent, or specific. +backendPipelineOutput :: Backend -> PipelineOutput +backendPipelineOutput (Named NCG) = Persistent +backendPipelineOutput (Named LLVM) = Persistent +backendPipelineOutput (Named ViaC) = Persistent +backendPipelineOutput (Named Interpreter) = NoOutputFile +backendPipelineOutput (Named NoBackend) = NoOutputFile + +-- | This flag tells the driver whether the back end can +-- reuse code (bytecode or object code) that has been +-- loaded dynamically. Likely true only of the interpreter. +backendCanReuseLoadedCode :: Backend -> Bool +backendCanReuseLoadedCode (Named NCG) = False +backendCanReuseLoadedCode (Named LLVM) = False +backendCanReuseLoadedCode (Named ViaC) = False +backendCanReuseLoadedCode (Named Interpreter) = True +backendCanReuseLoadedCode (Named NoBackend) = False + +-- | It is is true of every back end except @-fno-code@ +-- that it "generates code." Surprisingly, this property +-- influences the driver in a ton of ways. Some examples: +-- +-- * If the back end does not generate code, then the +-- driver needs to turn on code generation for +-- Template Haskell (because that code needs to be +-- generated and run at compile time). +-- +-- * If the back end does not generate code, then the +-- driver does not need to deal with an output file. +-- +-- * If the back end /does/ generated code, then the +-- driver supports `HscRecomp`. If not, recompilation +-- does not need a linkable (and is automatically up +-- to date). +-- +backendGeneratesCode :: Backend -> Bool +backendGeneratesCode (Named NCG) = True +backendGeneratesCode (Named LLVM) = True +backendGeneratesCode (Named ViaC) = True +backendGeneratesCode (Named Interpreter) = True +backendGeneratesCode (Named NoBackend) = False + +-- | When set, this flag turns on interface writing for +-- Backpack. It should probably be the same as +-- `backendGeneratesCode`, but it is kept distinct for +-- reasons described in Note [-fno-code mode]. +backendSupportsInterfaceWriting :: Backend -> Bool +backendSupportsInterfaceWriting (Named NCG) = True +backendSupportsInterfaceWriting (Named LLVM) = True +backendSupportsInterfaceWriting (Named ViaC) = True +backendSupportsInterfaceWriting (Named Interpreter) = True +backendSupportsInterfaceWriting (Named NoBackend) = False + +-- | When preparing code for this back end, the type +-- checker should pay attention to SPECIALISE pragmas. If +-- this flag is `False`, then the type checker ignores +-- SPECIALISE pragmas (for imported things?). +backendRespectsSpecialise :: Backend -> Bool +backendRespectsSpecialise (Named NCG) = True +backendRespectsSpecialise (Named LLVM) = True +backendRespectsSpecialise (Named ViaC) = True +backendRespectsSpecialise (Named Interpreter) = False +backendRespectsSpecialise (Named NoBackend) = False + +-- | This back end wants the `mi_globals` field of a +-- `ModIface` to be populated (with the top-level bindings +-- of the original source). True for the interpreter, and +-- also true for "no backend", which is used by Haddock. +-- (After typechecking a module, Haddock wants access to +-- the module's `GlobalRdrEnv`.) +backendWantsGlobalBindings :: Backend -> Bool +backendWantsGlobalBindings (Named NCG) = False +backendWantsGlobalBindings (Named LLVM) = False +backendWantsGlobalBindings (Named ViaC) = False +backendWantsGlobalBindings (Named Interpreter) = True +backendWantsGlobalBindings (Named NoBackend) = True + +-- | The back end targets a technology that implements +-- `switch` natively. (For example, LLVM or C.) Therefore +-- it is not necessary for GHC to ccompile a Cmm `Switch` +-- form into a decision tree with jump tables at the +-- leaves. +backendHasNativeSwitch :: Backend -> Bool +backendHasNativeSwitch (Named NCG) = False +backendHasNativeSwitch (Named LLVM) = True +backendHasNativeSwitch (Named ViaC) = True +backendHasNativeSwitch (Named Interpreter) = False +backendHasNativeSwitch (Named NoBackend) = False + +-- | As noted in the documentation for +-- `PrimitiveImplementation`, certain primitives have +-- multiple implementations, depending on the capabilities +-- of the back end. This field signals to module +-- "GHC.StgToCmm.Prim" what implementations to use with +-- this back end. +backendPrimitiveImplementation :: Backend -> PrimitiveImplementation +backendPrimitiveImplementation (Named NCG) = NcgPrimitives +backendPrimitiveImplementation (Named LLVM) = LlvmPrimitives +backendPrimitiveImplementation (Named ViaC) = GenericPrimitives +backendPrimitiveImplementation (Named Interpreter) = GenericPrimitives +backendPrimitiveImplementation (Named NoBackend) = GenericPrimitives + +-- | When this value is `IsValid`, the back end is +-- compatible with vector instructions. When it is +-- `NotValid`, it carries a message that is shown to +-- users. +backendSimdValidity :: Backend -> Validity' String +backendSimdValidity (Named NCG) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdValidity (Named LLVM) = IsValid +backendSimdValidity (Named ViaC) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdValidity (Named Interpreter) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] +backendSimdValidity (Named NoBackend) = NotValid $ unlines ["SIMD vector instructions require the LLVM back-end.","Please use -fllvm."] + +-- | This flag says whether the back end supports large +-- binary blobs. See Note [Embedding large binary blobs] +-- in "GHC.CmmToAsm.Ppr". +backendSupportsEmbeddedBlobs :: Backend -> Bool +backendSupportsEmbeddedBlobs (Named NCG) = True +backendSupportsEmbeddedBlobs (Named LLVM) = False +backendSupportsEmbeddedBlobs (Named ViaC) = False +backendSupportsEmbeddedBlobs (Named Interpreter) = False +backendSupportsEmbeddedBlobs (Named NoBackend) = False + +-- | This flag tells the compiler driver that the back end +-- does not support every target platform; it supports +-- only platforms that claim NCG support. (It's set only +-- for the native code generator.) Crufty. If the driver +-- tries to use the native code generator /without/ +-- platform support, the driver fails over to the LLVM +-- back end. +backendNeedsPlatformNcgSupport :: Backend -> Bool +backendNeedsPlatformNcgSupport (Named NCG) = True +backendNeedsPlatformNcgSupport (Named LLVM) = False +backendNeedsPlatformNcgSupport (Named ViaC) = False +backendNeedsPlatformNcgSupport (Named Interpreter) = False +backendNeedsPlatformNcgSupport (Named NoBackend) = False + +-- | This flag is set if the back end can generate code +-- for proc points. If the flag is not set, then a Cmm +-- pass needs to split proc points (that is, turn each +-- proc point into a standalone procedure). +backendSupportsUnsplitProcPoints :: Backend -> Bool +backendSupportsUnsplitProcPoints (Named NCG) = True +backendSupportsUnsplitProcPoints (Named LLVM) = False +backendSupportsUnsplitProcPoints (Named ViaC) = False +backendSupportsUnsplitProcPoints (Named Interpreter) = False +backendSupportsUnsplitProcPoints (Named NoBackend) = False + +-- | This flag guides the driver in resolving issues about +-- API support on the target platform. If the flag is set, +-- then these things are true: +-- +-- * When the target platform supports /only/ an unregisterised API, +-- this backend can be replaced with compilation via C. +-- +-- * When the target does /not/ support an unregisterised API, +-- this back end can replace compilation via C. +-- +backendSwappableWithViaC :: Backend -> Bool +backendSwappableWithViaC (Named NCG) = True +backendSwappableWithViaC (Named LLVM) = True +backendSwappableWithViaC (Named ViaC) = False +backendSwappableWithViaC (Named Interpreter) = False +backendSwappableWithViaC (Named NoBackend) = False + +-- | This flag is true if the back end works *only* with +-- the unregisterised ABI. +backendUnregisterisedAbiOnly :: Backend -> Bool +backendUnregisterisedAbiOnly (Named NCG) = False +backendUnregisterisedAbiOnly (Named LLVM) = False +backendUnregisterisedAbiOnly (Named ViaC) = True +backendUnregisterisedAbiOnly (Named Interpreter) = False +backendUnregisterisedAbiOnly (Named NoBackend) = False + +-- | This flag is set if the back end generates C code in +-- a @.hc@ file. The flag lets the compiler driver know +-- if the command-line flag @-C@ is meaningful. +backendGeneratesHc :: Backend -> Bool +backendGeneratesHc (Named NCG) = False +backendGeneratesHc (Named LLVM) = False +backendGeneratesHc (Named ViaC) = True +backendGeneratesHc (Named Interpreter) = False +backendGeneratesHc (Named NoBackend) = False + +-- | This flag says whether SPT (static pointer table) +-- entries will be inserted dynamically if needed. If +-- this flag is `False`, then "GHC.Iface.Tidy" should emit C +-- stubs that initialize the SPT entries. +backendSptIsDynamic :: Backend -> Bool +backendSptIsDynamic (Named NCG) = False +backendSptIsDynamic (Named LLVM) = False +backendSptIsDynamic (Named ViaC) = False +backendSptIsDynamic (Named Interpreter) = True +backendSptIsDynamic (Named NoBackend) = False + +-- | If this flag is set, then "GHC.HsToCore.Coverage" +-- inserts `Breakpoint` ticks. Used only for the +-- interpreter. +backendWantsBreakpointTicks :: Backend -> Bool +backendWantsBreakpointTicks (Named NCG) = False +backendWantsBreakpointTicks (Named LLVM) = False +backendWantsBreakpointTicks (Named ViaC) = False +backendWantsBreakpointTicks (Named Interpreter) = True +backendWantsBreakpointTicks (Named NoBackend) = False + +-- | If this flag is set, then the driver forces the +-- optimization level to 0, issuing a warning message if +-- the command line requested a higher optimization level. +backendForcesOptimization0 :: Backend -> Bool +backendForcesOptimization0 (Named NCG) = False +backendForcesOptimization0 (Named LLVM) = False +backendForcesOptimization0 (Named ViaC) = False +backendForcesOptimization0 (Named Interpreter) = True +backendForcesOptimization0 (Named NoBackend) = False + +-- | I don't understand exactly how this works. But if +-- this flag is set *and* another condition is met, then +-- @ghc/Main.hs@ will alter the `DynFlags` so that all the +-- `hostFullWays` are asked for. It is set only for the interpreter. +backendNeedsFullWays :: Backend -> Bool +backendNeedsFullWays (Named NCG) = False +backendNeedsFullWays (Named LLVM) = False +backendNeedsFullWays (Named ViaC) = False +backendNeedsFullWays (Named Interpreter) = True +backendNeedsFullWays (Named NoBackend) = False + +-- | This flag is also special for the interpreter: if a +-- message about a module needs to be shown, do we know +-- anything special about where the module came from? The +-- Boolean argument is a `recomp` flag. +backendSpecialModuleSource :: Backend -> Bool -> Maybe String +backendSpecialModuleSource (Named NCG) = const Nothing +backendSpecialModuleSource (Named LLVM) = const Nothing +backendSpecialModuleSource (Named ViaC) = const Nothing +backendSpecialModuleSource (Named Interpreter) = \b -> if b then Just "interpreted" else Nothing +backendSpecialModuleSource (Named NoBackend) = const (Just "nothing") + +-- | This flag says whether the back end supports Haskell +-- Program Coverage (HPC). If not, the compiler driver +-- will ignore the `-fhpc` option (and will issue a +-- warning message if it is used). +backendSupportsHpc :: Backend -> Bool +backendSupportsHpc (Named NCG) = True +backendSupportsHpc (Named LLVM) = True +backendSupportsHpc (Named ViaC) = True +backendSupportsHpc (Named Interpreter) = False +backendSupportsHpc (Named NoBackend) = True + +-- | This flag says whether the back end supports foreign +-- import of C functions. ("Supports" means "does not +-- barf on," so @-fno-code@ supports foreign C imports.) +backendSupportsCImport :: Backend -> Bool +backendSupportsCImport (Named NCG) = True +backendSupportsCImport (Named LLVM) = True +backendSupportsCImport (Named ViaC) = True +backendSupportsCImport (Named Interpreter) = True +backendSupportsCImport (Named NoBackend) = True + +-- | This flag says whether the back end supports foreign +-- export of Haskell functions to C. +backendSupportsCExport :: Backend -> Bool +backendSupportsCExport (Named NCG) = True +backendSupportsCExport (Named LLVM) = True +backendSupportsCExport (Named ViaC) = True +backendSupportsCExport (Named Interpreter) = False +backendSupportsCExport (Named NoBackend) = True + +-- | This (defunctionalized) function runs the assembler +-- used on the code that is written by this back end. A +-- program determined by a combination of back end, +-- `DynFlags`, and `Platform` is run with the given +-- `Option`s. +-- +-- The function's type is +-- @ +-- Logger -> DynFlags -> Platform -> [Option] -> IO () +-- @ +-- +-- This field is usually defaulted. +backendAssemblerProg :: Backend -> DefunctionalizedAssemblerProg +backendAssemblerProg (Named NCG) = StandardAssemblerProg +backendAssemblerProg (Named LLVM) = DarwinClangAssemblerProg +backendAssemblerProg (Named ViaC) = StandardAssemblerProg +backendAssemblerProg (Named Interpreter) = StandardAssemblerProg +backendAssemblerProg (Named NoBackend) = StandardAssemblerProg + +-- | This (defunctionalized) function is used to retrieve +-- an enumeration value that characterizes the C/assembler +-- part of a toolchain. The function caches the info in a +-- mutable variable that is part of the `DynFlags`. +-- +-- The function's type is +-- @ +-- Logger -> DynFlags -> Platform -> IO CompilerInfo +-- @ +-- +-- This field is usually defaulted. +backendAssemblerInfoGetter :: Backend -> DefunctionalizedAssemblerInfoGetter +backendAssemblerInfoGetter (Named NCG) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named LLVM) = DarwinClangAssemblerInfoGetter +backendAssemblerInfoGetter (Named ViaC) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named Interpreter) = StandardAssemblerInfoGetter +backendAssemblerInfoGetter (Named NoBackend) = StandardAssemblerInfoGetter + +-- | When using this back end, it may be necessary or +-- advisable to pass some `-D` options to a C compiler. +-- This (defunctionalized) function produces those +-- options, if any. An IO action may be necessary in +-- order to interrogate external tools about what version +-- they are, for example. +-- +-- The function's type is +-- @ +-- Logger -> DynFlags -> IO [String] +-- @ +-- +-- This field is usually defaulted. +backendCDefs :: Backend -> DefunctionalizedCDefs +backendCDefs (Named NCG) = NoCDefs +backendCDefs (Named LLVM) = LlvmCDefs +backendCDefs (Named ViaC) = NoCDefs +backendCDefs (Named Interpreter) = NoCDefs +backendCDefs (Named NoBackend) = NoCDefs + +-- | This (defunctionalized) function generates code and +-- writes it to a file. The type of the function is +-- +-- > Logger +-- > -> DynFlags +-- > -> Module -- ^ module being compiled +-- > -> ModLocation +-- > -> FilePath -- ^ Where to write output +-- > -> Set UnitId -- ^ dependencies +-- > -> Stream IO RawCmmGroup a -- results from `StgToCmm` +-- > -> IO a +backendCodeOutput :: Backend -> DefunctionalizedCodeOutput +backendCodeOutput (Named NCG) = NcgCodeOutput +backendCodeOutput (Named LLVM) = LlvmCodeOutput +backendCodeOutput (Named ViaC) = ViaCCodeOutput +backendCodeOutput (Named Interpreter) = panic "backendCodeOutput: interpreterBackend" +backendCodeOutput (Named NoBackend) = panic "backendCodeOutput: noBackend" + +-- | This (defunctionalized) function tells the compiler +-- driver what else has to be run after code output. +-- The type of the function is +-- +-- > +-- > TPipelineClass TPhase m +-- > => PipeEnv +-- > -> HscEnv +-- > -> Maybe ModLocation +-- > -> FilePath +-- > -> m (Maybe FilePath) +backendPostHscPipeline :: Backend -> DefunctionalizedPostHscPipeline +backendPostHscPipeline (Named NCG) = NcgPostHscPipeline +backendPostHscPipeline (Named LLVM) = LlvmPostHscPipeline +backendPostHscPipeline (Named ViaC) = ViaCPostHscPipeline +backendPostHscPipeline (Named Interpreter) = NoPostHscPipeline +backendPostHscPipeline (Named NoBackend) = NoPostHscPipeline + +-- | Somewhere in the compiler driver, when compiling +-- Haskell source (as opposed to a boot file or a sig +-- file), it needs to know what to do with the code that +-- the `backendCodeOutput` writes to a file. This `Phase` +-- value gives instructions like "run the C compiler", +-- "run the assembler," or "run the LLVM Optimizer." +backendNormalSuccessorPhase :: Backend -> Phase +backendNormalSuccessorPhase (Named NCG) = As False +backendNormalSuccessorPhase (Named LLVM) = LlvmOpt +backendNormalSuccessorPhase (Named ViaC) = HCc +backendNormalSuccessorPhase (Named Interpreter) = StopLn +backendNormalSuccessorPhase (Named NoBackend) = StopLn + +-- | Name of the back end, if any. Used to migrate legacy +-- clients of the GHC API. Code within the GHC source +-- tree should not refer to a back end's name. +backendName :: Backend -> BackendName +backendName (Named NCG) = NCG +backendName (Named LLVM) = LLVM +backendName (Named ViaC) = ViaC +backendName (Named Interpreter) = Interpreter +backendName (Named NoBackend) = NoBackend + + + +-- | A list of all back ends. They are ordered as we wish them to +-- appear when they are enumerated in error messages. + +allBackends :: [Backend] +allBackends = [ ncgBackend + , llvmBackend + , viaCBackend + , interpreterBackend + , noBackend + ] + +-- | When foreign C import or export is invalid, the carried value +-- enumerates the /valid/ back ends. + +backendValidityOfCImport, backendValidityOfCExport :: Backend -> Validity' [Backend] + +backendValidityOfCImport backend = + if backendSupportsCImport backend then + IsValid + else + NotValid $ filter backendSupportsCImport allBackends + +backendValidityOfCExport backend = + if backendSupportsCExport backend then + IsValid + else + NotValid $ filter backendSupportsCExport allBackends + + + + +{- +Note [Backend Defunctionalization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I had hoped to include code-output and post-hsc-pipeline functions +directly in the `Backend` record itself. But this agenda was derailed +by mutual recursion in the types: + + - A `DynFlags` record contains a back end of type `Backend`. + - A `Backend` contains a code-output function. + - A code-output function takes Cmm as input. + - Cmm can include a `CLabel`. + - A `CLabel` can have elements that are defined in + `GHC.Driver.Session`, where `DynFlags` is defined. + +There is also a nasty issue in the values: a typical post-backend +pipeline function both depends on and is depended upon by functions in +"GHC.Driver.Pipeline". + +I'm cut the Gordian not by removing the function types from the +`Backend` record. Instead, a function is represented by its /name/. +This representation is an example of an old trick called +/defunctionalization/, which has been used in both compilers and +interpreters for languages with first-class, nested functions. Here, +a function's name is a value of an algebraic data type. For example, +a code-output function is represented by a value of this type: + + data DefunctionalizedCodeOutput + = NcgCodeOutput + | ViaCCodeOutput + | LlvmCodeOutput + +Such a function may be applied in one of two ways: + + - In this particular example, a `case` expression in module + "GHC.Driver.CodeOutput" discriminates on the value and calls the + designated function. + + - In another example, a function of type `DefunctionalizedCDefs` is + applied by calling function `applyCDefs`, which has this type: + + @ + applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String] + @ + + Function `applyCDefs` is defined in module "GHC.Driver.Pipeline.Execute". + +I don't love this solution, but defunctionalization is a standard +thing, and it makes the meanings of the enumeration values clear. + +Anyone defining a new back end will need to extend both the +`DefunctionalizedCodeOutput` type and the corresponding apply +function. +-} diff --git a/compiler/GHC/Driver/Backend/Internal.hs b/compiler/GHC/Driver/Backend/Internal.hs new file mode 100644 index 0000000000..99484b752e --- /dev/null +++ b/compiler/GHC/Driver/Backend/Internal.hs @@ -0,0 +1,32 @@ +{-| +Module : GHC.Driver.Backend.Internal +Description : Interface for migrating legacy clients of the GHC API + +In versions of GHC up through 9.2, a `Backend` was represented only by +its name. This module is meant to aid clients written against the GHC +API, versions 9.2 and older. The module provides an alternative way +to name any back end found in GHC 9.2. /Code within the GHC source +tree should not import this module./ (#20927). + +Only back ends found in version 9.2 have names. + +-} + +module GHC.Driver.Backend.Internal + ( -- * Name of a back end + BackendName(..) + ) + +where + + + +import GHC.Prelude + +data BackendName + = NCG -- ^ Names the native code generator backend. + | LLVM -- ^ Names the LLVM backend. + | ViaC -- ^ Names the Via-C backend. + | Interpreter -- ^ Names the ByteCode interpreter. + | NoBackend -- ^ Names the `-fno-code` backend. + deriving (Eq, Show) diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index a5fb1dc168..06fdbb34e8 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -20,6 +20,7 @@ module GHC.Driver.Backpack (doBackpack) where import GHC.Prelude +import GHC.Driver.Backend -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax import GHC.Driver.Config.Finder (initFinderOpts) @@ -188,7 +189,7 @@ withBkpSession cid insts deps session_type do_this = do hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env mk_temp_dflags unit_state dflags = dflags { backend = case session_type of - TcSession -> NoBackend + TcSession -> noBackend _ -> backend dflags , ghcLink = case session_type of TcSession -> NoLink @@ -214,7 +215,7 @@ withBkpSession cid insts deps session_type do_this = do -- Make sure to write interfaces when we are type-checking -- indefinite packages. TcSession - | backend dflags /= NoBackend + | backendSupportsInterfaceWriting $ backend dflags -> EnumSet.insert Opt_WriteInterface (generalFlags dflags) _ -> generalFlags dflags diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index c073c40323..5b3f614d8e 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -43,7 +43,6 @@ import GHC.Utils.TmpFs import GHC.Utils.Error import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Utils.Logger import GHC.Utils.Exception (bracket) import GHC.Utils.Ppr (Mode(..)) @@ -120,13 +119,11 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g ; emitInitializerDecls this_mod stubs ; return (stubs, a) } - ; (stubs, a) <- case backend dflags of - NCG -> outputAsm logger dflags this_mod location filenm - final_stream - ViaC -> outputC logger dflags filenm final_stream pkg_deps - LLVM -> outputLlvm logger llvm_config dflags filenm final_stream - Interpreter -> panic "codeOutput: Interpreter" - NoBackend -> panic "codeOutput: NoBackend" + ; (stubs, a) <- case backendCodeOutput (backend dflags) of + NcgCodeOutput -> outputAsm logger dflags this_mod location filenm + final_stream + ViaCCodeOutput -> outputC logger dflags filenm final_stream pkg_deps + LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm final_stream ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs ; return (filenm, stubs_exist, foreign_fps, a) } @@ -313,8 +310,7 @@ outputForeignStubs logger tmpfs dflags unit_state mod location stubs cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n" --- Don't use doOutput for dumping the f. export stubs --- since it is more than likely that the stubs file will +-- It is more than likely that the stubs file will -- turn out to be empty, in which case no file should be created. outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool outputForeignStubs_help _fname "" _header _footer = return False @@ -392,5 +388,3 @@ ipInitCode do_info_table platform this_mod ents | ipe <- ipes ] ++ [text "NULL"]) <> semi - - diff --git a/compiler/GHC/Driver/Config/Cmm.hs b/compiler/GHC/Driver/Config/Cmm.hs index 38bab62048..5e7ebf72dd 100644 --- a/compiler/GHC/Driver/Config/Cmm.hs +++ b/compiler/GHC/Driver/Config/Cmm.hs @@ -3,7 +3,6 @@ module GHC.Driver.Config.Cmm ) where import GHC.Cmm.Config -import GHC.Cmm.Switch (backendSupportsSwitch) import GHC.Driver.Session import GHC.Driver.Backend @@ -21,8 +20,8 @@ initCmmConfig dflags = CmmConfig , cmmOptSink = gopt Opt_CmmSink dflags , cmmGenStackUnwindInstr = debugLevel dflags > 0 , cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags - , cmmDoCmmSwitchPlans = not . backendSupportsSwitch . backend $ dflags - , cmmSplitProcPoints = (backend dflags /= NCG) + , cmmDoCmmSwitchPlans = not . backendHasNativeSwitch . backend $ dflags + , cmmSplitProcPoints = not (backendSupportsUnsplitProcPoints (backend dflags)) || not (platformTablesNextToCode platform) || usingInconsistentPicReg } diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs index 7ec80f24d3..b0b28bf158 100644 --- a/compiler/GHC/Driver/Config/StgToCmm.hs +++ b/compiler/GHC/Driver/Config/StgToCmm.hs @@ -8,6 +8,7 @@ import GHC.Driver.Backend import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile +import GHC.Utils.Error import GHC.Unit.Module import GHC.Utils.Outputable @@ -60,9 +61,11 @@ initStgToCmmConfig dflags mod = StgToCmmConfig } where profile = targetProfile dflags platform = profilePlatform profile bk_end = backend dflags - ncg = bk_end == NCG - llvm = bk_end == LLVM b_blob = if not ncg then Nothing else binBlobThreshold dflags + (ncg, llvm) = case backendPrimitiveImplementation bk_end of + GenericPrimitives -> (False, False) + NcgPrimitives -> (True, False) + LlvmPrimitives -> (False, True) x86ish = case platformArch platform of ArchX86 -> True ArchX86_64 -> True @@ -71,6 +74,6 @@ initStgToCmmConfig dflags mod = StgToCmmConfig ArchPPC -> True ArchPPC_64 _ -> True _ -> False - vec_err = case backend dflags of - LLVM -> Nothing - _ -> Just (unlines ["SIMD vector instructions require the LLVM back-end.", "Please use -fllvm."]) + vec_err = case backendSimdValidity (backend dflags) of + IsValid -> Nothing + NotValid msg -> Just msg diff --git a/compiler/GHC/Driver/Config/Tidy.hs b/compiler/GHC/Driver/Config/Tidy.hs index d7ad76fc87..89bdf31b2c 100644 --- a/compiler/GHC/Driver/Config/Tidy.hs +++ b/compiler/GHC/Driver/Config/Tidy.hs @@ -62,12 +62,8 @@ initStaticPtrOpts hsc_env = do -- If we are compiling for the interpreter we will insert any necessary -- SPT entries dynamically, otherwise we add a C stub to do so - , opt_gen_cstub = case backend dflags of - Interpreter -> False - _ -> True - + , opt_gen_cstub = backendWritesFiles (backend dflags) , opt_mk_string = mk_string , opt_static_ptr_info_datacon = static_ptr_info_datacon , opt_static_ptr_datacon = static_ptr_datacon } - diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index ddc86ac3e3..36dcf24237 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -824,24 +824,24 @@ hscRecompStatus return $ HscRecompNeeded $ fmap (mi_iface_hash . mi_final_exts) mb_checked_iface UpToDateItem checked_iface -> do let lcl_dflags = ms_hspp_opts mod_summary - case backend lcl_dflags of - -- No need for a linkable, we're good to go - NoBackend -> do - msg $ UpToDate - return $ HscUpToDate checked_iface Nothing + if not (backendGeneratesCode (backend lcl_dflags)) then + -- No need for a linkable, we're good to go + do msg $ UpToDate + return $ HscUpToDate checked_iface Nothing + else -- Do need linkable - _ -> do + do -- Check to see whether the expected build products already exist. -- If they don't exists then we trigger recompilation. recomp_linkable_result <- case () of -- Interpreter can use either already loaded bytecode or loaded object code - _ | Interpreter <- backend lcl_dflags -> do + _ | backendCanReuseLoadedCode (backend lcl_dflags) -> do let res = checkByteCode old_linkable case res of UpToDateItem _ -> pure res _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary -- Need object files for making object files - | backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary + | backendWritesFiles (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags) case recomp_linkable_result of UpToDateItem linkable -> do @@ -1001,7 +1001,7 @@ hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_h -- interface file. case mb_desugar of -- Just cause we desugared doesn't mean we are generating code, see above. - Just desugared_guts | bcknd /= NoBackend -> do + Just desugared_guts | backendGeneratesCode bcknd -> do plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result) simplified_guts <- hscSimplify' plugins desugared_guts @@ -1088,10 +1088,7 @@ hscMaybeWriteIface -> IO () hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do let force_write_interface = gopt Opt_WriteInterface dflags - write_interface = case backend dflags of - NoBackend -> False - Interpreter -> False - _ -> True + write_interface = backendWritesFiles (backend dflags) write_iface dflags' iface = let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location @@ -2397,4 +2394,4 @@ showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text writeInterfaceOnlyMode :: DynFlags -> Bool writeInterfaceOnlyMode dflags = gopt Opt_WriteInterface dflags && - NoBackend == backend dflags + not (backendGeneratesCode (backend dflags)) diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index dfc0af7e38..efaefd84f5 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -1758,7 +1758,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = enable_code_gen ms = return ms nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) = - backend dflags == NoBackend && + not (backendGeneratesCode (backend dflags)) && -- Don't enable codegen for TH on indefinite packages; we -- can't compile anything anyway! See #16219. isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env) diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 89a4329745..e988979df2 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -251,10 +251,7 @@ compileOne' mHscMessage input_fn = expectJust "compile:hs" (ml_hs_file location) input_fnpp = ms_hspp_file summary - pipelineOutput = case bcknd of - Interpreter -> NoOutputFile - NoBackend -> NoOutputFile - _ -> Persistent + pipelineOutput = backendPipelineOutput bcknd logger = hsc_logger hsc_env0 tmpfs = hsc_tmpfs hsc_env0 @@ -278,7 +275,10 @@ compileOne' mHscMessage -- was set), force it to generate byte-code. This is NOT transitive and -- only applies to direct targets. | loadAsByteCode - = (Interpreter, gopt_set (lcl_dflags { backend = Interpreter }) Opt_ForceRecomp) + = ( interpreterBackend + , gopt_set (lcl_dflags { backend = interpreterBackend }) Opt_ForceRecomp + ) + | otherwise = (backend dflags, lcl_dflags) -- See Note [Filepaths and Multiple Home Units] @@ -526,7 +526,7 @@ compileFile hsc_env stop_phase (src, _mb_phase) = do -- When linking, the -o argument refers to the linker's output. -- otherwise, we use it as the name for the pipeline's output. output - | NoBackend <- backend dflags, notStopPreprocess = NoOutputFile + | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile -- avoid -E -fno-code undesirable interactions. see #20439 | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent -- -o foo applies to linker @@ -728,19 +728,19 @@ hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, Maybe Linkable) hscBackendPipeline pipe_env hsc_env mod_sum result = - case backend (hsc_dflags hsc_env) of - NoBackend -> - case result of - HscUpdate iface -> return (iface, Nothing) - HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure Nothing - -- TODO: Why is there not a linkable? - -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing - _ -> do + if backendGeneratesCode (backend (hsc_dflags hsc_env)) then + do res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env)) $ do let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow" () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result return res + else + case result of + HscUpdate iface -> return (iface, Nothing) + HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure Nothing + -- TODO: Why is there not a linkable? + -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing hscGenBackendPipeline :: P m => PipeEnv @@ -811,12 +811,19 @@ hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Ma hscPostBackendPipeline _ _ HsBootFile _ _ _ = return Nothing hscPostBackendPipeline _ _ HsigFile _ _ _ = return Nothing hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn = - case bcknd of - ViaC -> viaCPipeline HCc pipe_env hsc_env ml input_fn - NCG -> Just <$> asPipeline False pipe_env hsc_env ml input_fn - LLVM -> Just <$> llvmPipeline pipe_env hsc_env ml input_fn - NoBackend -> return Nothing - Interpreter -> return Nothing + applyPostHscPipeline (backendPostHscPipeline bcknd) pipe_env hsc_env ml input_fn + +applyPostHscPipeline + :: TPipelineClass TPhase m + => DefunctionalizedPostHscPipeline + -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) +applyPostHscPipeline NcgPostHscPipeline = + \pe he ml fp -> Just <$> asPipeline False pe he ml fp +applyPostHscPipeline ViaCPostHscPipeline = viaCPipeline HCc +applyPostHscPipeline LlvmPostHscPipeline = + \pe he ml fp -> Just <$> llvmPipeline pe he ml fp +applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing + -- Pipeline from a given suffix pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath) diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs index 58bc1e6907..86ba305461 100644 --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -44,7 +44,6 @@ import GHC.Utils.TmpFs import GHC.Platform import Data.List (intercalate, isInfixOf) import GHC.Unit.Env -import GHC.SysTools.Info import GHC.Utils.Error import Data.Maybe import GHC.CmmToLlvm.Mangler @@ -287,13 +286,11 @@ runAsPhase with_cpp pipe_env hsc_env location input_fn = do -- LLVM from version 3.0 onwards doesn't support the OS X system -- assembler, so we use clang as the assembler instead. (#5636) - let (as_prog, get_asm_info) | backend dflags == LLVM - , platformOS platform == OSDarwin - = (GHC.SysTools.runClang, pure Clang) - | otherwise - = (GHC.SysTools.runAs, getAssemblerInfo logger dflags) - - asmInfo <- get_asm_info + let (as_prog, get_asm_info) = + ( applyAssemblerProg $ backendAssemblerProg (backend dflags) + , applyAssemblerInfoGetter $ backendAssemblerInfoGetter (backend dflags) + ) + asmInfo <- get_asm_info logger dflags platform let cmdline_include_paths = includePaths dflags let pic_c_flags = picCCOpts dflags @@ -313,6 +310,7 @@ runAsPhase with_cpp pipe_env hsc_env location input_fn = do = withAtomicRename outputFilename $ \temp_outputFilename -> as_prog logger dflags + platform (local_includes ++ global_includes -- See Note [-fPIC for assembler] ++ map GHC.SysTools.Option pic_c_flags @@ -340,6 +338,29 @@ runAsPhase with_cpp pipe_env hsc_env location input_fn = do return output_fn +applyAssemblerInfoGetter + :: DefunctionalizedAssemblerInfoGetter + -> Logger -> DynFlags -> Platform -> IO CompilerInfo +applyAssemblerInfoGetter StandardAssemblerInfoGetter logger dflags _platform = + getAssemblerInfo logger dflags +applyAssemblerInfoGetter DarwinClangAssemblerInfoGetter logger dflags platform = + if platformOS platform == OSDarwin then + pure Clang + else + getAssemblerInfo logger dflags + +applyAssemblerProg + :: DefunctionalizedAssemblerProg + -> Logger -> DynFlags -> Platform -> [Option] -> IO () +applyAssemblerProg StandardAssemblerProg logger dflags _platform = + runAs logger dflags +applyAssemblerProg DarwinClangAssemblerProg logger dflags platform = + if platformOS platform == OSDarwin then + runClang logger dflags + else + runAs logger dflags + + runCcPhase :: Phase -> PipeEnv -> HscEnv -> FilePath -> IO FilePath runCcPhase cc_phase pipe_env hsc_env input_fn = do @@ -501,28 +522,10 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do hscs_partial_iface = partial_iface, hscs_old_iface_hash = mb_old_iface_hash } - -> case backend dflags of - NoBackend -> panic "HscRecomp not relevant for NoBackend" - Interpreter -> do - -- In interpreted mode the regular codeGen backend is not run so we - -- generate a interface without codeGen info. - final_iface <- mkFullIface hsc_env partial_iface Nothing - hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location - - (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location - - stub_o <- case hasStub of - Nothing -> return [] - Just stub_c -> do - stub_o <- compileStub hsc_env stub_c - return [DotO stub_o] - - let hs_unlinked = [BCOs comp_bc spt_entries] - unlinked_time <- getCurrentTime - let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) - (hs_unlinked ++ stub_o) - return ([], final_iface, Just linkable, panic "interpreter") - _ -> do + -> if not (backendGeneratesCode (backend dflags)) then + panic "HscRecomp not relevant for NoBackend" + else if backendWritesFiles (backend dflags) then + do output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location) (outputFilename, mStub, foreign_files, mb_cg_infos) <- hscGenHardCode hsc_env cgguts mod_location output_fn @@ -542,6 +545,27 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do -- is in TPipeline and in this branch we can invoke the rest of the backend phase. return (fos, final_iface, Nothing, outputFilename) + else + -- In interpreted mode the regular codeGen backend is not run so we + -- generate a interface without codeGen info. + do + final_iface <- mkFullIface hsc_env partial_iface Nothing + hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location + + (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location + + stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileStub hsc_env stub_c + return [DotO stub_o] + + let hs_unlinked = [BCOs comp_bc spt_entries] + unlinked_time <- getCurrentTime + let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) + (hs_unlinked ++ stub_o) + return ([], final_iface, Just linkable, panic "interpreter") + runUnlitPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath runUnlitPhase hsc_env input_fn output_fn = do @@ -991,7 +1015,7 @@ doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] - backend_defs <- getBackendDefs logger dflags + backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] -- Default CPP defines in Haskell source @@ -1043,8 +1067,9 @@ doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do , GHC.SysTools.FileOption "" output_fn ]) -getBackendDefs :: Logger -> DynFlags -> IO [String] -getBackendDefs logger dflags | backend dflags == LLVM = do +applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String] +applyCDefs NoCDefs _ _ = return [] +applyCDefs LlvmCDefs logger dflags = do llvmVer <- figureLlvmVersion logger dflags return $ case fmap llvmVersionList llvmVer of Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] @@ -1052,23 +1077,15 @@ getBackendDefs logger dflags | backend dflags == LLVM = do _ -> [] where format (major, minor) - | minor >= 100 = error "getBackendDefs: Unsupported minor version" - | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int + | minor >= 100 = error "backendCDefs: Unsupported minor version" + | otherwise = show (100 * major + minor :: Int) -- Contract is Int -getBackendDefs _ _ = - return [] -- | What phase to run after one of the backend code generators has run hscPostBackendPhase :: HscSource -> Backend -> Phase hscPostBackendPhase HsBootFile _ = StopLn hscPostBackendPhase HsigFile _ = StopLn -hscPostBackendPhase _ bcknd = - case bcknd of - ViaC -> HCc - NCG -> As False - LLVM -> LlvmOpt - NoBackend -> StopLn - Interpreter -> StopLn +hscPostBackendPhase _ bcknd = backendNormalSuccessorPhase bcknd compileStub :: HscEnv -> FilePath -> IO FilePath diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 0f1a4b6e02..f765bb44ce 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -2295,9 +2295,9 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "keep-s-files" (NoArg (setGeneralFlag Opt_KeepSFiles)) , make_ord_flag defGhcFlag "keep-llvm-file" - (NoArg $ setObjBackend LLVM >> setGeneralFlag Opt_KeepLlvmFiles) + (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles) , make_ord_flag defGhcFlag "keep-llvm-files" - (NoArg $ setObjBackend LLVM >> setGeneralFlag Opt_KeepLlvmFiles) + (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles) -- This only makes sense as plural , make_ord_flag defGhcFlag "keep-tmp-files" (NoArg (setGeneralFlag Opt_KeepTmpFiles)) @@ -2473,7 +2473,7 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) , make_ord_flag defGhcFlag "ddump-llvm" - (NoArg $ setObjBackend LLVM >> setDumpFlag' Opt_D_dump_llvm) + (NoArg $ setObjBackend llvmBackend >> setDumpFlag' Opt_D_dump_llvm) , make_ord_flag defGhcFlag "ddump-c-backend" (NoArg $ setDumpFlag' Opt_D_dump_c_backend) , make_ord_flag defGhcFlag "ddump-deriv" @@ -2902,20 +2902,20 @@ dynamic_flags_deps = [ (NoArg (setGeneralFlag Opt_InfoTableMap)) ------ Compiler flags ----------------------------------------------- - , make_ord_flag defGhcFlag "fasm" (NoArg (setObjBackend NCG)) + , make_ord_flag defGhcFlag "fasm" (NoArg (setObjBackend ncgBackend)) , make_ord_flag defGhcFlag "fvia-c" (NoArg (deprecate $ "The -fvia-c flag does nothing; " ++ "it will be removed in a future GHC release")) , make_ord_flag defGhcFlag "fvia-C" (NoArg (deprecate $ "The -fvia-C flag does nothing; " ++ "it will be removed in a future GHC release")) - , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjBackend LLVM)) + , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjBackend llvmBackend)) , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> - d { ghcLink=NoLink }) >> setBackend NoBackend)) + d { ghcLink=NoLink }) >> setBackend noBackend)) , make_ord_flag defFlag "fbyte-code" (noArgM $ \dflags -> do - setBackend Interpreter + setBackend interpreterBackend pure $ gopt_set dflags Opt_ByteCode) , make_ord_flag defFlag "fobject-code" $ NoArg $ do dflags <- liftEwM getCmdLineState @@ -4415,7 +4415,7 @@ addReexportedModule p = -- code are allowed (requests for other target types are ignored). setBackend :: Backend -> DynP () setBackend l = upd $ \ dfs -> - if ghcLink dfs /= LinkBinary || backendProducesObject l + if ghcLink dfs /= LinkBinary || backendWritesFiles l then dfs{ backend = l } else dfs @@ -4427,7 +4427,7 @@ setObjBackend :: Backend -> DynP () setObjBackend l = updM set where set dflags - | backendProducesObject (backend dflags) + | backendWritesFiles (backend dflags) = return $ dflags { backend = l } | otherwise = return dflags @@ -4774,30 +4774,33 @@ makeDynFlagsConsistent dflags -- Via-C backend only supports unregisterised ABI. Switch to a backend -- supporting it if possible. - | backend dflags == ViaC && + | backendUnregisterisedAbiOnly (backend dflags) && not (platformUnregisterised (targetPlatform dflags)) - = case platformDefaultBackend (targetPlatform dflags) of - NCG -> let dflags' = dflags { backend = NCG } - warn = "Target platform doesn't use unregisterised ABI, so using native code generator rather than compiling via C" - in loop dflags' warn - LLVM -> let dflags' = dflags { backend = LLVM } - warn = "Target platform doesn't use unregisterised ABI, so using LLVM rather than compiling via C" - in loop dflags' warn - _ -> pgmError "Compiling via C only supports unregisterised ABI but target platform doesn't use it." - - | gopt Opt_Hpc dflags && backend dflags == Interpreter + = let b = platformDefaultBackend (targetPlatform dflags) + in if backendSwappableWithViaC b then + let dflags' = dflags { backend = b } + warn = "Target platform doesn't use unregisterised ABI, so using " ++ + backendDescription b ++ " rather than " ++ + backendDescription (backend dflags) + in loop dflags' warn + else + pgmError (backendDescription (backend dflags) ++ + " supports only unregisterised ABI but target platform doesn't use it.") + + | gopt Opt_Hpc dflags && not (backendSupportsHpc (backend dflags)) = let dflags' = gopt_unset dflags Opt_Hpc - warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc." + warn = "Hpc can't be used with " ++ backendDescription (backend dflags) ++ + ". Ignoring -fhpc." in loop dflags' warn - | backend dflags `elem` [NCG, LLVM] && + | backendSwappableWithViaC (backend dflags) && platformUnregisterised (targetPlatform dflags) - = loop (dflags { backend = ViaC }) + = loop (dflags { backend = viaCBackend }) "Target platform uses unregisterised ABI, so compiling via C" - | backend dflags == NCG && + | backendNeedsPlatformNcgSupport (backend dflags) && not (platformNcgSupported $ targetPlatform dflags) - = let dflags' = dflags { backend = LLVM } + = let dflags' = dflags { backend = llvmBackend } warn = "Native code generator doesn't support target platform, so using LLVM" in loop dflags' warn @@ -4810,15 +4813,17 @@ makeDynFlagsConsistent dflags = loop (gopt_set dflags Opt_PIC) "Enabling -fPIC as it is always on for this platform" - | backend dflags == Interpreter + | backendForcesOptimization0 (backend dflags) , let (dflags', changed) = updOptLevelChanged 0 dflags , changed - = loop dflags' "Optimization flags conflict with --interactive; optimization flags ignored." + = loop dflags' ("Optimization flags are incompatible with the " ++ + backendDescription (backend dflags) ++ + "; optimization flags ignored.") | LinkInMemory <- ghcLink dflags , not (gopt Opt_ExternalInterpreter dflags) , hostIsProfiled - , backendProducesObject (backend dflags) + , backendWritesFiles (backend dflags) , ways dflags `hasNotWay` WayProf = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)} "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index b95a5aebbe..b1a6e6f572 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -371,7 +371,7 @@ addExportFlagsAndRules bcknd exports keep_alive rules prs -- isExternalName separates the user-defined top-level names from those -- introduced by the type checker. is_exported :: Name -> Bool - is_exported | backendRetainsAllBindings bcknd = isExternalName + is_exported | backendWantsGlobalBindings bcknd = isExternalName | otherwise = (`elemNameSet` exports) {- diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index f2948cee5e..09cd86f952 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -1078,7 +1078,7 @@ coveragePasses dflags = -- | Should we produce 'Breakpoint' ticks? breakpointsEnabled :: DynFlags -> Bool -breakpointsEnabled dflags = backend dflags == Interpreter +breakpointsEnabled dflags = backendWantsBreakpointTicks (backend dflags) -- | Tickishs that only make sense when their source code location -- refers to the current file. This might not always be true due to diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 7cf782a18d..7a7b66b137 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -340,7 +340,7 @@ mkIface_ hsc_env -- scope available. (#5534) maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv maybeGlobalRdrEnv rdr_env - | backendRetainsAllBindings (backend dflags) = Just rdr_env + | backendWantsGlobalBindings (backend dflags) = Just rdr_env | otherwise = Nothing ifFamInstTcName = ifFamInstFam diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index d6ee899794..1a978f9000 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -323,7 +323,7 @@ check_old_iface hsc_env mod_summary maybe_iface -- If the source has changed and we're in interactive mode, -- avoid reading an interface; just return the one we might -- have been supplied with. - True | not (backendProducesObject $ backend dflags) -> + True | not (backendWritesFiles $ backend dflags) -> return $ OutOfDateItem MustCompile maybe_iface -- Try and read the old interface for the current module diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 21a037aeee..4efcf69d18 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -179,7 +179,8 @@ cgTopBinding logger tmpfs cfg = \case StgTopStringLit id str -> do let label = mkBytesLabel (idName id) -- emit either a CmmString literal or dump the string in a file and emit a - -- CmmFileEmbed literal. + -- CmmFileEmbed literal. If binary blobs aren't supported, + -- the threshold in `cfg` will be 0. -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr let asString = case stgToCmmBinBlobThresh cfg of Just bin_blob_threshold -> fromIntegral (BS.length str) <= bin_blob_threshold diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs index 312ec7897a..a1846980a1 100644 --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -44,7 +44,7 @@ import System.Process -} runUnlit :: Logger -> DynFlags -> [Option] -> IO () -runUnlit logger dflags args = traceToolCommand logger "unlit" $ do +runUnlit logger dflags args = traceSystoolCommand logger "unlit" $ do let prog = pgm_L dflags opts = getOpts dflags opt_L runSomething logger "Literate pre-processor" prog @@ -60,7 +60,7 @@ augmentImports dflags ("-include":fp:fps) = "-include" : augmentByWorkingDirecto augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps) runCpp :: Logger -> DynFlags -> [Option] -> IO () -runCpp logger dflags args = traceToolCommand logger "cpp" $ do +runCpp logger dflags args = traceSystoolCommand logger "cpp" $ do let opts = getOpts dflags opt_P modified_imports = augmentImports dflags opts let (p,args0) = pgm_P dflags @@ -72,14 +72,14 @@ runCpp logger dflags args = traceToolCommand logger "cpp" $ do (args0 ++ args1 ++ args2 ++ args) Nothing mb_env runPp :: Logger -> DynFlags -> [Option] -> IO () -runPp logger dflags args = traceToolCommand logger "pp" $ do +runPp logger dflags args = traceSystoolCommand logger "pp" $ do let prog = pgm_F dflags opts = map Option (getOpts dflags opt_F) runSomething logger "Haskell pre-processor" prog (args ++ opts) -- | Run compiler of C-like languages and raw objects (such as gcc or clang). runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO () -runCc mLanguage logger tmpfs dflags args = traceToolCommand logger "cc" $ do +runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do let args1 = map Option userOpts args2 = languageOptions ++ args ++ args1 -- We take care to pass -optc flags in args1 last to ensure that the @@ -167,7 +167,7 @@ xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) -- | Run the linker with some arguments and return the output askLd :: Logger -> DynFlags -> [Option] -> IO String -askLd logger dflags args = traceToolCommand logger "linker" $ do +askLd logger dflags args = traceSystoolCommand logger "linker" $ do let (p,args0) = pgm_l dflags args1 = map Option (getOpts dflags opt_l) args2 = args0 ++ args1 ++ args @@ -176,7 +176,7 @@ askLd logger dflags args = traceToolCommand logger "linker" $ do readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } runAs :: Logger -> DynFlags -> [Option] -> IO () -runAs logger dflags args = traceToolCommand logger "as" $ do +runAs logger dflags args = traceSystoolCommand logger "as" $ do let (p,args0) = pgm_a dflags args1 = map Option (getOpts dflags opt_a) args2 = args0 ++ args1 ++ args @@ -185,7 +185,7 @@ runAs logger dflags args = traceToolCommand logger "as" $ do -- | Run the LLVM Optimiser runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO () -runLlvmOpt logger dflags args = traceToolCommand logger "opt" $ do +runLlvmOpt logger dflags args = traceSystoolCommand logger "opt" $ do let (p,args0) = pgm_lo dflags args1 = map Option (getOpts dflags opt_lo) -- We take care to pass -optlo flags (e.g. args0) last to ensure that the @@ -194,7 +194,7 @@ runLlvmOpt logger dflags args = traceToolCommand logger "opt" $ do -- | Run the LLVM Compiler runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO () -runLlvmLlc logger dflags args = traceToolCommand logger "llc" $ do +runLlvmLlc logger dflags args = traceSystoolCommand logger "llc" $ do let (p,args0) = pgm_lc dflags args1 = map Option (getOpts dflags opt_lc) runSomething logger "LLVM Compiler" p (args0 ++ args1 ++ args) @@ -203,7 +203,7 @@ runLlvmLlc logger dflags args = traceToolCommand logger "llc" $ do -- backend on OS X as LLVM doesn't support the OS X system -- assembler) runClang :: Logger -> DynFlags -> [Option] -> IO () -runClang logger dflags args = traceToolCommand logger "clang" $ do +runClang logger dflags args = traceSystoolCommand logger "clang" $ do let (clang,_) = pgm_lcc dflags -- be careful what options we call clang with -- see #5903 and #7617 for bugs caused by this. @@ -223,7 +223,7 @@ runClang logger dflags args = traceToolCommand logger "clang" $ do -- | Figure out which version of LLVM we are running this session figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion) -figureLlvmVersion logger dflags = traceToolCommand logger "llc" $ do +figureLlvmVersion logger dflags = traceSystoolCommand logger "llc" $ do let (pgm,opts) = pgm_lc dflags args = filter notNull (map showOpt opts) -- we grab the args even though they should be useless just in @@ -266,7 +266,7 @@ figureLlvmVersion logger dflags = traceToolCommand logger "llc" $ do runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () -runLink logger tmpfs dflags args = traceToolCommand logger "linker" $ do +runLink logger tmpfs dflags args = traceSystoolCommand logger "linker" $ do -- See Note [Run-time linker info] -- -- `-optl` args come at the end, so that later `-l` options @@ -331,7 +331,7 @@ ld: warning: symbol referencing errors -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () runMergeObjects logger tmpfs dflags args = - traceToolCommand logger "merge-objects" $ do + traceSystoolCommand logger "merge-objects" $ do let (p,args0) = fromMaybe err (pgm_lm dflags) err = throwGhcException $ UsageError $ unwords [ "Attempted to merge object files but the configured linker" @@ -348,7 +348,7 @@ runMergeObjects logger tmpfs dflags args = runSomething logger "Merge objects" p args2 runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO () -runAr logger dflags cwd args = traceToolCommand logger "ar" $ do +runAr logger dflags cwd args = traceSystoolCommand logger "ar" $ do let ar = pgm_ar dflags runSomethingFiltered logger id "Ar" ar args cwd Nothing @@ -364,12 +364,12 @@ runInstallNameTool logger dflags args = do runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing runRanlib :: Logger -> DynFlags -> [Option] -> IO () -runRanlib logger dflags args = traceToolCommand logger "ranlib" $ do +runRanlib logger dflags args = traceSystoolCommand logger "ranlib" $ do let ranlib = pgm_ranlib dflags runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing runWindres :: Logger -> DynFlags -> [Option] -> IO () -runWindres logger dflags args = traceToolCommand logger "windres" $ do +runWindres logger dflags args = traceSystoolCommand logger "windres" $ do let cc_args = map Option (sOpt_c (settings dflags)) windres = pgm_windres dflags opts = map Option (getOpts dflags opt_windres) @@ -377,17 +377,5 @@ runWindres logger dflags args = traceToolCommand logger "windres" $ do runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env touch :: Logger -> DynFlags -> String -> String -> IO () -touch logger dflags purpose arg = traceToolCommand logger "touch" $ +touch logger dflags purpose arg = traceSystoolCommand logger "touch" $ runSomething logger purpose (pgm_T dflags) [FileOption "" arg] - --- * Tracing utility - --- | Record in the eventlog when the given tool command starts --- and finishes, prepending the given 'String' with --- \"systool:\", to easily be able to collect and process --- all the systool events. --- --- For those events to show up in the eventlog, you need --- to run GHC with @-v2@ or @-ddump-timings@. -traceToolCommand :: Logger -> String -> IO a -> IO a -traceToolCommand logger tool = withTiming logger (text "systool:" <> text tool) (const ()) diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 59bde4f0aa..b8ed303dd7 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -41,7 +41,7 @@ import GHC.Core.Predicate import GHC.Core.Type import GHC.Driver.Flags - +import GHC.Driver.Backend import GHC.Hs import GHC.Tc.Errors.Types @@ -737,12 +737,9 @@ instance Diagnostic TcRnMessage where text "possible missing & in foreign import of FunPtr" TcRnIllegalForeignDeclBackend _decl _backend expectedBknds - -> mkSimpleDecorated $ text "Illegal foreign declaration:" <+> - case expectedBknds of - COrAsmOrLlvm -> - text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)" - COrAsmOrLlvmOrInterp -> - text "requires interpreted, unregisterised, llvm or native code generation" + -> mkSimpleDecorated $ + fsep (text "Illegal foreign declaration: requires one of these back ends:" : + commafyWith (text "or") (map (text . backendDescription) expectedBknds)) TcRnUnsupportedCallConv _decl unsupportedCC -> mkSimpleDecorated $ @@ -1481,6 +1478,18 @@ instance Diagnostic TcRnMessage where TcRnUnpromotableThing{} -> noHints + +-- | Change [x] to "x", [x, y] to "x and y", [x, y, z] to "x, y, and z", +-- and so on. The `and` stands for any `conjunction`, which is passed in. +commafyWith :: SDoc -> [SDoc] -> [SDoc] +commafyWith _ [] = [] +commafyWith _ [x] = [x] +commafyWith conjunction [x, y] = [x <+> conjunction <+> y] +commafyWith conjunction xs = addConjunction $ punctuate comma xs + where addConjunction [x, y] = [x, conjunction, y] + addConjunction (x : xs) = x : addConjunction xs + addConjunction _ = panic "commafyWith expected 2 or more elements" + deriveInstanceErrReasonHints :: Class -> UsingGeneralizedNewtypeDeriving -> DeriveInstanceErrReason diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index b1f635325a..182818616a 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -62,7 +62,7 @@ module GHC.Tc.Errors.Types ( , CoercibleMsg(..) , PotentialInstances(..) , UnsupportedCallConvention(..) - , ExpectedBackends(..) + , ExpectedBackends , ArgOrResult(..) ) where @@ -2008,11 +2008,8 @@ data TcRnMessage where -} TcRnUnpromotableThing :: !Name -> !PromotionErr -> TcRnMessage --- | Specifies which backend code generators where expected for an FFI declaration -data ExpectedBackends - = COrAsmOrLlvm -- ^ C, Asm, or LLVM - | COrAsmOrLlvmOrInterp -- ^ C, Asm, LLVM, or interpreted - deriving Eq +-- | Specifies which back ends can handle a requested foreign import or export +type ExpectedBackends = [Backend] -- | Specifies which calling convention is unsupported on the current platform data UnsupportedCallConvention diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index 31f47227c8..819c66b2c2 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -268,7 +268,7 @@ tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh l@(CLabel _) src) -- Foreign import label - = do checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + = do checkCg (Right idecl) backendValidityOfCImport -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a) check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) @@ -281,7 +281,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh CWrapper src) -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. -- The use of the latter form is DEPRECATED, though. - checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + checkCg (Right idecl) backendValidityOfCImport cconv' <- checkCConv (Right idecl) cconv case arg_tys of [Scaled arg1_mult arg1_ty] -> do @@ -297,7 +297,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh CWrapper src) tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh (CFunction target) src) | isDynamicTarget target = do -- Foreign import dynamic - checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + checkCg (Right idecl) backendValidityOfCImport cconv' <- checkCConv (Right idecl) cconv case arg_tys of -- The first arg must be Ptr or FunPtr [] -> @@ -315,7 +315,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh dflags <- getDynFlags checkTc (xopt LangExt.GHCForeignImportPrim dflags) (TcRnForeignImportPrimExtNotSet idecl) - checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + checkCg (Right idecl) backendValidityOfCImport checkCTarget idecl target checkTc (playSafe safety) (TcRnForeignImportPrimSafeAnn idecl) @@ -324,7 +324,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty return idecl | otherwise = do -- Normal foreign import - checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + checkCg (Right idecl) backendValidityOfCImport cconv' <- checkCConv (Right idecl) cconv checkCTarget idecl target dflags <- getDynFlags @@ -342,7 +342,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh -- that the C identifier is valid for C checkCTarget :: ForeignImport -> CCallTarget -> TcM () checkCTarget idecl (StaticTarget _ str _ _) = do - checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp + checkCg (Right idecl) backendValidityOfCImport checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget" @@ -415,7 +415,7 @@ tcFExport d = pprPanic "tcFExport" (ppr d) tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport tcCheckFEType sig_ty edecl@(CExport (L l (CExportStatic esrc str cconv)) src) = do - checkCg (Left edecl) checkCOrAsmOrLlvm + checkCg (Left edecl) backendValidityOfCExport checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) cconv' <- checkCConv (Left edecl) cconv checkForeignArgs isFFIExternalTy arg_tys @@ -497,32 +497,14 @@ checkSafe, noCheckSafe :: Bool checkSafe = True noCheckSafe = False --- | Checking a supported backend is in use -checkCOrAsmOrLlvm :: Backend -> Validity' ExpectedBackends -checkCOrAsmOrLlvm ViaC = IsValid -checkCOrAsmOrLlvm NCG = IsValid -checkCOrAsmOrLlvm LLVM = IsValid -checkCOrAsmOrLlvm _ = NotValid COrAsmOrLlvm - --- | Checking a supported backend is in use -checkCOrAsmOrLlvmOrInterp :: Backend -> Validity' ExpectedBackends -checkCOrAsmOrLlvmOrInterp ViaC = IsValid -checkCOrAsmOrLlvmOrInterp NCG = IsValid -checkCOrAsmOrLlvmOrInterp LLVM = IsValid -checkCOrAsmOrLlvmOrInterp Interpreter = IsValid -checkCOrAsmOrLlvmOrInterp _ = NotValid COrAsmOrLlvmOrInterp - checkCg :: Either ForeignExport ForeignImport -> (Backend -> Validity' ExpectedBackends) -> TcM () checkCg decl check = do dflags <- getDynFlags let bcknd = backend dflags - case bcknd of - NoBackend -> return () - _ -> - case check bcknd of - IsValid -> return () - NotValid expectedBcknd -> - addErrTc $ TcRnIllegalForeignDeclBackend decl bcknd expectedBcknd + case check bcknd of + IsValid -> return () + NotValid expectedBcknds -> + addErrTc $ TcRnIllegalForeignDeclBackend decl bcknd expectedBcknds -- Calling conventions diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 874870765f..95cb2f467f 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -858,12 +858,8 @@ tcImpPrags prags -- when we aren't specialising, or when we aren't generating -- code. The latter happens when Haddocking the base library; -- we don't want complaints about lack of INLINABLE pragmas - not_specialising dflags - | not (gopt Opt_Specialise dflags) = True - | otherwise = case backend dflags of - NoBackend -> True - Interpreter -> True - _other -> False + not_specialising dflags = + not (gopt Opt_Specialise dflags) || not (backendRespectsSpecialise (backend dflags)) tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] tcImpSpec (name, prag) diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index 54c5ad47ec..4c651cc9c2 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -1940,9 +1940,9 @@ it preserved boxity in its argument. That was needed for code like (# s', r) -> f x which uses `x` *boxed*. If we `lub`bed it with `(DmdType emptyDmdEnv [] exnDiv)` -we'd get an *unboxed* demand on `x` (because we let Unboxed win), which led to -#20746. -Nowadays with `lubBoxity = boxedWins` we don't need the complicated definition. +we'd get an *unboxed* demand on `x` (because we let Unboxed win), +which led to #20746. Nowadays with `lubBoxity = boxedWins` we don't need +the complicated definition. Note [Demand type Divergence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs index 06f3fcdc68..c09d778086 100644 --- a/compiler/GHC/Unit/Module/Graph.hs +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -271,10 +271,9 @@ showModMsg dflags recomp (ModuleNode _ mod_summary) = mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) dyn_file = op $ msDynObjFilePath mod_summary obj_file = op $ msObjFilePath mod_summary - message = case backend dflags of - Interpreter | recomp -> text "interpreted" - NoBackend -> text "nothing" - _ -> + message = case backendSpecialModuleSource (backend dflags) recomp of + Just special -> text special + Nothing -> if gopt Opt_BuildDynamicToo dflags then text obj_file <> comma <+> text dyn_file else text obj_file diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index ef6dd4f07d..8c044c5af9 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -58,6 +58,7 @@ module GHC.Utils.Error ( ghcExit, prettyPrintGhcErrors, traceCmd, + traceSystoolCommand, sortMsgBag ) where @@ -460,6 +461,20 @@ traceCmd logger phase_name cmd_line action = do -- And run it! action `catchIO` handle_exn + +-- * Tracing utility + +-- | Record in the eventlog when the given tool command starts +-- and finishes, prepending the given 'String' with +-- \"systool:\", to easily be able to collect and process +-- all the systool events. +-- +-- For those events to show up in the eventlog, you need +-- to run GHC with @-v2@ or @-ddump-timings@. +traceSystoolCommand :: Logger -> String -> IO a -> IO a +traceSystoolCommand logger tool = withTiming logger (text "systool:" <> text tool) (const ()) + + {- Note [withTiming] ~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 153263cdda..392f0a4f84 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -379,6 +379,7 @@ Library GHC.Data.TrieMap GHC.Data.UnionFind GHC.Driver.Backend + GHC.Driver.Backend.Internal GHC.Driver.Backpack GHC.Driver.Backpack.Syntax GHC.Driver.CmdLine |