never executed always true always false
1 {-# LANGUAGE CPP #-}
2 -----------------------------------------------------------------------------
3 --
4 -- Misc process handling code for SysTools
5 --
6 -- (c) The GHC Team 2017
7 --
8 -----------------------------------------------------------------------------
9 module GHC.SysTools.Process where
10
11 import GHC.Prelude
12
13 import GHC.Driver.Session
14
15 import GHC.Utils.Exception
16 import GHC.Utils.Error
17 import GHC.Utils.Outputable
18 import GHC.Utils.Panic
19 import GHC.Utils.Misc
20 import GHC.Utils.Logger
21
22 import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan )
23 import GHC.Data.FastString
24
25 import Control.Concurrent
26 import Data.Char
27
28 import System.Exit
29 import System.Environment
30 import System.FilePath
31 import System.IO
32 import System.IO.Error as IO
33 import System.Process
34
35 import GHC.Utils.TmpFs
36
37 -- | Enable process jobs support on Windows if it can be expected to work (e.g.
38 -- @process >= 1.6.9.0@).
39 enableProcessJobs :: CreateProcess -> CreateProcess
40 #if defined(MIN_VERSION_process)
41 enableProcessJobs opts = opts { use_process_jobs = True }
42 #else
43 enableProcessJobs opts = opts
44 #endif
45
46 #if !MIN_VERSION_base(4,15,0)
47 -- TODO: This can be dropped with GHC 8.16
48 hGetContents' :: Handle -> IO String
49 hGetContents' hdl = do
50 output <- hGetContents hdl
51 _ <- evaluate $ length output
52 return output
53 #endif
54
55 -- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
56 -- inherited from the parent process, and output to stderr is not captured.
57 readCreateProcessWithExitCode'
58 :: CreateProcess
59 -> IO (ExitCode, String) -- ^ stdout
60 readCreateProcessWithExitCode' proc = do
61 (_, Just outh, _, pid) <-
62 createProcess $ enableProcessJobs $ proc{ std_out = CreatePipe }
63
64 -- fork off a thread to start consuming the output
65 outMVar <- newEmptyMVar
66 let onError :: SomeException -> IO ()
67 onError exc = putMVar outMVar (Left exc)
68 _ <- forkIO $ handle onError $ do
69 output <- hGetContents' outh
70 putMVar outMVar $ Right output
71
72 -- wait on the output
73 result <- takeMVar outMVar
74 hClose outh
75 output <- case result of
76 Left exc -> throwIO exc
77 Right output -> return output
78
79 -- wait on the process
80 ex <- waitForProcess pid
81
82 return (ex, output)
83
84 replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
85 replaceVar (var, value) env =
86 (var, value) : filter (\(var',_) -> var /= var') env
87
88 -- | Version of @System.Process.readProcessWithExitCode@ that takes a
89 -- key-value tuple to insert into the environment.
90 readProcessEnvWithExitCode
91 :: String -- ^ program path
92 -> [String] -- ^ program args
93 -> (String, String) -- ^ addition to the environment
94 -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
95 readProcessEnvWithExitCode prog args env_update = do
96 current_env <- getEnvironment
97 readCreateProcessWithExitCode (proc prog args) {
98 env = Just (replaceVar env_update current_env) } ""
99
100 -- Don't let gcc localize version info string, #8825
101 c_locale_env :: (String, String)
102 c_locale_env = ("LANGUAGE", "C")
103
104 -- If the -B<dir> option is set, add <dir> to PATH. This works around
105 -- a bug in gcc on Windows Vista where it can't find its auxiliary
106 -- binaries (see bug #1110).
107 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
108 getGccEnv opts =
109 if null b_dirs
110 then return Nothing
111 else do env <- getEnvironment
112 return (Just (mangle_paths env))
113 where
114 (b_dirs, _) = partitionWith get_b_opt opts
115
116 get_b_opt (Option ('-':'B':dir)) = Left dir
117 get_b_opt other = Right other
118
119 -- Work around #1110 on Windows only (lest we stumble into #17266).
120 #if defined(mingw32_HOST_OS)
121 mangle_paths = map mangle_path
122 mangle_path (path,paths) | map toUpper path == "PATH"
123 = (path, '\"' : head b_dirs ++ "\";" ++ paths)
124 mangle_path other = other
125 #else
126 mangle_paths = id
127 #endif
128
129
130 -----------------------------------------------------------------------------
131 -- Running an external program
132
133 runSomething :: Logger
134 -> String -- For -v message
135 -> String -- Command name (possibly a full path)
136 -- assumed already dos-ified
137 -> [Option] -- Arguments
138 -- runSomething will dos-ify them
139 -> IO ()
140
141 runSomething logger phase_name pgm args =
142 runSomethingFiltered logger id phase_name pgm args Nothing Nothing
143
144 -- | Run a command, placing the arguments in an external response file.
145 --
146 -- This command is used in order to avoid overlong command line arguments on
147 -- Windows. The command line arguments are first written to an external,
148 -- temporary response file, and then passed to the linker via @filepath.
149 -- response files for passing them in. See:
150 --
151 -- https://gcc.gnu.org/wiki/Response_Files
152 -- https://gitlab.haskell.org/ghc/ghc/issues/10777
153 runSomethingResponseFile
154 :: Logger
155 -> TmpFs
156 -> DynFlags
157 -> (String->String)
158 -> String
159 -> String
160 -> [Option]
161 -> Maybe [(String,String)]
162 -> IO ()
163 runSomethingResponseFile logger tmpfs dflags filter_fn phase_name pgm args mb_env =
164 runSomethingWith logger phase_name pgm args $ \real_args -> do
165 fp <- getResponseFile real_args
166 let args = ['@':fp]
167 r <- builderMainLoop logger filter_fn pgm args Nothing mb_env
168 return (r,())
169 where
170 getResponseFile args = do
171 fp <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rsp"
172 withFile fp WriteMode $ \h -> do
173 #if defined(mingw32_HOST_OS)
174 hSetEncoding h latin1
175 #else
176 hSetEncoding h utf8
177 #endif
178 hPutStr h $ unlines $ map escape args
179 return fp
180
181 -- Note: Response files have backslash-escaping, double quoting, and are
182 -- whitespace separated (some implementations use newline, others any
183 -- whitespace character). Therefore, escape any backslashes, newlines, and
184 -- double quotes in the argument, and surround the content with double
185 -- quotes.
186 --
187 -- Another possibility that could be considered would be to convert
188 -- backslashes in the argument to forward slashes. This would generally do
189 -- the right thing, since backslashes in general only appear in arguments
190 -- as part of file paths on Windows, and the forward slash is accepted for
191 -- those. However, escaping is more reliable, in case somehow a backslash
192 -- appears in a non-file.
193 escape x = concat
194 [ "\""
195 , concatMap
196 (\c ->
197 case c of
198 '\\' -> "\\\\"
199 '\n' -> "\\n"
200 '\"' -> "\\\""
201 _ -> [c])
202 x
203 , "\""
204 ]
205
206 runSomethingFiltered
207 :: Logger -> (String->String) -> String -> String -> [Option]
208 -> Maybe FilePath -> Maybe [(String,String)] -> IO ()
209
210 runSomethingFiltered logger filter_fn phase_name pgm args mb_cwd mb_env =
211 runSomethingWith logger phase_name pgm args $ \real_args -> do
212 r <- builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env
213 return (r,())
214
215 runSomethingWith
216 :: Logger -> String -> String -> [Option]
217 -> ([String] -> IO (ExitCode, a))
218 -> IO a
219
220 runSomethingWith logger phase_name pgm args io = do
221 let real_args = filter notNull (map showOpt args)
222 cmdLine = showCommandForUser pgm real_args
223 traceCmd logger phase_name cmdLine $ handleProc pgm phase_name $ io real_args
224
225 handleProc :: String -> String -> IO (ExitCode, r) -> IO r
226 handleProc pgm phase_name proc = do
227 (rc, r) <- proc `catchIO` handler
228 case rc of
229 ExitSuccess{} -> return r
230 ExitFailure n -> throwGhcExceptionIO (
231 ProgramError ("`" ++ takeFileName pgm ++ "'" ++
232 " failed in phase `" ++ phase_name ++ "'." ++
233 " (Exit code: " ++ show n ++ ")"))
234 where
235 handler err =
236 if IO.isDoesNotExistError err
237 then does_not_exist
238 else throwGhcExceptionIO (ProgramError $ show err)
239
240 does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
241
242
243 builderMainLoop :: Logger -> (String -> String) -> FilePath
244 -> [String] -> Maybe FilePath -> Maybe [(String, String)]
245 -> IO ExitCode
246 builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = do
247 chan <- newChan
248
249 -- We use a mask here rather than a bracket because we want
250 -- to distinguish between cleaning up with and without an
251 -- exception. This is to avoid calling terminateProcess
252 -- unless an exception was raised.
253 let safely inner = mask $ \restore -> do
254 -- acquire
255 -- On Windows due to how exec is emulated the old process will exit and
256 -- a new process will be created. This means waiting for termination of
257 -- the parent process will get you in a race condition as the child may
258 -- not have finished yet. This caused #16450. To fix this use a
259 -- process job to track all child processes and wait for each one to
260 -- finish.
261 let procdata =
262 enableProcessJobs
263 $ (proc pgm real_args) { cwd = mb_cwd
264 , env = mb_env
265 , std_in = CreatePipe
266 , std_out = CreatePipe
267 , std_err = CreatePipe
268 }
269 (Just hStdIn, Just hStdOut, Just hStdErr, hProcess) <- restore $
270 createProcess_ "builderMainLoop" procdata
271 let cleanup_handles = do
272 hClose hStdIn
273 hClose hStdOut
274 hClose hStdErr
275 r <- try $ restore $ do
276 hSetBuffering hStdOut LineBuffering
277 hSetBuffering hStdErr LineBuffering
278 let make_reader_proc h = forkIO $ readerProc chan h filter_fn
279 bracketOnError (make_reader_proc hStdOut) killThread $ \_ ->
280 bracketOnError (make_reader_proc hStdErr) killThread $ \_ ->
281 inner hProcess
282 case r of
283 -- onException
284 Left (SomeException e) -> do
285 terminateProcess hProcess
286 cleanup_handles
287 throw e
288 -- cleanup when there was no exception
289 Right s -> do
290 cleanup_handles
291 return s
292 safely $ \h -> do
293 -- we don't want to finish until 2 streams have been complete
294 -- (stdout and stderr)
295 log_loop chan (2 :: Integer)
296 -- after that, we wait for the process to finish and return the exit code.
297 waitForProcess h
298 where
299 -- t starts at the number of streams we're listening to (2) decrements each
300 -- time a reader process sends EOF. We are safe from looping forever if a
301 -- reader thread dies, because they send EOF in a finally handler.
302 log_loop _ 0 = return ()
303 log_loop chan t = do
304 msg <- readChan chan
305 case msg of
306 BuildMsg msg -> do
307 logInfo logger $ withPprStyle defaultUserStyle msg
308 log_loop chan t
309 BuildError loc msg -> do
310 logMsg logger errorDiagnostic (mkSrcSpan loc loc)
311 $ withPprStyle defaultUserStyle msg
312 log_loop chan t
313 EOF ->
314 log_loop chan (t-1)
315
316 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
317 readerProc chan hdl filter_fn =
318 (do str <- hGetContents hdl
319 loop (linesPlatform (filter_fn str)) Nothing)
320 `finally`
321 writeChan chan EOF
322 -- ToDo: check errors more carefully
323 -- ToDo: in the future, the filter should be implemented as
324 -- a stream transformer.
325 where
326 loop [] Nothing = return ()
327 loop [] (Just err) = writeChan chan err
328 loop (l:ls) in_err =
329 case in_err of
330 Just err@(BuildError srcLoc msg)
331 | leading_whitespace l ->
332 loop ls (Just (BuildError srcLoc (msg $$ text l)))
333 | otherwise -> do
334 writeChan chan err
335 checkError l ls
336 Nothing ->
337 checkError l ls
338 _ -> panic "readerProc/loop"
339
340 checkError l ls
341 = case parseError l of
342 Nothing -> do
343 writeChan chan (BuildMsg (text l))
344 loop ls Nothing
345 Just (file, lineNum, colNum, msg) -> do
346 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
347 loop ls (Just (BuildError srcLoc (text msg)))
348
349 leading_whitespace [] = False
350 leading_whitespace (x:_) = isSpace x
351
352 parseError :: String -> Maybe (String, Int, Int, String)
353 parseError s0 = case breakColon s0 of
354 Just (filename, s1) ->
355 case breakIntColon s1 of
356 Just (lineNum, s2) ->
357 case breakIntColon s2 of
358 Just (columnNum, s3) ->
359 Just (filename, lineNum, columnNum, s3)
360 Nothing ->
361 Just (filename, lineNum, 0, s2)
362 Nothing -> Nothing
363 Nothing -> Nothing
364
365 -- | Break a line of an error message into a filename and the rest of the line,
366 -- taking care to ignore colons in Windows drive letters (as noted in #17786).
367 -- For instance,
368 --
369 -- * @"hi.c: ABCD"@ is mapped to @Just ("hi.c", \"ABCD\")@
370 -- * @"C:\\hi.c: ABCD"@ is mapped to @Just ("C:\\hi.c", \"ABCD\")@
371 breakColon :: String -> Maybe (String, String)
372 breakColon = go []
373 where
374 -- Don't break on Windows drive letters (e.g. @C:\@ or @C:/@)
375 go accum (':':'\\':rest) = go ('\\':':':accum) rest
376 go accum (':':'/':rest) = go ('/':':':accum) rest
377 go accum (':':rest) = Just (reverse accum, rest)
378 go accum (c:rest) = go (c:accum) rest
379 go _accum [] = Nothing
380
381 breakIntColon :: String -> Maybe (Int, String)
382 breakIntColon xs = case break (':' ==) xs of
383 (ys, _:zs)
384 | not (null ys) && all isAscii ys && all isDigit ys ->
385 Just (read ys, zs)
386 _ -> Nothing
387
388 data BuildMessage
389 = BuildMsg !SDoc
390 | BuildError !SrcLoc !SDoc
391 | EOF
392
393 -- Divvy up text stream into lines, taking platform dependent
394 -- line termination into account.
395 linesPlatform :: String -> [String]
396 #if !defined(mingw32_HOST_OS)
397 linesPlatform ls = lines ls
398 #else
399 linesPlatform "" = []
400 linesPlatform xs =
401 case lineBreak xs of
402 (as,xs1) -> as : linesPlatform xs1
403 where
404 lineBreak "" = ("","")
405 lineBreak ('\r':'\n':xs) = ([],xs)
406 lineBreak ('\n':xs) = ([],xs)
407 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
408
409 #endif