Add GHC.SysTools.Cpp module

Move doCpp out of the driver to be able to use it in the upcoming JS backend.

4 files changed, 246 insertions, 156 deletions

diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 246b00393a..d05dd751ce 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/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
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index 915265f8f3..5e34309019 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/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
diff --git a/compiler/GHC/SysTools/Cpp.hs b/compiler/GHC/SysTools/Cpp.hs
new file mode 100644
index 0000000000..1754def83d
--- /dev/null
+++ b/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)
+
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index e502506d89..6f92f021da 100644
--- a/compiler/ghc.cabal.in
+++ b/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