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