diff options
35 files changed, 326 insertions, 459 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index dd7e1f14f5..93abde05bc 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -148,7 +148,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.FastString -import GHC.Driver.Session import GHC.Platform import GHC.Types.Unique.Set import GHC.Utils.Misc diff --git a/compiler/GHC/Cmm/Switch.hs b/compiler/GHC/Cmm/Switch.hs index b0f22ce1b3..42b01b36e3 100644 --- a/compiler/GHC/Cmm/Switch.hs +++ b/compiler/GHC/Cmm/Switch.hs @@ -8,14 +8,12 @@ module GHC.Cmm.Switch ( switchTargetsToList, eqSwitchTargetWith, SwitchPlan(..), - backendHasNativeSwitch, createSwitchPlan, ) where import GHC.Prelude import GHC.Utils.Outputable -import GHC.Driver.Backend import GHC.Utils.Panic import GHC.Cmm.Dataflow.Label (Label) diff --git a/compiler/GHC/CmmToAsm.hs-boot b/compiler/GHC/CmmToAsm.hs-boot new file mode 100644 index 0000000000..dd6a87a9ad --- /dev/null +++ b/compiler/GHC/CmmToAsm.hs-boot @@ -0,0 +1,16 @@ +module GHC.CmmToAsm +where + +import GHC.Prelude + +import GHC.IO.Handle.Types +import GHC.CmmToAsm.Config +import GHC.Types.Unique.Supply +import GHC.Utils.Logger +import GHC.Unit.Module.Location +import GHC.Data.Stream +import GHC.Cmm + +nativeCodeGen :: forall a . Logger -> NCGConfig -> ModLocation -> Handle -> UniqSupply + -> Stream IO RawCmmGroup a + -> IO a diff --git a/compiler/GHC/CmmToLlvm.hs-boot b/compiler/GHC/CmmToLlvm.hs-boot new file mode 100644 index 0000000000..7a00880137 --- /dev/null +++ b/compiler/GHC/CmmToLlvm.hs-boot @@ -0,0 +1,14 @@ +module GHC.CmmToLlvm +where + +import GHC.Prelude + +import GHC.IO.Handle.Types +import {-# SOURCE #-} GHC.CmmToLlvm.Config (LlvmCgConfig) +import GHC.Utils.Logger +import GHC.Data.Stream +import GHC.Cmm + +llvmCodeGen :: Logger -> LlvmCgConfig -> Handle + -> Stream IO RawCmmGroup a + -> IO a diff --git a/compiler/GHC/CmmToLlvm/Config.hs-boot b/compiler/GHC/CmmToLlvm/Config.hs-boot new file mode 100644 index 0000000000..735d263f46 --- /dev/null +++ b/compiler/GHC/CmmToLlvm/Config.hs-boot @@ -0,0 +1,4 @@ +module GHC.CmmToLlvm.Config +where + +data LlvmCgConfig diff --git a/compiler/GHC/Driver/Backend.hs b/compiler/GHC/Driver/Backend.hs index eaa5a02edd..66390f049d 100644 --- a/compiler/GHC/Driver/Backend.hs +++ b/compiler/GHC/Driver/Backend.hs @@ -21,16 +21,38 @@ where import GHC.Prelude +import Data.Set (Set) +import qualified Data.Set as Set +import System.IO + +import GHC.Cmm +import {-# SOURCE #-} GHC.CmmToAsm ( nativeCodeGen ) +import {-# SOURCE #-} GHC.CmmToLlvm ( llvmCodeGen ) +import GHC.CmmToC ( cmmToC ) +import GHC.CmmToLlvm.LlvmVersion +import GHC.Data.Stream ( Stream, consume ) import GHC.Driver.Backend.Types +import {-# SOURCE #-} GHC.Driver.Config.CmmToAsm (initNCGConfig) +import {-# SOURCE #-} GHC.Driver.Config.CmmToLlvm (initLlvmCgConfig) +import {-# SOURCE #-} GHC.Driver.Config.StgToCmm +import GHC.Driver.Flags import GHC.Driver.Phases - - +import {-# SOURCE #-} GHC.Driver.Pipeline +import {-# SOURCE #-} GHC.Driver.Session +import GHC.Driver.Pipeline.Monad +import GHC.Platform +import {-# SOURCE #-} GHC.SysTools.Tasks +import {-# SOURCE #-} GHC.SysTools.Info +import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) +import GHC.Unit.Module.Location +import GHC.Unit.Types import GHC.Utils.Error +import GHC.Utils.Exception (bracket) +import GHC.Utils.Logger import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Ppr ( Mode(..) ) -import GHC.Driver.Pipeline.Monad -import GHC.Platform platformDefaultBackend :: Platform -> Backend @@ -55,8 +77,6 @@ platformNcgSupported platform = if _ -> False - - prototypeBackend, ncgBackend, llvmBackend, viaCBackend, interpreterBackend, noBackend :: Backend @@ -106,18 +126,17 @@ prototypeBackend = -- | 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. - , backendAssemblerProg = StandardAssemblerProg -- \logger dflags _platform -> runAs logger dflags - , backendAssemblerInfoGetter = StandardAssemblerInfoGetter - -- \logger dflags _platform -> getAssemblerInfo logger dflags + , backendAssemblerProg = \logger dflags _platform -> runAs logger dflags + , backendAssemblerInfoGetter = + \logger dflags _platform -> getAssemblerInfo logger dflags - , backendCDefs = NoCDefs -- \_ _ -> return [] + , backendCDefs = \_ _ -> return [] ----------------- code generation and compiler driver - , backendCodeOutput = missing "CodeOutput" - , backendPostHscPipeline = NoPostHscPipeline - -- \ _ _ _ _ -> return Nothing + , backendCodeOutput = missing "CodeOutput'" + , backendPostHscPipeline = \ _ _ _ _ -> return Nothing , backendNormalSuccessorPhase = missing "NormalSuccessorPhase" } @@ -146,12 +165,30 @@ ncgBackend = , backendSupportsUnsplitProcPoints = True , backendSwappableWithViaC = True - , backendCodeOutput = NcgCodeOutput -- outputAsm - , backendPostHscPipeline = NcgPostHscPipeline -- asPipeline False + , backendCodeOutput = outputAsm + , backendPostHscPipeline = asPipeline False , backendNormalSuccessorPhase = As False } +outputAsm, outputLlvm, outputC + :: Logger + -> DynFlags + -> Module + -> ModLocation + -> FilePath + -> Set UnitId + -> Stream IO RawCmmGroup a + -> IO a + +outputAsm logger dflags this_mod location filenm _deps cmm_stream = do + ncg_uniqs <- mkSplitUniqSupply 'n' + debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm) + let ncg_config = initNCGConfig dflags this_mod + {-# SCC "OutputAsm" #-} doOutput filenm $ + \h -> {-# SCC "NativeCodeGen" #-} + nativeCodeGen logger ncg_config location h ncg_uniqs cmm_stream + -- | LLVM backend. -- @@ -177,31 +214,45 @@ llvmBackend = -- LLVM from version 3.0 onwards doesn't support the OS X system -- assembler, so we use clang as the assembler instead. (#5636) - , backendAssemblerProg = DarwinClangAssemblerProg - {- + , backendAssemblerProg = \logger dflags platform -> if platformOS platform == OSDarwin then runClang logger dflags else runAs logger dflags - -} - , backendAssemblerInfoGetter = DarwinClangAssemblerInfoGetter -{- + , backendAssemblerInfoGetter = \logger dflags platform -> if platformOS platform == OSDarwin then - pure Clang + pure clang else getAssemblerInfo logger dflags --} - , backendCDefs = LlvmCDefs -- llvmCDefs - , backendCodeOutput = LlvmCodeOutput -- outputLlvm - , backendPostHscPipeline = LlvmPostHscPipeline -- llvmPipeline - + , backendCDefs = llvmCDefs + , backendCodeOutput = outputLlvm + , backendPostHscPipeline = llvmPipeline , backendNormalSuccessorPhase = LlvmOpt - } +outputLlvm logger dflags _this_mod _location filenm _deps cmm_stream = do + lcg_config <- initLlvmCgConfig logger dflags + {-# SCC "llvm_output" #-} doOutput filenm $ + \f -> {-# SCC "llvm_CodeGen" #-} + llvmCodeGen logger lcg_config f cmm_stream + +llvmCDefs :: Logger -> DynFlags -> IO [String] +llvmCDefs logger dflags = do + llvmVer <- figureLlvmVersion logger dflags + return $ case fmap llvmVersionList llvmVer of + Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] + Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] + _ -> [] + where + format (major, minor) + | minor >= 100 = error "backendCDefs: Unsupported minor version" + | otherwise = show (100 * major + minor :: Int) -- Contract is Int + + + -- | Via-C backend. -- -- Compiles Cmm code into C code, then relies on a C compiler @@ -225,12 +276,30 @@ viaCBackend = , backendGeneratesHc = True , backendHasNativeSwitch = True - , backendCodeOutput = ViaCCodeOutput -- outputC - , backendPostHscPipeline = ViaCPostHscPipeline -- viaCPipeline HCc + , backendCodeOutput = outputC + , backendPostHscPipeline = viaCPipeline HCc , backendNormalSuccessorPhase = HCc } +outputC logger dflags _module _location filenm unit_deps cmm_stream = + withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do + let pkg_names = map unitIdString (Set.toAscList unit_deps) + doOutput filenm $ \ h -> do + hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") + hPutStr h "#include \"Stg.h\"\n" + let platform = targetPlatform dflags + writeC cmm = do + let doc = cmmToC platform cmm + putDumpFileMaybe logger Opt_D_dump_c_backend + "C backend output" + FormatC + doc + let ctx = initSDocContext dflags (PprCode CStyle) + printSDocLn ctx LeftMode h doc + consume cmm_stream id writeC + + -- | No code generated (implements -fno-code). -- -- Use this to disable code generation. It is particularly @@ -284,3 +353,6 @@ interpreterBackend = -- implements -fno-code , backendNormalSuccessorPhase = StopLn } + +doOutput :: String -> (Handle -> IO a) -> IO a +doOutput filenm = bracket (openFile filenm WriteMode) hClose diff --git a/compiler/GHC/Driver/Backend/Refunctionalize.hs b/compiler/GHC/Driver/Backend/Refunctionalize.hs deleted file mode 100644 index bbebf86e29..0000000000 --- a/compiler/GHC/Driver/Backend/Refunctionalize.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module GHC.Driver.Backend.Refunctionalize - ( applyCodeOutput - , applyAssemblerInfoGetter - , applyAssemblerProg - , applyCDefs - ) -where - -import GHC.Prelude - -import GHC.Driver.Backend - - -import GHC.Utils.Error - -import GHC.CmmToAsm ( nativeCodeGen ) - -import GHC.Cmm ( RawCmmGroup ) -import GHC.CmmToC ( cmmToC ) - -import GHC.Driver.Session -import GHC.Driver.Config.CmmToAsm (initNCGConfig) - -import GHC.Data.Stream ( Stream ) -import GHC.Utils.Outputable -import GHC.Utils.Ppr (Mode(LeftMode)) -import GHC.Utils.Logger -import GHC.Utils.Exception (bracket) - -import GHC.Unit - -import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) - -import System.IO - -import GHC.SysTools.Info -import GHC.SysTools.Tasks -import GHC.CmmToLlvm.LlvmVersion -import GHC.Driver.Config.CmmToLlvm -import GHC.CmmToLlvm -import Data.Set (Set) -import qualified Data.Set as Set -import qualified GHC.Data.Stream as Stream -import GHC.Platform - - -applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String] -applyCDefs NoCDefs _ _ = return [] -applyCDefs LlvmCDefs logger dflags = do - llvmVer <- figureLlvmVersion logger dflags - return $ case fmap llvmVersionList llvmVer of - Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] - Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] - _ -> [] - where - format (major, minor) - | minor >= 100 = error "backendCDefs: Unsupported minor version" - | otherwise = show (100 * major + minor :: Int) -- Contract is Int - - -applyCodeOutput - :: DefunctionalizedCodeOutput - -> Logger - -> DynFlags - -> Module - -> ModLocation - -> FilePath - -> Set UnitId - -> Stream IO RawCmmGroup a - -> IO a -applyCodeOutput NcgCodeOutput = outputAsm -applyCodeOutput ViaCCodeOutput = outputC -applyCodeOutput LlvmCodeOutput = outputLlvm - - -outputAsm, outputLlvm, outputC - :: Logger - -> DynFlags - -> Module - -> ModLocation - -> FilePath - -> Set UnitId - -> Stream IO RawCmmGroup a - -> IO a - -outputLlvm logger dflags _this_mod _location filenm _deps cmm_stream = do - lcg_config <- initLlvmCgConfig logger dflags - {-# SCC "llvm_output" #-} doOutput filenm $ - \f -> {-# SCC "llvm_CodeGen" #-} - llvmCodeGen logger lcg_config f cmm_stream - - -outputAsm logger dflags this_mod location filenm _deps cmm_stream = do - ncg_uniqs <- mkSplitUniqSupply 'n' - debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm) - let ncg_config = initNCGConfig dflags this_mod - {-# SCC "OutputAsm" #-} doOutput filenm $ - \h -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen logger ncg_config location h ncg_uniqs cmm_stream - -outputC logger dflags _module _location filenm unit_deps cmm_stream = - withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do - let pkg_names = map unitIdString (Set.toAscList unit_deps) - doOutput filenm $ \ h -> do - hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") - hPutStr h "#include \"Stg.h\"\n" - let platform = targetPlatform dflags - writeC cmm = do - let doc = cmmToC platform cmm - putDumpFileMaybe logger Opt_D_dump_c_backend - "C backend output" - FormatC - doc - let ctx = initSDocContext dflags (PprCode CStyle) - printSDocLn ctx LeftMode h doc - Stream.consume cmm_stream id writeC - - -doOutput :: String -> (Handle -> IO a) -> IO a -doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action - - - -- 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) | backendWantsClangTools (backend dflags) - , platformOS platform == OSDarwin - = (GHC.SysTools.runClang, pure Clang) - | otherwise - = (GHC.SysTools.runAs, getAssemblerInfoGetter logger dflags) --} - -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 - - - diff --git a/compiler/GHC/Driver/Backend/Types.hs b/compiler/GHC/Driver/Backend/Types.hs index 4a76f023a1..746f64268e 100644 --- a/compiler/GHC/Driver/Backend/Types.hs +++ b/compiler/GHC/Driver/Backend/Types.hs @@ -51,14 +51,6 @@ -- -- In practice, this ideal is not necessarily achieved: -- --- * 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 must then be defined in --- "GHC.Driver.Backend.Refunctionalize" or in "GHC.Driver.Pipeline". --- -- * 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 -- it supports five back ends doesn't mean it will support a sixth @@ -94,142 +86,35 @@ module GHC.Driver.Backend.Types - ( -- * Representation of a back end - Backend(..) - -- * Specialized types of properties - , PrimitiveImplementation(..) - -- * Functions that appear in back ends - -- ** Back-end function for code generation - , DefunctionalizedCodeOutput(..) - -- ** Back-end functions for assembly - , DefunctionalizedPostHscPipeline(..) - , DefunctionalizedAssemblerProg(..) - , DefunctionalizedAssemblerInfoGetter(..) - -- ** Other back-end functions - , DefunctionalizedCDefs(..) + ( Backend(..) ) where import GHC.Prelude +import Data.Set (Set) + +import GHC.Cmm +import GHC.Data.Stream ( Stream ) +import {-# SOURCE #-} GHC.Driver.Config.StgToCmm +import {-# SOURCE #-} GHC.Driver.Env.Types -- HscEnv import GHC.Driver.Phases import GHC.Driver.Pipeline.Monad +import {-# SOURCE #-} GHC.Driver.Pipeline.Phases +import {-# SOURCE #-} GHC.Driver.Session +import GHC.Platform +import GHC.Unit.Module.Location +import GHC.Unit.Types +import GHC.Utils.CliOption import GHC.Utils.Error +import GHC.Utils.Logger --- | 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 - | NcgPrimitives - | GenericPrimitives - deriving Show - - --- | Names a function that runs the assembler, of this type: --- --- > Logger -> DynFlags -> Platform -> [Option] -> IO () - -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 - -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 --- --- There will be one function per back end---or more precisely, one --- function for each back end that writes code to a file. (The --- interpreter does not; 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 has this type: --- --- > TPipelineClass TPhase m --- > => PipeEnv --- > -> HscEnv --- > -> Maybe ModLocation --- > -> FilePath --- > -> m (Maybe FilePath) --- --- Unlike the other named functions, which are defined in --- "GHC.Driver.Backend.Refunctionalize", these functions have to be --- defined in "GHC.Driver.Pipeline", because they depend on functions --- defined there and are depended upon by functions defined there. --- --- There is one function per back end. - -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. -- | The properties of and functions performed by a back end. - data Backend = Backend { -- | An informal description of the back end, for use in @@ -412,66 +297,69 @@ data Backend = ----------------- supporting tooling - -- | This (defunctionalized) function runs the assembler + -- | This 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. -- -- This field is usually defaulted. - , backendAssemblerProg :: DefunctionalizedAssemblerProg - -- ^ Logger -> DynFlags -> Platform -> [Option] -> IO () + , backendAssemblerProg + :: Logger -> DynFlags -> Platform -> [Option] -> IO () - -- | This (defunctionalized) function is used to retrieve + -- | This 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`. -- -- This field is usually defaulted. - , backendAssemblerInfoGetter :: DefunctionalizedAssemblerInfoGetter - -- ^ Logger -> DynFlags -> Platform -> IO CompilerInfo + , backendAssemblerInfoGetter :: + Logger -> DynFlags -> Platform -> IO CompilerInfo -- | 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. + -- This function produces those options, if any. An IO + -- action may be necessary in order to interrogate + -- external tools---for example to find out what version + -- of LLVM is isntalled. + -- -- -- This field is usually defaulted. - , backendCDefs :: DefunctionalizedCDefs - -- ^ Logger -> DynFlags -> IO [String] + + , backendCDefs :: Logger -> DynFlags -> IO [String] ----------------- code generation and compiler driver - -- | 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 :: DefunctionalizedCodeOutput - - - -- | 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 :: DefunctionalizedPostHscPipeline + -- | This function generates code and writes it to a file. + -- Not every back end will have one; the function is clled + -- only if the back end claims to write code to a file. + + , backendCodeOutput + :: forall a . + Logger + -> DynFlags + -> Module + -> ModLocation + -> FilePath -- ^ Where to write output + -> Set UnitId -- ^ dependencies + -> Stream IO RawCmmGroup a -- results from `StgToCmm` + -> IO a + + -- | This function tells the compiler driver what else has + -- to be run after code output. This might include running + -- a C compiler, running LLVM, running an assembler, or + -- various similar activities. + + , backendPostHscPipeline + :: forall m . + TPipelineClass TPhase m + => PipeEnv + -> HscEnv + -> Maybe ModLocation + -> FilePath + -> m (Maybe FilePath) -- | Somewhere in the compiler driver, when compiling -- Haskell source (as opposed to a boot file or a sig @@ -483,66 +371,8 @@ data Backend = } - -- | 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 - - ----------------------------------------------------------------- --- --- 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 --- --- To apply the named function, one uses module --- "Driver.Backend.Refunctionalize", which exports this function: --- --- applyCodeOutput --- :: DefunctionalizedCodeOutput --- -> Logger --- -> DynFlags --- -> Module --- -> ModLocation --- -> FilePath --- -> Set UnitId --- -> Stream IO RawCmmGroup a --- -> IO a --- --- 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/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 8db6eed3eb..e9e7fd49b2 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -20,7 +20,7 @@ module GHC.Driver.Backpack (doBackpack) where import GHC.Prelude -import GHC.Driver.Backend +import GHC.Driver.Backend.Types -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax import GHC.Driver.Config.Finder (initFinderOpts) diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 68571451bc..4073bb6a7a 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -25,8 +25,7 @@ import GHC.Cmm.CLabel import GHC.Driver.Session import GHC.Driver.Config.Finder (initFinderOpts) import GHC.Driver.Ppr -import GHC.Driver.Backend -import GHC.Driver.Backend.Refunctionalize +import GHC.Driver.Backend.Types import qualified GHC.Data.ShortText as ST import GHC.Data.Stream ( Stream ) @@ -99,7 +98,7 @@ codeOutput logger tmpfs dflags unit_state this_mod filenm location genForeignStu ; return cmm } - ; a <- applyCodeOutput (backendCodeOutput $ backend dflags) + ; a <- (backendCodeOutput $ backend dflags) logger dflags this_mod location filenm pkg_deps linted_cmm_stream ; let stubs = genForeignStubs a ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs @@ -277,5 +276,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 5e7ebf72dd..85a70246ef 100644 --- a/compiler/GHC/Driver/Config/Cmm.hs +++ b/compiler/GHC/Driver/Config/Cmm.hs @@ -5,7 +5,7 @@ module GHC.Driver.Config.Cmm import GHC.Cmm.Config import GHC.Driver.Session -import GHC.Driver.Backend +import GHC.Driver.Backend.Types import GHC.Platform diff --git a/compiler/GHC/Driver/Config/CmmToAsm.hs-boot b/compiler/GHC/Driver/Config/CmmToAsm.hs-boot new file mode 100644 index 0000000000..869f1b716d --- /dev/null +++ b/compiler/GHC/Driver/Config/CmmToAsm.hs-boot @@ -0,0 +1,8 @@ +module GHC.Driver.Config.CmmToAsm +where + +import GHC.CmmToAsm.Config +import GHC.Unit.Types +import {-# SOURCE #-} GHC.Driver.Session + +initNCGConfig :: DynFlags -> Module -> NCGConfig diff --git a/compiler/GHC/Driver/Config/CmmToLlvm.hs-boot b/compiler/GHC/Driver/Config/CmmToLlvm.hs-boot new file mode 100644 index 0000000000..e697f43134 --- /dev/null +++ b/compiler/GHC/Driver/Config/CmmToLlvm.hs-boot @@ -0,0 +1,10 @@ +module GHC.Driver.Config.CmmToLlvm +where + +import GHC.Prelude ( IO ) + +import {-# SOURCE #-} GHC.CmmToLlvm.Config ( LlvmCgConfig ) +import GHC.Utils.Logger +import {-# SOURCE #-} GHC.Driver.Session ( DynFlags ) + +initLlvmCgConfig :: Logger -> DynFlags -> IO LlvmCgConfig diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs index 1ac590cef0..d82187e036 100644 --- a/compiler/GHC/Driver/Config/StgToCmm.hs +++ b/compiler/GHC/Driver/Config/StgToCmm.hs @@ -1,10 +1,11 @@ module GHC.Driver.Config.StgToCmm ( initStgToCmmConfig + , PrimitiveImplementation(..) ) where import GHC.StgToCmm.Config -import GHC.Driver.Backend +import GHC.Driver.Backend.Types import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile @@ -80,3 +81,24 @@ initStgToCmmConfig dflags mod = StgToCmmConfig binBlobThreshold dflags else 0 -- suppress them entirely + + + +-- | 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.Driver.Config.StgToCmm". (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 + | NcgPrimitives + | GenericPrimitives + deriving Show diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs-boot b/compiler/GHC/Driver/Config/StgToCmm.hs-boot new file mode 100644 index 0000000000..8344756b2e --- /dev/null +++ b/compiler/GHC/Driver/Config/StgToCmm.hs-boot @@ -0,0 +1,7 @@ +module GHC.Driver.Config.StgToCmm +where + +data PrimitiveImplementation + = LlvmPrimitives + | NcgPrimitives + | GenericPrimitives diff --git a/compiler/GHC/Driver/Env/Types.hs-boot b/compiler/GHC/Driver/Env/Types.hs-boot new file mode 100644 index 0000000000..86bd4f6a22 --- /dev/null +++ b/compiler/GHC/Driver/Env/Types.hs-boot @@ -0,0 +1,4 @@ +module GHC.Driver.Env.Types +where + +data HscEnv diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 6bd491e0bb..25c71451e8 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -99,7 +99,7 @@ import GHC.Prelude import GHC.Driver.Plugins import GHC.Driver.Session -import GHC.Driver.Backend +import GHC.Driver.Backend.Types import GHC.Driver.Env import GHC.Driver.Errors import GHC.Driver.Errors.Types diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 68e5191d49..0a3c7b3dc8 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -919,14 +919,4 @@ hscPostBackendPipeline :: TPipelineClass TPhase m => PipeEnv -> HscEnv -> HscSou hscPostBackendPipeline _ _ HsBootFile _ _ _ = return Nothing hscPostBackendPipeline _ _ HsigFile _ _ _ = return Nothing hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn = - 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 = asPipeline False -applyPostHscPipeline ViaCPostHscPipeline = viaCPipeline HCc -applyPostHscPipeline LlvmPostHscPipeline = llvmPipeline -applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing + (backendPostHscPipeline bcknd) pipe_env hsc_env ml input_fn diff --git a/compiler/GHC/Driver/Pipeline.hs-boot b/compiler/GHC/Driver/Pipeline.hs-boot index 3467ff4ced..0aedc9b00f 100644 --- a/compiler/GHC/Driver/Pipeline.hs-boot +++ b/compiler/GHC/Driver/Pipeline.hs-boot @@ -1,13 +1,25 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} module GHC.Driver.Pipeline where -import GHC.Driver.Env.Types ( HscEnv ) +import {-# SOURCE #-} GHC.Driver.Pipeline.Phases ( TPhase ) +import GHC.Driver.Pipeline.Monad ( TPipelineClass, PipeEnv ) +import {-# SOURCE #-} GHC.Driver.Env.Types ( HscEnv ) import GHC.ForeignSrcLang ( ForeignSrcLang ) -import GHC.Prelude (FilePath, IO) -import GHC.Unit.Module.Location (ModLocation) -import GHC.Unit.Module.Name (ModuleName) -import GHC.Driver.Session (DynFlags) +import GHC.Prelude (Maybe, Bool, FilePath, IO) +import GHC.Unit.Module.Location ( ModLocation ) +import GHC.Unit.Module.Name ( ModuleName ) +import GHC.Driver.Phases (Phase) +import {-# SOURCE #-} GHC.Driver.Session ( DynFlags ) -- These are used in GHC.Driver.Pipeline.Execute, but defined in terms of runPipeline compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO () + +asPipeline :: TPipelineClass TPhase m + => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) +llvmPipeline :: TPipelineClass TPhase m + => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) +viaCPipeline :: TPipelineClass TPhase m + => Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs index 8a74d8e18d..d4d7821b81 100644 --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -28,8 +28,7 @@ import GHC.Types.SourceFile import GHC.Unit.Module.Status import GHC.Unit.Module.ModIface import GHC.Linker.Types -import GHC.Driver.Backend -import GHC.Driver.Backend.Refunctionalize +import GHC.Driver.Backend.Types import GHC.Driver.Session import GHC.Driver.CmdLine import GHC.Unit.Module.ModSummary @@ -285,8 +284,8 @@ 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) = - ( applyAssemblerProg $ backendAssemblerProg (backend dflags) - , applyAssemblerInfoGetter $ backendAssemblerInfoGetter (backend dflags) + ( backendAssemblerProg (backend dflags) + , backendAssemblerInfoGetter (backend dflags) ) asmInfo <- get_asm_info logger dflags platform @@ -989,7 +988,7 @@ doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] - backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags + backend_defs <- (backendCDefs $ backend dflags) logger dflags let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] -- Default CPP defines in Haskell source diff --git a/compiler/GHC/Driver/Pipeline/Phases.hs-boot b/compiler/GHC/Driver/Pipeline/Phases.hs-boot new file mode 100644 index 0000000000..4a33170816 --- /dev/null +++ b/compiler/GHC/Driver/Pipeline/Phases.hs-boot @@ -0,0 +1,9 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RoleAnnotations #-} + +module GHC.Driver.Pipeline.Phases +where + +type role TPhase nominal +data TPhase res + diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index ae352b8e83..3e43a86c6f 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -202,7 +202,7 @@ module GHC.Driver.Session ( -- * Linker/compiler information LinkerInfo(..), - CompilerInfo(..), + CompilerInfo(..), clang, useXLinkerRPath, -- * Include specifications @@ -4865,6 +4865,10 @@ data CompilerInfo | UnknownCC deriving Eq +clang :: CompilerInfo -- used in .hs-boot to make it resilient to + -- changes in CompilerInfo +clang = Clang + -- | Should we use `-XLinker -rpath` when linking or not? -- See Note [-fno-use-rpaths] diff --git a/compiler/GHC/Driver/Session.hs-boot b/compiler/GHC/Driver/Session.hs-boot new file mode 100644 index 0000000000..bc6b4bd001 --- /dev/null +++ b/compiler/GHC/Driver/Session.hs-boot @@ -0,0 +1,13 @@ +module GHC.Driver.Session +where + +import GHC.Platform ( Platform ) +import GHC.Utils.Outputable ( PprStyle, SDocContext ) + +data DynFlags +data CompilerInfo +clang :: CompilerInfo +targetPlatform :: DynFlags -> Platform + + +initSDocContext :: DynFlags -> PprStyle -> SDocContext diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index db27bcbd02..819cd80577 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -21,7 +21,7 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Driver.Config import GHC.Driver.Env -import GHC.Driver.Backend +import GHC.Driver.Backend.Types import GHC.Driver.Plugins import GHC.Hs diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index f9f07ad37e..60cf24c8f6 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -18,7 +18,9 @@ module GHC.HsToCore.Coverage import GHC.Prelude as Prelude import GHC.Driver.Session -import GHC.Driver.Backend +import GHC.Driver.Backend.Types +import GHC.Driver.Ppr +import GHC.Driver.Env import qualified GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 6cfc02bf09..ff43533317 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -50,7 +50,7 @@ import GHC.Core.Ppr import GHC.Core.Unify( RoughMatchTc(..) ) import GHC.Driver.Env -import GHC.Driver.Backend +import GHC.Driver.Backend.Types import GHC.Driver.Session import GHC.Driver.Plugins diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 09506bf7e1..07f8e98a8c 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -14,7 +14,7 @@ where import GHC.Prelude -import GHC.Driver.Backend +import GHC.Driver.Backend.Types import GHC.Driver.Config.Finder import GHC.Driver.Env import GHC.Driver.Session diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index 6b5e796a34..c682e53e58 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -17,7 +17,7 @@ module GHC.Iface.Tidy ( import GHC.Prelude import GHC.Driver.Session -import GHC.Driver.Backend +import GHC.Driver.Backend.Types import GHC.Driver.Ppr import GHC.Driver.Env diff --git a/compiler/GHC/Runtime/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs index 3e6f6ed405..028010e65e 100644 --- a/compiler/GHC/Runtime/Heap/Layout.hs +++ b/compiler/GHC/Runtime/Heap/Layout.hs @@ -48,7 +48,7 @@ module GHC.Runtime.Heap.Layout ( import GHC.Prelude import GHC.Types.Basic( ConTagZ ) -import GHC.Driver.Session +--import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile import GHC.StgToCmm.Types diff --git a/compiler/GHC/SysTools/Info.hs-boot b/compiler/GHC/SysTools/Info.hs-boot new file mode 100644 index 0000000000..25bb1d659a --- /dev/null +++ b/compiler/GHC/SysTools/Info.hs-boot @@ -0,0 +1,8 @@ +module GHC.SysTools.Info where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Driver.Session +import GHC.Utils.Logger + +getAssemblerInfo :: Logger -> DynFlags -> IO CompilerInfo diff --git a/compiler/GHC/SysTools/Tasks.hs-boot b/compiler/GHC/SysTools/Tasks.hs-boot new file mode 100644 index 0000000000..3854558cbf --- /dev/null +++ b/compiler/GHC/SysTools/Tasks.hs-boot @@ -0,0 +1,11 @@ +module GHC.SysTools.Tasks where + +import GHC.Prelude + +import {-# SOURCE #-} GHC.Driver.Session +import GHC.Utils.Logger +import GHC.Utils.CliOption +import GHC.CmmToLlvm.LlvmVersion + +runAs, runClang :: Logger -> DynFlags -> [Option] -> IO () +figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion) diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index 8e297d7f87..53c7d253d4 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -62,7 +62,7 @@ import GHC.Core.TyCon.RecWalk import GHC.Tc.Utils.TcType import GHC.Builtin.Names import GHC.Driver.Session -import GHC.Driver.Backend +import GHC.Driver.Backend.Types import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Platform diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 44b2a6a102..0684d11c74 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -27,7 +27,7 @@ module GHC.Tc.Gen.Sig( import GHC.Prelude import GHC.Driver.Session -import GHC.Driver.Backend +import GHC.Driver.Backend.Types import GHC.Hs diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs index 59cef48886..f1b37c2d13 100644 --- a/compiler/GHC/Unit/Module/Graph.hs +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -49,7 +49,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Maybe import GHC.Data.Graph.Directed -import GHC.Driver.Backend +import GHC.Driver.Backend.Types import GHC.Driver.Ppr import GHC.Driver.Session @@ -365,4 +365,3 @@ msKey :: ModSummary -> ModNodeKeyWithUid msKey ms = ModNodeKeyWithUid (ms_mnwib ms) (ms_unitid ms) type ModNodeKey = ModuleNameWithIsBoot - diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 1af32d36de..09de5ded54 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -368,7 +368,6 @@ Library GHC.Data.UnionFind GHC.Driver.Backend GHC.Driver.Backend.Types - GHC.Driver.Backend.Refunctionalize GHC.Driver.Backend.Legacy GHC.Driver.Backpack GHC.Driver.Backpack.Syntax |