diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index 242f4154cd40bedb2cb0fa0c571b9eb6baa65c7f..02c7d66c7e111fac0f2105de048c18966eb1fabf 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -408,7 +408,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
let unit_env = hsc_unit_env hsc_env
- let home_unit = hsc_home_unit hsc_env
+ let home_unit = hsc_home_unit_maybe hsc_env
let tmpfs = hsc_tmpfs hsc_env
let platform = ue_platform unit_env
let hcc = cc_phase `eqPhase` HCc
@@ -507,10 +507,12 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do
-- These symbols are imported into the stub.c file via RtsAPI.h, and the
-- way we do the import depends on whether we're currently compiling
-- the base package or not.
- ++ (if platformOS platform == OSMinGW32 &&
- isHomeUnitId home_unit ghcInternalUnitId
- then [ "-DCOMPILING_GHC_INTERNAL_PACKAGE" ]
- else [])
+ ++ (case home_unit of
+ Just hu
+ | isHomeUnitId hu ghcInternalUnitId
+ , platformOS platform == OSMinGW32
+ -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"]
+ _ -> [])
-- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)
diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs
index 327acb671c90c98a3a52428f481bde2a52e6fe14..28934ee6025aadd61068920c89ef487d98d81c06 100644
--- a/compiler/GHC/Settings/IO.hs
+++ b/compiler/GHC/Settings/IO.hs
@@ -21,13 +21,14 @@ import GHC.Settings
import GHC.SysTools.BaseDir
import GHC.Unit.Types
-import Data.Char
import Control.Monad.Trans.Except
import Control.Monad.IO.Class
+import Data.Char
import qualified Data.Map as Map
import System.FilePath
import System.Directory
+
data SettingsError
= SettingsError_MissingData String
| SettingsError_BadData String
@@ -71,44 +72,51 @@ initSettings top_dir = do
mtool_dir <- liftIO $ findToolDir useInplaceMinGW top_dir
-- see Note [tooldir: How GHC finds mingw on Windows]
+ -- Escape 'top_dir' and 'mtool_dir', to make sure we don't accidentally
+ -- introduce unescaped spaces. See #24265 and #25204.
+ let escaped_top_dir = escapeArg top_dir
+ escaped_mtool_dir = fmap escapeArg mtool_dir
+
+ getSetting_raw key = either pgmError pure $
+ getRawSetting settingsFile mySettings key
+ getSetting_topDir top key = either pgmError pure $
+ getRawFilePathSetting top settingsFile mySettings key
+ getSetting_toolDir top tool key =
+ expandToolDir useInplaceMinGW tool <$> getSetting_topDir top key
+
+ getSetting :: String -> ExceptT SettingsError m String
+ getSetting key = getSetting_topDir top_dir key
+ getToolSetting :: String -> ExceptT SettingsError m String
+ getToolSetting key = getSetting_toolDir top_dir mtool_dir key
+ getFlagsSetting :: String -> ExceptT SettingsError m [String]
+ getFlagsSetting key = unescapeArgs <$> getSetting_toolDir escaped_top_dir escaped_mtool_dir key
+ -- Make sure to unescape, as we have escaped top_dir and tool_dir.
+
-- See Note [Settings file] for a little more about this file. We're
-- just partially applying those functions and throwing 'Left's; they're
-- written in a very portable style to keep ghc-boot light.
- let getSetting key = either pgmError pure $
- -- Escape the 'top_dir', to make sure we don't accidentally introduce an
- -- unescaped space
- getRawFilePathSetting (escapeArg top_dir) settingsFile mySettings key
- getToolSetting :: String -> ExceptT SettingsError m String
- -- Escape the 'mtool_dir', to make sure we don't accidentally introduce
- -- an unescaped space
- getToolSetting key = expandToolDir useInplaceMinGW (fmap escapeArg mtool_dir) <$> getSetting key
- targetPlatformString <- getSetting "target platform string"
+ targetPlatformString <- getSetting_raw "target platform string"
cc_prog <- getToolSetting "C compiler command"
cxx_prog <- getToolSetting "C++ compiler command"
- cc_args_str <- getToolSetting "C compiler flags"
- cxx_args_str <- getToolSetting "C++ compiler flags"
+ cc_args0 <- getFlagsSetting "C compiler flags"
+ cxx_args <- getFlagsSetting "C++ compiler flags"
gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"
cmmCppSupportsG0 <- getBooleanSetting "C-- CPP supports -g0"
cpp_prog <- getToolSetting "CPP command"
- cpp_args_str <- getToolSetting "CPP flags"
+ cpp_args <- map Option <$> getFlagsSetting "CPP flags"
hs_cpp_prog <- getToolSetting "Haskell CPP command"
- hs_cpp_args_str <- getToolSetting "Haskell CPP flags"
+ hs_cpp_args <- map Option <$> getFlagsSetting "Haskell CPP flags"
js_cpp_prog <- getToolSetting "JavaScript CPP command"
- js_cpp_args_str <- getToolSetting "JavaScript CPP flags"
+ js_cpp_args <- map Option <$> getFlagsSetting "JavaScript CPP flags"
cmmCpp_prog <- getToolSetting "C-- CPP command"
- cmmCpp_args_str <- getToolSetting "C-- CPP flags"
+ cmmCpp_args <- map Option <$> getFlagsSetting "C-- CPP flags"
platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings
let unreg_cc_args = if platformUnregisterised platform
then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
else []
- cpp_args = map Option (unescapeArgs cpp_args_str)
- hs_cpp_args = map Option (unescapeArgs hs_cpp_args_str)
- js_cpp_args = map Option (unescapeArgs js_cpp_args_str)
- cmmCpp_args = map Option (unescapeArgs cmmCpp_args_str)
- cc_args = unescapeArgs cc_args_str ++ unreg_cc_args
- cxx_args = unescapeArgs cxx_args_str
+ cc_args = cc_args0 ++ unreg_cc_args
-- The extra flags we need to pass gcc when we invoke it to compile .hc code.
--
@@ -150,25 +158,25 @@ initSettings top_dir = do
-- Config.hs one day.
- -- Other things being equal, as and ld are simply gcc
- cc_link_args_str <- getToolSetting "C compiler link flags"
+ -- Other things being equal, 'as' and 'ld' are simply 'gcc'
+ cc_link_args <- getFlagsSetting "C compiler link flags"
let as_prog = cc_prog
as_args = map Option cc_args
ld_prog = cc_prog
- ld_args = map Option (cc_args ++ unescapeArgs cc_link_args_str)
+ ld_args = map Option (cc_args ++ cc_link_args)
ld_r_prog <- getToolSetting "Merge objects command"
- ld_r_args <- getToolSetting "Merge objects flags"
+ ld_r_args <- getFlagsSetting "Merge objects flags"
let ld_r
| null ld_r_prog = Nothing
- | otherwise = Just (ld_r_prog, map Option $ unescapeArgs ld_r_args)
+ | otherwise = Just (ld_r_prog, map Option ld_r_args)
- llvmTarget <- getSetting "LLVM target"
+ llvmTarget <- getSetting_raw "LLVM target"
-- We just assume on command line
- lc_prog <- getSetting "LLVM llc command"
- lo_prog <- getSetting "LLVM opt command"
- las_prog <- getSetting "LLVM llvm-as command"
- las_args <- map Option . unescapeArgs <$> getSetting "LLVM llvm-as flags"
+ lc_prog <- getToolSetting "LLVM llc command"
+ lo_prog <- getToolSetting "LLVM opt command"
+ las_prog <- getToolSetting "LLVM llvm-as command"
+ las_args <- map Option <$> getFlagsSetting "LLVM llvm-as flags"
let iserv_prog = libexec "ghc-iserv"
@@ -176,7 +184,7 @@ initSettings top_dir = do
ghcWithInterpreter <- getBooleanSetting "Use interpreter"
useLibFFI <- getBooleanSetting "Use LibFFI"
- baseUnitId <- getSetting "base unit-id"
+ baseUnitId <- getSetting_raw "base unit-id"
return $ Settings
{ sGhcNameVersion = GhcNameVersion
diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs
index 37597da7add265410a93d777db0e5e6977212bff..cebd46aeb02c72f55ce0d06fb29851633bcc5f5c 100644
--- a/compiler/GHC/SysTools/Process.hs
+++ b/compiler/GHC/SysTools/Process.hs
@@ -215,7 +215,9 @@ handleProc pgm phase_name proc = do
then does_not_exist
else throwGhcExceptionIO (ProgramError $ show err)
- does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
+ does_not_exist =
+ throwGhcExceptionIO $
+ InstallationError (phase_name ++ ": could not execute: " ++ pgm)
withPipe :: ((Handle, Handle) -> IO a) -> IO a
withPipe = bracket createPipe $ \ (readEnd, writeEnd) -> do
diff --git a/testsuite/tests/ghc-api/settings-escape/T11938.hs b/testsuite/tests/ghc-api/settings-escape/T24265.hs
similarity index 84%
rename from testsuite/tests/ghc-api/settings-escape/T11938.hs
rename to testsuite/tests/ghc-api/settings-escape/T24265.hs
index ac7bff1dc114412bc57b88e0274de50839195621..593f3e4fb5edd97a3fa29323ba9a8b10eb0bba93 100644
--- a/testsuite/tests/ghc-api/settings-escape/T11938.hs
+++ b/testsuite/tests/ghc-api/settings-escape/T24265.hs
@@ -1,3 +1,4 @@
+module Main where
import GHC
import GHC.ResponseFile (unescapeArgs)
@@ -6,13 +7,11 @@ import GHC.Settings.IO
import GHC.Driver.DynFlags
import GHC.Driver.Session
import GHC.Driver.Env
-import GHC.Utils.CliOption (Option, showOpt)
import Control.Monad.Trans.Except (runExceptT)
import qualified Data.Set as Set
-import Data.Maybe (fromJust)
import Data.List (intercalate)
-import System.Directory (makeAbsolute, createDirectory)
+import System.Directory
import System.Environment
import System.IO (hPutStrLn, stderr)
import System.Exit (exitWith, ExitCode(ExitFailure))
@@ -29,13 +28,13 @@ import System.Exit (exitWith, ExitCode(ExitFailure))
-- escaped the spaces appropriately.
main :: IO ()
main = do
- libdir:args <- getArgs
+ libdir:_args <- getArgs
(rawSettingOpts, originalSettings) <- runGhc (Just libdir) $ do
dflags <- hsc_dflags <$> getSession
pure (rawSettings dflags, settings dflags)
- topDir <- makeAbsolute "./ghc-install-folder/lib"
+ top_dir <- makeAbsolute "./ghc-install-folder/lib with spaces"
let argsWithSpaces = "\"-some option\" -some\\ other"
numberOfExtraArgs = length $ unescapeArgs argsWithSpaces
@@ -58,10 +57,10 @@ main = do
else (name, args)) rawSettingOpts
-- write out the modified settings. We try to keep it legible
- writeFile (topDir ++ "/settings") $
+ writeFile (top_dir ++ "/settings") $
"[" ++ (intercalate "\n," (map show rawSettingOptsWithExtraArgs)) ++ "]"
- settingsm <- runExceptT $ initSettings topDir
+ settingsm <- runExceptT $ initSettings top_dir
case settingsm of
Left (SettingsError_MissingData msg) -> do
@@ -71,11 +70,11 @@ main = do
Left (SettingsError_BadData msg) -> do
hPutStrLn stderr msg
exitWith $ ExitFailure 1
- Right settings -> do
+ Right ghc_settings -> do
let
recordSetting :: String -> (Settings -> [String]) -> IO ()
recordSetting label selector = do
- let opts = selector settings
+ let opts = selector ghc_settings
origOpts = selector originalSettings
-- At least one of the options must contain a space
containsSpaces = any (' ' `elem`) opts
@@ -86,7 +85,7 @@ main = do
recordSettingM :: String -> (Settings -> Maybe [a]) -> IO ()
recordSettingM label selector = do
- let optsM = selector settings
+ let optsM = selector ghc_settings
origOptsM = selector originalSettings
hPutStrLn stderr
$ "=== '" <> label <> "' contains expected entries: "
@@ -99,15 +98,14 @@ main = do
recordFpSetting :: String -> (Settings -> String) -> IO ()
recordFpSetting label selector = do
- let fp = selector settings
- containsOnlyEscapedSpaces ('\\':' ':xs) = containsOnlyEscapedSpaces xs
- containsOnlyEscapedSpaces (' ':_) = False
- containsOnlyEscapedSpaces [] = True
- containsOnlyEscapedSpaces (_:xs) = containsOnlyEscapedSpaces xs
+ let fp = selector ghc_settings
+ containsEscapedSpaces ('\\':' ':_) = True
+ containsEscapedSpaces (' ':xs) = containsEscapedSpaces xs
+ containsEscapedSpaces [] = False
+ containsEscapedSpaces (_:xs) = containsEscapedSpaces xs
- -- Filepath may only contain escaped spaces
- containsSpaces = containsOnlyEscapedSpaces fp
- hPutStrLn stderr $ "=== FilePath '" <> label <> "' contains only escaped spaces: " ++ show containsSpaces
+ -- Filepath should not contain escaped spaces
+ hPutStrLn stderr $ "=== FilePath '" <> label <> "' contains escaped spaces: " ++ show (containsEscapedSpaces fp)
-- Assertions
-- Assumption: this test case is executed in a directory with a space.
@@ -139,6 +137,6 @@ main = do
-- GHC should not split these by word.
-- If 'Nothing', ignore this test, otherwise the same assertion holds as before.
recordSettingM "Merge objects flags" (fmap (map showOpt . snd) . toolSettings_pgm_lm . sToolSettings)
- -- Setting 'unlit command' contains '$topdir' reference.
- -- Resolving those while containing spaces, should be escaped correctly.
- recordFpSetting "unlit command" (toolSettings_pgm_L . sToolSettings)
+ -- Setting 'C compiler command' contains '$topdir' reference.
+ -- Spaces in the final filepath should not be escaped.
+ recordFpSetting "C compiler" (toolSettings_pgm_c . sToolSettings)
diff --git a/testsuite/tests/ghc-api/settings-escape/T11938.stderr b/testsuite/tests/ghc-api/settings-escape/T24265.stderr
similarity index 90%
rename from testsuite/tests/ghc-api/settings-escape/T11938.stderr
rename to testsuite/tests/ghc-api/settings-escape/T24265.stderr
index 0b454df2c02f7342b978999f1f32050984ab9f06..55b2663dea9743111207f7c663f43bb5e5c48d5b 100644
--- a/testsuite/tests/ghc-api/settings-escape/T11938.stderr
+++ b/testsuite/tests/ghc-api/settings-escape/T24265.stderr
@@ -13,4 +13,4 @@
=== 'CPP flags' contains 2 new entries: True
Contains spaces: True
=== 'Merge objects flags' contains expected entries: True
-=== FilePath 'unlit command' contains only escaped spaces: True
+=== FilePath 'C compiler' contains escaped spaces: False
diff --git a/testsuite/tests/ghc-api/settings-escape/T25204.hs b/testsuite/tests/ghc-api/settings-escape/T25204.hs
new file mode 100644
index 0000000000000000000000000000000000000000..c7b105936d475f9ff45bdceaf6893d7cb42cf3ac
--- /dev/null
+++ b/testsuite/tests/ghc-api/settings-escape/T25204.hs
@@ -0,0 +1,79 @@
+module Main where
+
+import GHC
+import GHC.Settings
+import GHC.Driver.Env
+import GHC.Driver.Pipeline
+import GHC.Driver.Phases
+
+import Control.Monad
+import Control.Monad.IO.Class
+import System.Directory
+import System.Environment
+import System.FilePath ((</>))
+import System.Info (os)
+
+main :: IO ()
+main = do
+ libdir:_args <- getArgs
+
+ top_dir <- makeAbsolute "./ghc-install-folder/lib with spaces"
+
+ runGhc (Just libdir) $ do
+
+ dflags <- hsc_dflags <$> getSession
+
+ -- Try compiling a C file with a C compiler that contains a space.
+
+ -- Set the C compiler to something which is known to have spaces in it,
+ -- and check that compilation proceeds as expected.
+ let
+ tool_settings = toolSettings dflags
+ cc = toolSettings_pgm_c tool_settings
+
+ -- Create a directory with spaces for our shim compiler
+ let shimCcDir = top_dir </> "shim cc dir"
+ liftIO $ createDirectory shimCcDir
+
+ -- Create a shim script that calls the original C compiler based on OS
+ let (shimCcPath, shimCcContent) = case os of
+ "mingw32" ->
+ -- Windows batch file
+ ( shimCcDir </> "cc_shim.bat"
+ , "@echo off\r\n\"" ++ cc ++ "\" %*\r\n" )
+ _ ->
+ -- Unix shell script
+ ( shimCcDir </> "cc_shim.sh"
+ , "#!/bin/sh\n" ++ cc ++ " \"$@\"\n" )
+
+ liftIO $ writeFile shimCcPath shimCcContent
+
+ -- Make the script executable on Unix-like systems
+ when (os /= "mingw32") $ liftIO $ do
+ perms <- getPermissions shimCcPath
+ setPermissions shimCcPath (setOwnerExecutable True perms)
+
+ -- Use the shim compiler in our settings
+ let
+ tool_settings' = tool_settings { toolSettings_pgm_c = shimCcPath }
+
+ -- Compile the test C file with our modified settings
+ let c_file = "./T25204_C.c"
+
+ ghc_ver_file <- liftIO $ makeAbsolute "./ghc-install-folder/ghc version.h"
+
+ hsc_env <- getSession
+
+ let dflags' =
+ dflags { toolSettings = tool_settings'
+ , ghcVersionFile = Just ghc_ver_file
+ }
+ setSession $ hsc_env { hsc_dflags = dflags' }
+ hsc_env' <- getSession
+
+ res <- liftIO $ compileFile hsc_env' NoStop (c_file, Nothing)
+ case res of
+ Nothing ->
+ liftIO $ putStrLn "Compilation of C file failed"
+ Just {} ->
+ liftIO $ putStrLn "Compilation of C file succeeded"
diff --git a/testsuite/tests/ghc-api/settings-escape/T25204.stdout b/testsuite/tests/ghc-api/settings-escape/T25204.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..6d9953a6175a3a6648e9b5fecbdfe4f6f09a7867
--- /dev/null
+++ b/testsuite/tests/ghc-api/settings-escape/T25204.stdout
@@ -0,0 +1 @@
+Compilation of C file succeeded
diff --git a/testsuite/tests/ghc-api/settings-escape/T25204_C.c b/testsuite/tests/ghc-api/settings-escape/T25204_C.c
new file mode 100644
index 0000000000000000000000000000000000000000..a5041ca9f3d1209c531e0ec7a951f22e4f937d85
--- /dev/null
+++ b/testsuite/tests/ghc-api/settings-escape/T25204_C.c
@@ -0,0 +1,6 @@
+#include <stdio.h>
+
+int main () {
+ printf("Hello C compiler with spaces!");
+ return 0;
+}
diff --git a/testsuite/tests/ghc-api/settings-escape/all.T b/testsuite/tests/ghc-api/settings-escape/all.T
index b033b6aa1ba7cffb65f1920a2819e216a8453df4..6867e2b028824d176586ec1295bf25e0f0d082b6 100644
--- a/testsuite/tests/ghc-api/settings-escape/all.T
+++ b/testsuite/tests/ghc-api/settings-escape/all.T
@@ -1,5 +1,13 @@
-test('T11938',
+test('T24265',
[ extra_run_opts('"' + config.libdir + '"')
- , extra_files(['ghc-install-folder/'])]
+ , extra_files(['ghc-install-folder/']) ]
, compile_and_run
- , ['-package ghc -package directory -package containers -package transformers'])
+ , ['-package ghc -package directory -package containers -package transformers -package filepath'])
+test('T25204',
+ [ extra_run_opts('"' + config.libdir + '"')
+ , extra_files(['T25204_C.c', 'ghc-install-folder/'])
+ , req_c
+ , when(arch('wasm32'), skip)
+ ]
+ , compile_and_run
+ , ['-package ghc -package directory -package containers -package transformers -package filepath'])
diff --git a/testsuite/tests/ghc-api/settings-escape/ghc-install-folder/ghc version.h b/testsuite/tests/ghc-api/settings-escape/ghc-install-folder/ghc version.h
new file mode 100644
index 0000000000000000000000000000000000000000..320ac188453f0b8a0224a94d006e340d3da3711b
--- /dev/null
+++ b/testsuite/tests/ghc-api/settings-escape/ghc-install-folder/ghc version.h
@@ -0,0 +1 @@
+// this file doesn't matter for this test
\ No newline at end of file
diff --git a/testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib/.gitkeep b/testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/.gitkeep
similarity index 100%
rename from testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib/.gitkeep
rename to testsuite/tests/ghc-api/settings-escape/ghc-install-folder/lib with spaces/.gitkeep
diff --git a/testsuite/tests/rts/T13082/Makefile b/testsuite/tests/rts/T13082/Makefile
index 1f023b0039ff948f0672889a3ad7039341b30292..1a28644384ddf3dc0e74cd850fc8e46243a46718 100644
--- a/testsuite/tests/rts/T13082/Makefile
+++ b/testsuite/tests/rts/T13082/Makefile
@@ -12,4 +12,5 @@ T13082_good:
.PHONY: T13082_fail
T13082_fail:
- ! echo main | '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) main.hs -ldoesnotexist
+ '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) main.hs -ldoesnotexist 2>&1 | grep "addDLL: doesnotexist or dependencies not loaded"
+
diff --git a/testsuite/tests/rts/T13082/T13082_fail.stderr b/testsuite/tests/rts/T13082/T13082_fail.stdout
similarity index 60%
rename from testsuite/tests/rts/T13082/T13082_fail.stderr
rename to testsuite/tests/rts/T13082/T13082_fail.stdout
index 281e16a1b5f5a32158f6d3e3bbce62bbe0ac68cf..13d66a53b812b034864c6696c38ed56cbfe18c47 100644
--- a/testsuite/tests/rts/T13082/T13082_fail.stderr
+++ b/testsuite/tests/rts/T13082/T13082_fail.stdout
@@ -1,3 +1 @@
<command line>: user specified .o/.so/.DLL could not be loaded (addDLL: doesnotexist or dependencies not loaded. (Win32 error 126))
-Whilst trying to load: (dynamic) doesnotexist
-Additional directories searched: (none)