GitLab

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

6d058a69

by Andrea Bedini at 2025-05-21T16:00:51-04:00

Don't fail when ghcversion.h can't be found (#26018)

If ghcversion.h can't be found, don't try to include it. This happens
when there is no rts package in the package db and when -ghcversion-file
argument isn't passed.

Co-authored-by: Syvlain Henry <sylvain@haskus.fr>

4 changed files:

compiler/GHC/Driver/Pipeline/Execute.hs
compiler/GHC/SysTools/Cpp.hs
testsuite/tests/driver/Makefile
testsuite/tests/driver/all.T

Changes:

compiler/GHC/Driver/Pipeline/Execute.hs

@@ -478,7 +478,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do
            -- very weakly typed, being derived from C--.
            ["-fno-strict-aliasing"]
 -  ghcVersionH <- getGhcVersionPathName dflags unit_env
 +  ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env
    withAtomicRename output_fn $ \temp_outputFilename ->
      GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (
@@ -525,7 +525,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do
                         else [])
                   ++ verbFlags
                   ++ cc_opt
 -                 ++ [ "-include", ghcVersionH ]
 +                 ++ ghcVersionH
                   ++ framework_paths
                   ++ include_paths
                   ++ pkg_extra_cc_opts

compiler/GHC/SysTools/Cpp.hs

@@ -7,6 +7,7 @@ module GHC.SysTools.Cpp
    ( doCpp
    , CppOpts(..)
    , getGhcVersionPathName
 +  , getGhcVersionIncludeFlags
    , applyCDefs
    , offsetIncludePaths
+   )
@@ -31,7 +32,6 @@ import GHC.Utils.TmpFs
  import GHC.Utils.Panic
  import Data.Version
 -import Data.List (intercalate)
  import Data.Maybe
  import Control.Monad
@@ -124,10 +124,10 @@ doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do
           [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) []
 +    let include_paths_global = map ("-I" ++)
            (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs
                                                      ++ concatMap includePathsGlobal dep_pkg_extra_inputs)
 -    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
 +    let include_paths_quote = map ("-iquote" ++)
            (includePathsQuote cmdline_include_paths ++
             includePathsQuoteImplicit cmdline_include_paths)
      let include_paths = include_paths_quote ++ include_paths_global
@@ -178,8 +178,7 @@ doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do
      let asserts_def = [ "-D__GLASGOW_HASKELL_ASSERTS_IGNORED__" | gopt Opt_IgnoreAsserts dflags]
      -- Default CPP defines in Haskell source
 -    ghcVersionH <- getGhcVersionPathName dflags unit_env
 -    let hsSourceCppOpts = [ "-include", ghcVersionH ]
 +    ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env
      -- MIN_VERSION macros
      let uids = explicitUnits unit_state
@@ -202,7 +201,7 @@ doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do
      cpp_prog       (   map GHC.SysTools.Option verbFlags
                      ++ map GHC.SysTools.Option include_paths
 -                    ++ map GHC.SysTools.Option hsSourceCppOpts
 +                    ++ map GHC.SysTools.Option ghcVersionH
                      ++ map GHC.SysTools.Option target_defs
                      ++ map GHC.SysTools.Option backend_defs
                      ++ map GHC.SysTools.Option th_defs
@@ -265,28 +264,32 @@ generateMacros prefix name version =
        _         -> error "take3"
      (major1,major2,minor) = take3 $ map show (versionBranch version) ++ repeat "0"
 +getGhcVersionIncludeFlags :: DynFlags -> UnitEnv -> IO [String]
 +getGhcVersionIncludeFlags dflags unit_env =
 +  getGhcVersionPathName dflags unit_env >>= \case
 +    Nothing -> pure []
 +    Just path -> pure [ "-include", path ]
  -- | Find out path to @ghcversion.h@ file
 -getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
 -getGhcVersionPathName dflags unit_env = do
 -  let candidates = case ghcVersionFile dflags of
 -        -- the user has provided an explicit `ghcversion.h` file to use.
 -        Just path -> [path]
 -        -- otherwise, try to find it in the rts' include-dirs.
 -        -- Note: only in the RTS include-dirs! not all preload units less we may
 -        -- use a wrong file. See #25106 where a globally installed
 -        -- /usr/include/ghcversion.h file was used instead of the one provided
 -        -- by the rts.
 -        Nothing -> case lookupUnitId (ue_homeUnitState unit_env) rtsUnitId of
 -          Nothing   -> []
 -          Just info -> (</> "ghcversion.h") <$> collectIncludeDirs [info]
+-
 -  found <- filterM doesFileExist candidates
 -  case found of
 -      []    -> throwGhcExceptionIO (InstallationError
 -                                    ("ghcversion.h missing; tried: "
 -                                      ++ intercalate ", " candidates))
 -      (x:_) -> return x
 +getGhcVersionPathName :: DynFlags -> UnitEnv -> IO (Maybe FilePath)
 +getGhcVersionPathName dflags unit_env = case ghcVersionFile dflags of
 +  -- the user has provided an explicit `ghcversion.h` file to use.
 +  Just path -> doesFileExist path >>= \case
 +    True -> return (Just path)
 +    False -> throwGhcExceptionIO (InstallationError ("ghcversion.h not found in: " ++ path))
 +  -- otherwise, try to find it in the rts' include-dirs.
 +  -- Note: only in the RTS include-dirs! not all preload units less we may
 +  -- use a wrong file. See #25106 where a globally installed
 +  -- /usr/include/ghcversion.h file was used instead of the one provided
 +  -- by the rts.
 +  Nothing -> case lookupUnitId (ue_homeUnitState unit_env) rtsUnitId of
 +    Nothing   -> pure Nothing
 +    Just info -> do
 +      let candidates = (</> "ghcversion.h") <$> collectIncludeDirs [info]
 +      found <- filterM doesFileExist candidates
 +      case found of
 +        [] -> pure Nothing
 +        (x:_) -> pure (Just x)
  applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String]
  applyCDefs NoCDefs _ _ = return []

testsuite/tests/driver/Makefile

@@ -813,3 +813,8 @@ T23339B:
  T25382:
  	"$(TEST_HC)" $(TEST_HC_OPTS) -c T25382.hs
  	"$(TEST_HC)" $(TEST_HC_OPTS) T25382.o -o main
++
 +# Test we can compile C code with an empty package DB
 +T26018:
 +	touch foo.c
 +	"$(TEST_HC)" $(TEST_HC_OPTS) -c foo.c -clear-package-db

testsuite/tests/driver/all.T

@@ -331,3 +331,4 @@ test('T24286', [cxx_src, unless(have_profiling(), skip), extra_files(['T24286.cp
  test('T24839', [unless(arch('x86_64') or arch('aarch64'), skip), extra_files(["t24839_sub.S"])], compile_and_run, ['t24839_sub.S'])
  test('t25150', [extra_files(["t25150"])], multimod_compile, ['Main.hs', '-v0 -working-dir t25150/dir a.c'])
  test('T25382', normal, makefile_test, [])
 +test('T26018', req_c, makefile_test, [])