[Git][ghc/ghc][master] Add GHC.SysTools.Cpp module
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Oct 25 22:09:21 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
a2f53ac8 by Sylvain Henry at 2022-10-25T18:09:05-04:00
Add GHC.SysTools.Cpp module
Move doCpp out of the driver to be able to use it in the upcoming JS backend.
- - - - -
4 changed files:
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- + compiler/GHC/SysTools/Cpp.hs
- compiler/ghc.cabal.in
Changes:
=====================================
compiler/GHC/Driver/Pipeline.hs
=====================================
@@ -73,6 +73,7 @@ import GHC.Driver.Hooks
import GHC.Platform.Ways
import GHC.SysTools
+import GHC.SysTools.Cpp
import GHC.Utils.TmpFs
import GHC.Linker.ExtraObj
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -65,9 +65,8 @@ import GHC.Runtime.Loader
import Data.IORef
import GHC.Types.Name.Env
import GHC.Platform.Ways
-import GHC.Platform.ArchOS
import GHC.Driver.LlvmConfigCache (readLlvmConfigCache)
-import GHC.CmmToLlvm.Config (llvmVersionList, LlvmTarget (..), LlvmConfig (..))
+import GHC.CmmToLlvm.Config (LlvmTarget (..), LlvmConfig (..))
import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub)
import GHC.Settings
import System.IO
@@ -79,6 +78,7 @@ import GHC.Unit.Module.Env
import GHC.Driver.Env.KnotVars
import GHC.Driver.Config.Finder
import GHC.Rename.Names
+import GHC.SysTools.Cpp
import Language.Haskell.Syntax.Module.Name
import GHC.Unit.Home.ModInfo
@@ -121,7 +121,10 @@ runPhase (T_CmmCpp pipe_env hsc_env input_fn) = do
(hsc_tmpfs hsc_env)
(hsc_dflags hsc_env)
(hsc_unit_env hsc_env)
- False{-not raw-}
+ (CppOpts
+ { cppUseCc = True
+ , cppLinePragmas = True
+ })
input_fn output_fn
return output_fn
runPhase (T_Cmm pipe_env hsc_env input_fn) = do
@@ -620,7 +623,10 @@ runCppPhase hsc_env input_fn output_fn = do
(hsc_tmpfs hsc_env)
(hsc_dflags hsc_env)
(hsc_unit_env hsc_env)
- True{-raw-}
+ (CppOpts
+ { cppUseCc = False
+ , cppLinePragmas = True
+ })
input_fn output_fn
return output_fn
@@ -953,142 +959,6 @@ llvmOptions llvm_config dflags =
ArchRISCV64 -> "lp64d"
_ -> ""
-
--- Note [Filepaths and Multiple Home Units]
-offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs
-offsetIncludePaths dflags (IncludeSpecs incs quotes impl) =
- let go = map (augmentByWorkingDirectory dflags)
- in IncludeSpecs (go incs) (go quotes) (go impl)
--- -----------------------------------------------------------------------------
--- Running CPP
-
--- | Run CPP
---
--- UnitEnv is needed to compute MIN_VERSION macros
-doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()
-doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do
- let hscpp_opts = picPOpts dflags
- let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)
- let unit_state = ue_units unit_env
- pkg_include_dirs <- mayThrowUnitErr
- (collectIncludeDirs <$> preloadUnitsInfo unit_env)
- -- MP: This is not quite right, the headers which are supposed to be installed in
- -- the package might not be the same as the provided include paths, but it's a close
- -- enough approximation for things to work. A proper solution would be to have to declare which paths should
- -- be propagated to dependent packages.
- let home_pkg_deps =
- [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]
- dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]
-
- let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
- (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs
- ++ concatMap includePathsGlobal dep_pkg_extra_inputs)
- let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
- (includePathsQuote cmdline_include_paths ++
- includePathsQuoteImplicit cmdline_include_paths)
- let include_paths = include_paths_quote ++ include_paths_global
-
- let verbFlags = getVerbFlags dflags
-
- let cpp_prog args | raw = GHC.SysTools.runCpp logger dflags args
- | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags
- (GHC.SysTools.Option "-E" : args)
-
- let platform = targetPlatform dflags
- targetArch = stringEncodeArch $ platformArch platform
- targetOS = stringEncodeOS $ platformOS platform
- isWindows = platformOS platform == OSMinGW32
- let target_defs =
- [ "-D" ++ HOST_OS ++ "_BUILD_OS",
- "-D" ++ HOST_ARCH ++ "_BUILD_ARCH",
- "-D" ++ targetOS ++ "_HOST_OS",
- "-D" ++ targetArch ++ "_HOST_ARCH" ]
- -- remember, in code we *compile*, the HOST is the same our TARGET,
- -- and BUILD is the same as our HOST.
-
- let io_manager_defs =
- [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++
- [ "-D__IO_MANAGER_MIO__=1" ]
-
- let sse_defs =
- [ "-D__SSE__" | isSseEnabled platform ] ++
- [ "-D__SSE2__" | isSse2Enabled platform ] ++
- [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
-
- let avx_defs =
- [ "-D__AVX__" | isAvxEnabled dflags ] ++
- [ "-D__AVX2__" | isAvx2Enabled dflags ] ++
- [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
- [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
- [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
- [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
-
- backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags
-
- let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
- -- Default CPP defines in Haskell source
- ghcVersionH <- getGhcVersionPathName dflags unit_env
- let hsSourceCppOpts = [ "-include", ghcVersionH ]
-
- -- MIN_VERSION macros
- let uids = explicitUnits unit_state
- pkgs = mapMaybe (lookupUnit unit_state . fst) uids
- mb_macro_include <-
- if not (null pkgs) && gopt Opt_VersionMacros dflags
- then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"
- writeFile macro_stub (generatePackageVersionMacros pkgs)
- -- Include version macros for every *exposed* package.
- -- Without -hide-all-packages and with a package database
- -- size of 1000 packages, it takes cpp an estimated 2
- -- milliseconds to process this file. See #10970
- -- comment 8.
- return [GHC.SysTools.FileOption "-include" macro_stub]
- else return []
-
- cpp_prog ( map GHC.SysTools.Option verbFlags
- ++ map GHC.SysTools.Option include_paths
- ++ map GHC.SysTools.Option hsSourceCppOpts
- ++ map GHC.SysTools.Option target_defs
- ++ map GHC.SysTools.Option backend_defs
- ++ map GHC.SysTools.Option th_defs
- ++ map GHC.SysTools.Option hscpp_opts
- ++ map GHC.SysTools.Option sse_defs
- ++ map GHC.SysTools.Option avx_defs
- ++ map GHC.SysTools.Option io_manager_defs
- ++ mb_macro_include
- -- Set the language mode to assembler-with-cpp when preprocessing. This
- -- alleviates some of the C99 macro rules relating to whitespace and the hash
- -- operator, which we tend to abuse. Clang in particular is not very happy
- -- about this.
- ++ [ GHC.SysTools.Option "-x"
- , GHC.SysTools.Option "assembler-with-cpp"
- , GHC.SysTools.Option input_fn
- -- We hackily use Option instead of FileOption here, so that the file
- -- name is not back-slashed on Windows. cpp is capable of
- -- dealing with / in filenames, so it works fine. Furthermore
- -- if we put in backslashes, cpp outputs #line directives
- -- with *double* backslashes. And that in turn means that
- -- our error messages get double backslashes in them.
- -- In due course we should arrange that the lexer deals
- -- with these \\ escapes properly.
- , GHC.SysTools.Option "-o"
- , GHC.SysTools.FileOption "" output_fn
- ])
-
-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
-
-
-- | What phase to run after one of the backend code generators has run
hscPostBackendPhase :: HscSource -> Backend -> Phase
hscPostBackendPhase HsBootFile _ = StopLn
@@ -1279,22 +1149,6 @@ touchObjectFile logger dflags path = do
createDirectoryIfMissing True $ takeDirectory path
GHC.SysTools.touch logger dflags "Touching object file" path
--- | Find out path to @ghcversion.h@ file
-getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
-getGhcVersionPathName dflags unit_env = do
- candidates <- case ghcVersionFile dflags of
- Just path -> return [path]
- Nothing -> do
- ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])
- return ((</> "ghcversion.h") <$> collectIncludeDirs ps)
-
- found <- filterM doesFileExist candidates
- case found of
- [] -> throwGhcExceptionIO (InstallationError
- ("ghcversion.h missing; tried: "
- ++ intercalate ", " candidates))
- (x:_) -> return x
-
-- Note [-fPIC for assembler]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
-- When compiling .c source file GHC's driver pipeline basically
=====================================
compiler/GHC/SysTools/Cpp.hs
=====================================
@@ -0,0 +1,234 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+
+#include <ghcplatform.h>
+
+module GHC.SysTools.Cpp
+ ( doCpp
+ , CppOpts (..)
+ , getGhcVersionPathName
+ , applyCDefs
+ , offsetIncludePaths
+ )
+where
+
+import GHC.Prelude
+import GHC.Driver.Session
+import GHC.Driver.Backend
+import GHC.CmmToLlvm.Config
+import GHC.Platform
+import GHC.Platform.ArchOS
+
+import GHC.SysTools
+
+import GHC.Unit.Env
+import GHC.Unit.Info
+import GHC.Unit.State
+import GHC.Unit.Types
+
+import GHC.Utils.Logger
+import GHC.Utils.TmpFs
+import GHC.Utils.Panic
+
+import Data.Version
+import Data.List (intercalate)
+import Data.Maybe
+
+import Control.Monad
+
+import System.Directory
+import System.FilePath
+
+data CppOpts = CppOpts
+ { cppUseCc :: !Bool -- ^ Use "cc -E" as preprocessor, otherwise use "cpp"
+ , cppLinePragmas :: !Bool -- ^ Enable generation of LINE pragmas
+ }
+
+-- | Run CPP
+--
+-- UnitEnv is needed to compute MIN_VERSION macros
+doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> CppOpts -> FilePath -> FilePath -> IO ()
+doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do
+ let hscpp_opts = picPOpts dflags
+ let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)
+ let unit_state = ue_units unit_env
+ pkg_include_dirs <- mayThrowUnitErr
+ (collectIncludeDirs <$> preloadUnitsInfo unit_env)
+ -- MP: This is not quite right, the headers which are supposed to be installed in
+ -- the package might not be the same as the provided include paths, but it's a close
+ -- enough approximation for things to work. A proper solution would be to have to declare which paths should
+ -- be propagated to dependent packages.
+ let home_pkg_deps =
+ [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]
+ dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]
+
+ let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
+ (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs
+ ++ concatMap includePathsGlobal dep_pkg_extra_inputs)
+ let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
+ (includePathsQuote cmdline_include_paths ++
+ includePathsQuoteImplicit cmdline_include_paths)
+ let include_paths = include_paths_quote ++ include_paths_global
+
+ let verbFlags = getVerbFlags dflags
+
+ let cpp_prog args
+ | cppUseCc opts = GHC.SysTools.runCc Nothing logger tmpfs dflags
+ (GHC.SysTools.Option "-E" : args)
+ | otherwise = GHC.SysTools.runCpp logger dflags args
+
+ let platform = targetPlatform dflags
+ targetArch = stringEncodeArch $ platformArch platform
+ targetOS = stringEncodeOS $ platformOS platform
+ isWindows = platformOS platform == OSMinGW32
+ let target_defs =
+ [ "-D" ++ HOST_OS ++ "_BUILD_OS",
+ "-D" ++ HOST_ARCH ++ "_BUILD_ARCH",
+ "-D" ++ targetOS ++ "_HOST_OS",
+ "-D" ++ targetArch ++ "_HOST_ARCH" ]
+ -- remember, in code we *compile*, the HOST is the same our TARGET,
+ -- and BUILD is the same as our HOST.
+
+ let io_manager_defs =
+ [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++
+ [ "-D__IO_MANAGER_MIO__=1" ]
+
+ let sse_defs =
+ [ "-D__SSE__" | isSseEnabled platform ] ++
+ [ "-D__SSE2__" | isSse2Enabled platform ] ++
+ [ "-D__SSE4_2__" | isSse4_2Enabled dflags ]
+
+ let avx_defs =
+ [ "-D__AVX__" | isAvxEnabled dflags ] ++
+ [ "-D__AVX2__" | isAvx2Enabled dflags ] ++
+ [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
+ [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
+ [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++
+ [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
+
+ backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags
+
+ let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
+ -- Default CPP defines in Haskell source
+ ghcVersionH <- getGhcVersionPathName dflags unit_env
+ let hsSourceCppOpts = [ "-include", ghcVersionH ]
+
+ -- MIN_VERSION macros
+ let uids = explicitUnits unit_state
+ pkgs = mapMaybe (lookupUnit unit_state . fst) uids
+ mb_macro_include <-
+ if not (null pkgs) && gopt Opt_VersionMacros dflags
+ then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"
+ writeFile macro_stub (generatePackageVersionMacros pkgs)
+ -- Include version macros for every *exposed* package.
+ -- Without -hide-all-packages and with a package database
+ -- size of 1000 packages, it takes cpp an estimated 2
+ -- milliseconds to process this file. See #10970
+ -- comment 8.
+ return [GHC.SysTools.FileOption "-include" macro_stub]
+ else return []
+
+ let line_pragmas
+ | cppLinePragmas opts = [] -- on by default
+ | otherwise = [GHC.SysTools.Option "-P"] -- disable LINE markers
+
+ cpp_prog ( map GHC.SysTools.Option verbFlags
+ ++ map GHC.SysTools.Option include_paths
+ ++ map GHC.SysTools.Option hsSourceCppOpts
+ ++ map GHC.SysTools.Option target_defs
+ ++ map GHC.SysTools.Option backend_defs
+ ++ map GHC.SysTools.Option th_defs
+ ++ map GHC.SysTools.Option hscpp_opts
+ ++ map GHC.SysTools.Option sse_defs
+ ++ map GHC.SysTools.Option avx_defs
+ ++ map GHC.SysTools.Option io_manager_defs
+ ++ mb_macro_include
+ ++ line_pragmas
+ -- Set the language mode to assembler-with-cpp when preprocessing. This
+ -- alleviates some of the C99 macro rules relating to whitespace and the hash
+ -- operator, which we tend to abuse. Clang in particular is not very happy
+ -- about this.
+ ++ [ GHC.SysTools.Option "-x"
+ , GHC.SysTools.Option "assembler-with-cpp"
+ , GHC.SysTools.Option input_fn
+ -- We hackily use Option instead of FileOption here, so that the file
+ -- name is not back-slashed on Windows. cpp is capable of
+ -- dealing with / in filenames, so it works fine. Furthermore
+ -- if we put in backslashes, cpp outputs #line directives
+ -- with *double* backslashes. And that in turn means that
+ -- our error messages get double backslashes in them.
+ -- In due course we should arrange that the lexer deals
+ -- with these \\ escapes properly.
+ , GHC.SysTools.Option "-o"
+ , GHC.SysTools.FileOption "" output_fn
+ ])
+
+-- ---------------------------------------------------------------------------
+-- Macros (cribbed from Cabal)
+
+generatePackageVersionMacros :: [UnitInfo] -> String
+generatePackageVersionMacros pkgs = concat
+ -- Do not add any C-style comments. See #3389.
+ [ generateMacros "" pkgname version
+ | pkg <- pkgs
+ , let version = unitPackageVersion pkg
+ pkgname = map fixchar (unitPackageNameString pkg)
+ ]
+
+fixchar :: Char -> Char
+fixchar '-' = '_'
+fixchar c = c
+
+generateMacros :: String -> String -> Version -> String
+generateMacros prefix name version =
+ concat
+ ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
+ ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
+ ," (major1) < ",major1," || \\\n"
+ ," (major1) == ",major1," && (major2) < ",major2," || \\\n"
+ ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
+ ,"\n\n"
+ ]
+ where
+ take3 = \case
+ (a:b:c:_) -> (a,b,c)
+ _ -> error "take3"
+ (major1,major2,minor) = take3 $ map show (versionBranch version) ++ repeat "0"
+
+
+-- | Find out path to @ghcversion.h@ file
+getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
+getGhcVersionPathName dflags unit_env = do
+ candidates <- case ghcVersionFile dflags of
+ Just path -> return [path]
+ Nothing -> do
+ ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])
+ return ((</> "ghcversion.h") <$> collectIncludeDirs ps)
+
+ found <- filterM doesFileExist candidates
+ case found of
+ [] -> throwGhcExceptionIO (InstallationError
+ ("ghcversion.h missing; tried: "
+ ++ intercalate ", " candidates))
+ (x:_) -> return x
+
+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
+
+
+-- Note [Filepaths and Multiple Home Units]
+offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs
+offsetIncludePaths dflags (IncludeSpecs incs quotes impl) =
+ let go = map (augmentByWorkingDirectory dflags)
+ in IncludeSpecs (go incs) (go quotes) (go impl)
+
=====================================
compiler/ghc.cabal.in
=====================================
@@ -632,6 +632,7 @@ Library
GHC.SysTools
GHC.SysTools.Ar
GHC.SysTools.BaseDir
+ GHC.SysTools.Cpp
GHC.SysTools.Elf
GHC.SysTools.Info
GHC.SysTools.Process
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a2f53ac8d968723417baadfab5be36a020ea6850
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a2f53ac8d968723417baadfab5be36a020ea6850
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221025/f2862dfa/attachment-0001.html>
More information about the ghc-commits
mailing list