diff options
| author | Norman Ramsey <nr@cs.tufts.edu> | 2022-02-07 10:42:36 -0500 |
|---|---|---|
| committer | Cheng Shao <astrohavoc@gmail.com> | 2022-05-21 03:11:04 +0000 |
| commit | 4aa3c5bde8c54f6ab8cbb2a574f7654590c077ca (patch) | |
| tree | 43e79b6f797f12a3eb040252a20ac80659c55514 | |
| parent | 36b8a57cb30c1374cce749b6f1554a2d438336b9 (diff) | |
| download | haskell-wip/backend-as-record.tar.gz | |
Change `Backend` type and remove direct dependencieswip/backend-as-record
With this change, `Backend` becomes an abstract type
(there are no more exposed value constructors).
Decisions that were formerly made by asking "is the
current back end equal to (or different from) this named value
constructor?" are now made by interrogating the back end about
its properties, which are functions exported by `GHC.Driver.Backend`.
There is a description of how to migrate code using `Backend` in the
user guide.
Clients using the GHC API can find a backdoor to access the Backend
datatype in GHC.Driver.Backend.Internal.
Bumps haddock submodule.
Fixes #20927
49 files changed, 1306 insertions, 362 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 diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst index 998ddeeec0..acc8791fb0 100644 --- a/docs/users_guide/extending_ghc.rst +++ b/docs/users_guide/extending_ghc.rst @@ -1585,3 +1585,116 @@ you cannot from a ``DynFlags`` plugin register other plugins by just adding them to the ``plugins`` field of ``DynFlags``. In order to achieve this, you would have to load them yourself and store the result into the ``cachedPlugins`` field of ``DynFlags``. + + +Referring to back ends +---------------------- + +In versions of GHC numbered up to and including 9.4, a back end is +referred to by name: type ``Backend``, from module +``GHC.Driver.Backend``, is a simple enumeration type. In versions of GHC +numbered 9.6 and higher, ``Backend`` is an abstract type. The module +specifies predicates and functions associated with a back end. + +This change in representation requires changes in client code. + +Client code that only names back ends +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Suppose your client uses ``Backend`` only to mention back ends by name. +That is, it never discriminates between back ends in a ``case`` +expression, function definition, or equality comparison. Then the +simplest way for you to migrate your code is to replace each value +constructor from version 9.4 with the corresponding value from 9.6: + ++-----------------+------------------------+ +| Old value | New value | ++=================+========================+ +| ``NCG`` | ``ncgBackend`` | ++-----------------+------------------------+ +| ``LLVM`` | ``llvmBackend`` | ++-----------------+------------------------+ +| ``ViaC`` | ``viaCBackend`` | ++-----------------+------------------------+ +| ``Interpreter`` | ``interpreterBackend`` | ++-----------------+------------------------+ +| ``NoBackend`` | ``noBackend`` | ++-----------------+------------------------+ + +Client code that discriminates among back ends +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Suppose your code makes decisions based on the value of an expression of +type ``Backend``. Then the simplest way for you to migrate your +decision-making code depends on the code’s form. + +- If your decision-making is driven by an equality or inequality + predicate, an equivalent predicate may already be defined in module + ``GHC.Driver.Backend``. For example, if your client wants to be + sure that optimization levels above ``-O0`` are permitted, it might + have originally compared ``backend /= Interpreter``. But now there is + a predicate for that: it is + ``not (backendForcesOptimization0 backend)``. + + If the predicate you want is not already defined, you will have to + fall back on the more general strategy defined below. + +- If your decision-making is still driven by a predicate, but the + implementation of the predicate inspects the form of ``Backend``, you + may still be in luck. For example, if your client needs to know + whether the ``Backend`` wishes to write files to disk, it can query + ``backendWritesFiles backend``. In version 9.4, this predicate holds + for the NCG, LLVM, and Via-C back ends, but not for the interpreter + or for ``NoBackend``. + +- In the general case, for any function definition, case expression, or + equality test that discriminates among back ends, you can use the + general migration strategy described below. + +General migration strategy for client code +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +From version 9.6 onward, each back end may be +queried for its name: + +:: + + backendName :: Backend -> BackendName + +The ``BackendName`` type must be imported from module ``GHC.Driver.Backend.Internal``. +It is defined to look the same as the old +``Backend`` type: + +:: + + data BackendName + = NCG + | LLVM + | ViaC + | Interpreter + | NoBackend + +This type is also an instance of the ``Eq`` and ``Show`` classes. + + +If your existing code discriminates among existing back ends using a +``case`` expression, you need to apply ``backendName`` to the scrutinee. + +:: + + case backend dflags of -- code using the 9.4 interface + NCG -> ... + LLVM -> ... + ... + +can become + +:: + + case backendName $ backend dflags of -- code using the 9.6 interface + NCG -> ... + LLVM -> ... + ... + +Only the scrutinee changes, not the pattern matches. And if your pattern +matches were complete before, they are still complete. diff --git a/ghc/Main.hs b/ghc/Main.hs index 8e30d1a765..45dd5fede1 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -16,9 +16,10 @@ module Main (main) where -- The official GHC API import qualified GHC -import GHC (parseTargetFiles, Ghc, GhcMonad(..), Backend (..), +import GHC (parseTargetFiles, Ghc, GhcMonad(..), LoadHowMuch(..) ) +import GHC.Driver.Backend import GHC.Driver.CmdLine import GHC.Driver.Env import GHC.Driver.Errors @@ -175,9 +176,9 @@ main' postLoadMode units dflags0 args flagWarnings = do let dflt_backend = backend dflags0 (mode, bcknd, link) = case postLoadMode of - DoInteractive -> (CompManager, Interpreter, LinkInMemory) - DoEval _ -> (CompManager, Interpreter, LinkInMemory) - DoRun -> (CompManager, Interpreter, LinkInMemory) + DoInteractive -> (CompManager, interpreterBackend, LinkInMemory) + DoEval _ -> (CompManager, interpreterBackend, LinkInMemory) + DoRun -> (CompManager, interpreterBackend, LinkInMemory) DoMake -> (CompManager, dflt_backend, LinkBinary) DoBackpack -> (CompManager, dflt_backend, LinkBinary) DoMkDependHS -> (MkDepend, dflt_backend, LinkBinary) @@ -217,8 +218,9 @@ main' postLoadMode units dflags0 args flagWarnings = do (dflags3, fileish_args, dynamicFlagWarnings) <- GHC.parseDynamicFlags logger2 dflags2 args' - let dflags4 = case bcknd of - Interpreter | not (gopt Opt_ExternalInterpreter dflags3) -> + let dflags4 = if backendNeedsFullWays bcknd && + not (gopt Opt_ExternalInterpreter dflags3) + then let platform = targetPlatform dflags3 dflags3a = dflags3 { targetWays_ = hostFullWays } dflags3b = foldl gopt_set dflags3a @@ -228,7 +230,7 @@ main' postLoadMode units dflags0 args flagWarnings = do $ concatMap (wayUnsetGeneralFlags platform) hostFullWays in dflags3c - _ -> + else dflags3 let logger4 = setLogFlags logger2 (initLogFlags dflags4) @@ -364,7 +366,7 @@ checkOptions mode dflags srcs objs units = do else do case mode of - StopBefore StopC | backend dflags /= ViaC + StopBefore StopC | not (backendGeneratesHc (backend dflags)) -> throwGhcException $ UsageError $ "the option -C is only available with an unregisterised GHC" StopBefore StopAs | ghcLink dflags == NoLink diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index 2dfd8309c7..31cf9d458a 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -1,4 +1,4 @@ -Found 284 Language.Haskell.Syntax module dependencies +Found 285 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.PrimOps.Ids @@ -86,6 +86,7 @@ GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap GHC.Driver.Backend +GHC.Driver.Backend.Internal GHC.Driver.CmdLine GHC.Driver.Config.Diagnostic GHC.Driver.Config.Logger diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index 8a64148831..b3834a0f92 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -1,4 +1,4 @@ -Found 291 GHC.Parser module dependencies +Found 292 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.PrimOps.Ids @@ -86,6 +86,7 @@ GHC.Data.Strict GHC.Data.StringBuffer GHC.Data.TrieMap GHC.Driver.Backend +GHC.Driver.Backend.Internal GHC.Driver.Backpack.Syntax GHC.Driver.CmdLine GHC.Driver.Config.Diagnostic diff --git a/testsuite/tests/driver/T5313.hs b/testsuite/tests/driver/T5313.hs index 7379e9bb53..c64a9f38b8 100644 --- a/testsuite/tests/driver/T5313.hs +++ b/testsuite/tests/driver/T5313.hs @@ -7,7 +7,7 @@ main = do -- begin initialize df0 <- GHC.getSessionDynFlags let df1 = df0{GHC.ghcMode = GHC.CompManager, - GHC.backend = GHC.Interpreter, + GHC.backend = GHC.interpreterBackend, GHC.ghcLink = GHC.LinkInMemory, GHC.verbosity = 0} _ <- GHC.setSessionDynFlags df1 diff --git a/testsuite/tests/ghc-api/T10052/T10052.hs b/testsuite/tests/ghc-api/T10052/T10052.hs index 2b82a41c15..472667b188 100644 --- a/testsuite/tests/ghc-api/T10052/T10052.hs +++ b/testsuite/tests/ghc-api/T10052/T10052.hs @@ -23,7 +23,7 @@ runGhc' args act = do logger <- getLogger (dflags1, _leftover, _warns) <- parseDynamicFlags logger dflags0 flags let dflags2 = dflags1 { - backend = Interpreter + backend = interpreterBackend , ghcLink = LinkInMemory , verbosity = 1 } diff --git a/testsuite/tests/ghc-api/T10052/T10052.stderr b/testsuite/tests/ghc-api/T10052/T10052.stderr index 50db4fe9f2..14d76b9f49 100644 --- a/testsuite/tests/ghc-api/T10052/T10052.stderr +++ b/testsuite/tests/ghc-api/T10052/T10052.stderr @@ -1,3 +1,3 @@ when making flags consistent: warning: - Optimization flags conflict with --interactive; optimization flags ignored. + Optimization flags are incompatible with the byte-code interpreter; optimization flags ignored. diff --git a/testsuite/tests/ghc-api/T8639_api.hs b/testsuite/tests/ghc-api/T8639_api.hs index e74b994a27..8b9b5ce95d 100644 --- a/testsuite/tests/ghc-api/T8639_api.hs +++ b/testsuite/tests/ghc-api/T8639_api.hs @@ -11,7 +11,7 @@ main = do { [libdir] <- getArgs ; runGhc (Just libdir) $ do flags <- getSessionDynFlags - setSessionDynFlags (flags{ backend = Interpreter, ghcLink = LinkInMemory}) + setSessionDynFlags (flags{ backend = interpreterBackend, ghcLink = LinkInMemory}) target <- guessTarget "T8639_api_a.hs" Nothing Nothing setTargets [target] load LoadAllTargets diff --git a/testsuite/tests/ghc-api/apirecomp001/myghc.hs b/testsuite/tests/ghc-api/apirecomp001/myghc.hs index 3d2cb9c238..7f1d7cdfff 100644 --- a/testsuite/tests/ghc-api/apirecomp001/myghc.hs +++ b/testsuite/tests/ghc-api/apirecomp001/myghc.hs @@ -26,7 +26,7 @@ main = do logger <- getLogger (dflags, _, _) <- parseDynamicFlags logger dflags0 (map (mkGeneralLocated "on the commandline") args) - setSessionDynFlags $ dflags { backend = NoBackend + setSessionDynFlags $ dflags { backend = noBackend , ghcLink = LinkInMemory , verbosity = 0 -- silence please } @@ -37,7 +37,7 @@ main = do prn "target nothing: ok" dflags <- getSessionDynFlags - setSessionDynFlags $ dflags { backend = Interpreter } + setSessionDynFlags $ dflags { backend = interpreterBackend } ok <- load LoadAllTargets when (failed ok) $ error "Couldn't load A.hs in interpreted mode" prn "target interpreted: ok" diff --git a/testsuite/tests/ghci.debugger/scripts/print007.stderr b/testsuite/tests/ghci.debugger/scripts/print007.stderr index 50db4fe9f2..14d76b9f49 100644 --- a/testsuite/tests/ghci.debugger/scripts/print007.stderr +++ b/testsuite/tests/ghci.debugger/scripts/print007.stderr @@ -1,3 +1,3 @@ when making flags consistent: warning: - Optimization flags conflict with --interactive; optimization flags ignored. + Optimization flags are incompatible with the byte-code interpreter; optimization flags ignored. diff --git a/testsuite/tests/ghci/linking/dyn/T3372.hs b/testsuite/tests/ghci/linking/dyn/T3372.hs index e49e0a1672..91f67fabcd 100644 --- a/testsuite/tests/ghci/linking/dyn/T3372.hs +++ b/testsuite/tests/ghci/linking/dyn/T3372.hs @@ -41,7 +41,7 @@ newGhcServer = do (libdir:_) <- getArgs where ghc action libdir = GHC.runGhc (Just libdir) (init >> action) init = do df <- GHC.getSessionDynFlags GHC.setSessionDynFlags df{GHC.ghcMode = GHC.CompManager, - GHC.backend = GHC.Interpreter, + GHC.backend = GHC.interpreterBackend, GHC.ghcLink = GHC.LinkInMemory, GHC.verbosity = 0} diff --git a/testsuite/tests/ghci/should_fail/T10549.stderr b/testsuite/tests/ghci/should_fail/T10549.stderr index 50db4fe9f2..14d76b9f49 100644 --- a/testsuite/tests/ghci/should_fail/T10549.stderr +++ b/testsuite/tests/ghci/should_fail/T10549.stderr @@ -1,3 +1,3 @@ when making flags consistent: warning: - Optimization flags conflict with --interactive; optimization flags ignored. + Optimization flags are incompatible with the byte-code interpreter; optimization flags ignored. diff --git a/testsuite/tests/ghci/should_fail/T10549a.stderr b/testsuite/tests/ghci/should_fail/T10549a.stderr index 50db4fe9f2..14d76b9f49 100644 --- a/testsuite/tests/ghci/should_fail/T10549a.stderr +++ b/testsuite/tests/ghci/should_fail/T10549a.stderr @@ -1,3 +1,3 @@ when making flags consistent: warning: - Optimization flags conflict with --interactive; optimization flags ignored. + Optimization flags are incompatible with the byte-code interpreter; optimization flags ignored. diff --git a/testsuite/tests/rts/linker/LinkerUnload.hs b/testsuite/tests/rts/linker/LinkerUnload.hs index ae4bd7562a..c13ad016c2 100644 --- a/testsuite/tests/rts/linker/LinkerUnload.hs +++ b/testsuite/tests/rts/linker/LinkerUnload.hs @@ -17,7 +17,7 @@ loadPackages = do [libdir] <- getArgs runGhc (Just libdir) $ do dflags <- getSessionDynFlags - let dflags' = dflags { backend = NoBackend + let dflags' = dflags { backend = noBackend , ghcLink = LinkInMemory } setSessionDynFlags dflags' hsc_env <- getSession diff --git a/testsuite/tests/safeHaskell/ghci/p14.stderr b/testsuite/tests/safeHaskell/ghci/p14.stderr index 66ac9c0074..74717b1217 100644 --- a/testsuite/tests/safeHaskell/ghci/p14.stderr +++ b/testsuite/tests/safeHaskell/ghci/p14.stderr @@ -1,6 +1,6 @@ when making flags consistent: warning: - Optimization flags conflict with --interactive; optimization flags ignored. + Optimization flags are incompatible with the byte-code interpreter; optimization flags ignored. <interactive>:10:25: error: • No instance for (Num a) arising from a use of ‘f’ diff --git a/testsuite/tests/th/T8333.stderr b/testsuite/tests/th/T8333.stderr index 50db4fe9f2..14d76b9f49 100644 --- a/testsuite/tests/th/T8333.stderr +++ b/testsuite/tests/th/T8333.stderr @@ -1,3 +1,3 @@ when making flags consistent: warning: - Optimization flags conflict with --interactive; optimization flags ignored. + Optimization flags are incompatible with the byte-code interpreter; optimization flags ignored. diff --git a/utils/haddock b/utils/haddock -Subproject 7921211350a572d5365e7feb5fa4cc04666318e +Subproject 852d097c27271dba90e3c5faed4343104eb34ca |