summaryrefslogtreecommitdiff
path: root/compiler/GHC/SysTools/Process.hs
blob: 522c50f354c4c4d42d09a5a77b6ccd2d943d9644 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
--
-- Misc process handling code for SysTools
--
-- (c) The GHC Team 2017
--
-----------------------------------------------------------------------------
module GHC.SysTools.Process where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Driver.Session

import GHC.Utils.Exception
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Logger

import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan )
import GHC.Data.FastString

import Control.Concurrent
import Data.Char

import System.Exit
import System.Environment
import System.FilePath
import System.IO
import System.IO.Error as IO
import System.Process

import GHC.Utils.TmpFs

-- | Enable process jobs support on Windows if it can be expected to work (e.g.
-- @process >= 1.6.9.0@).
enableProcessJobs :: CreateProcess -> CreateProcess
#if defined(MIN_VERSION_process)
enableProcessJobs opts = opts { use_process_jobs = True }
#else
enableProcessJobs opts = opts
#endif

#if !MIN_VERSION_base(4,15,0)
-- TODO: This can be dropped with GHC 8.16
hGetContents' :: Handle -> IO String
hGetContents' hdl = do
  output  <- hGetContents hdl
  _ <- evaluate $ length output
  return output
#endif

-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
-- inherited from the parent process, and output to stderr is not captured.
readCreateProcessWithExitCode'
    :: CreateProcess
    -> IO (ExitCode, String)    -- ^ stdout
readCreateProcessWithExitCode' proc = do
    (_, Just outh, _, pid) <-
        createProcess $ enableProcessJobs $ proc{ std_out = CreatePipe }

    -- fork off a thread to start consuming the output
    outMVar <- newEmptyMVar
    let onError :: SomeException -> IO ()
        onError exc = putMVar outMVar (Left exc)
    _ <- forkIO $ handle onError $ do
      output <- hGetContents' outh
      putMVar outMVar $ Right output

    -- wait on the output
    result <- takeMVar outMVar
    hClose outh
    output <- case result of
      Left exc -> throwIO exc
      Right output -> return output

    -- wait on the process
    ex <- waitForProcess pid

    return (ex, output)

replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
replaceVar (var, value) env =
    (var, value) : filter (\(var',_) -> var /= var') env

-- | Version of @System.Process.readProcessWithExitCode@ that takes a
-- key-value tuple to insert into the environment.
readProcessEnvWithExitCode
    :: String -- ^ program path
    -> [String] -- ^ program args
    -> (String, String) -- ^ addition to the environment
    -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
readProcessEnvWithExitCode prog args env_update = do
    current_env <- getEnvironment
    readCreateProcessWithExitCode (proc prog args) {
        env = Just (replaceVar env_update current_env) } ""

-- Don't let gcc localize version info string, #8825
c_locale_env :: (String, String)
c_locale_env = ("LANGUAGE", "C")

-- If the -B<dir> option is set, add <dir> to PATH.  This works around
-- a bug in gcc on Windows Vista where it can't find its auxiliary
-- binaries (see bug #1110).
getGccEnv :: [Option] -> IO (Maybe [(String,String)])
getGccEnv opts =
  if null b_dirs
     then return Nothing
     else do env <- getEnvironment
             return (Just (mangle_paths env))
 where
  (b_dirs, _) = partitionWith get_b_opt opts

  get_b_opt (Option ('-':'B':dir)) = Left dir
  get_b_opt other = Right other

  -- Work around #1110 on Windows only (lest we stumble into #17266).
#if defined(mingw32_HOST_OS)
  mangle_paths = map mangle_path
  mangle_path (path,paths) | map toUpper path == "PATH"
        = (path, '\"' : head b_dirs ++ "\";" ++ paths)
  mangle_path other = other
#else
  mangle_paths = id
#endif


-----------------------------------------------------------------------------
-- Running an external program

runSomething :: Logger
             -> DynFlags
             -> String          -- For -v message
             -> String          -- Command name (possibly a full path)
                                --      assumed already dos-ified
             -> [Option]        -- Arguments
                                --      runSomething will dos-ify them
             -> IO ()

runSomething logger dflags phase_name pgm args =
  runSomethingFiltered logger dflags id phase_name pgm args Nothing Nothing

-- | Run a command, placing the arguments in an external response file.
--
-- This command is used in order to avoid overlong command line arguments on
-- Windows. The command line arguments are first written to an external,
-- temporary response file, and then passed to the linker via @filepath.
-- response files for passing them in. See:
--
--     https://gcc.gnu.org/wiki/Response_Files
--     https://gitlab.haskell.org/ghc/ghc/issues/10777
runSomethingResponseFile
  :: Logger
  -> TmpFs
  -> DynFlags
  -> (String->String)
  -> String
  -> String
  -> [Option]
  -> Maybe [(String,String)]
  -> IO ()
runSomethingResponseFile logger tmpfs dflags filter_fn phase_name pgm args mb_env =
    runSomethingWith logger dflags phase_name pgm args $ \real_args -> do
        fp <- getResponseFile real_args
        let args = ['@':fp]
        r <- builderMainLoop logger dflags filter_fn pgm args Nothing mb_env
        return (r,())
  where
    getResponseFile args = do
      fp <- newTempName logger tmpfs dflags TFL_CurrentModule "rsp"
      withFile fp WriteMode $ \h -> do
#if defined(mingw32_HOST_OS)
          hSetEncoding h latin1
#else
          hSetEncoding h utf8
#endif
          hPutStr h $ unlines $ map escape args
      return fp

    -- Note: Response files have backslash-escaping, double quoting, and are
    -- whitespace separated (some implementations use newline, others any
    -- whitespace character). Therefore, escape any backslashes, newlines, and
    -- double quotes in the argument, and surround the content with double
    -- quotes.
    --
    -- Another possibility that could be considered would be to convert
    -- backslashes in the argument to forward slashes. This would generally do
    -- the right thing, since backslashes in general only appear in arguments
    -- as part of file paths on Windows, and the forward slash is accepted for
    -- those. However, escaping is more reliable, in case somehow a backslash
    -- appears in a non-file.
    escape x = concat
        [ "\""
        , concatMap
            (\c ->
                case c of
                    '\\' -> "\\\\"
                    '\n' -> "\\n"
                    '\"' -> "\\\""
                    _    -> [c])
            x
        , "\""
        ]

runSomethingFiltered
  :: Logger -> DynFlags -> (String->String) -> String -> String -> [Option]
  -> Maybe FilePath -> Maybe [(String,String)] -> IO ()

runSomethingFiltered logger dflags filter_fn phase_name pgm args mb_cwd mb_env =
    runSomethingWith logger dflags phase_name pgm args $ \real_args -> do
        r <- builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env
        return (r,())

runSomethingWith
  :: Logger -> DynFlags -> String -> String -> [Option]
  -> ([String] -> IO (ExitCode, a))
  -> IO a

runSomethingWith logger dflags phase_name pgm args io = do
  let real_args = filter notNull (map showOpt args)
      cmdLine = showCommandForUser pgm real_args
  traceCmd logger dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args

handleProc :: String -> String -> IO (ExitCode, r) -> IO r
handleProc pgm phase_name proc = do
    (rc, r) <- proc `catchIO` handler
    case rc of
      ExitSuccess{} -> return r
      ExitFailure n -> throwGhcExceptionIO (
            ProgramError ("`" ++ takeFileName pgm ++ "'" ++
                          " failed in phase `" ++ phase_name ++ "'." ++
                          " (Exit code: " ++ show n ++ ")"))
  where
    handler err =
       if IO.isDoesNotExistError err
          then does_not_exist
          else throwGhcExceptionIO (ProgramError $ show err)

    does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))


builderMainLoop :: Logger -> DynFlags -> (String -> String) -> FilePath
                -> [String] -> Maybe FilePath -> Maybe [(String, String)]
                -> IO ExitCode
builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env = do
  chan <- newChan

  -- We use a mask here rather than a bracket because we want
  -- to distinguish between cleaning up with and without an
  -- exception. This is to avoid calling terminateProcess
  -- unless an exception was raised.
  let safely inner = mask $ \restore -> do
        -- acquire
        -- On Windows due to how exec is emulated the old process will exit and
        -- a new process will be created. This means waiting for termination of
        -- the parent process will get you in a race condition as the child may
        -- not have finished yet.  This caused #16450.  To fix this use a
        -- process job to track all child processes and wait for each one to
        -- finish.
        let procdata =
              enableProcessJobs
              $ (proc pgm real_args) { cwd = mb_cwd
                                     , env = mb_env
                                     , std_in  = CreatePipe
                                     , std_out = CreatePipe
                                     , std_err = CreatePipe
                                     }
        (Just hStdIn, Just hStdOut, Just hStdErr, hProcess) <- restore $
          createProcess_ "builderMainLoop" procdata
        let cleanup_handles = do
              hClose hStdIn
              hClose hStdOut
              hClose hStdErr
        r <- try $ restore $ do
          hSetBuffering hStdOut LineBuffering
          hSetBuffering hStdErr LineBuffering
          let make_reader_proc h = forkIO $ readerProc chan h filter_fn
          bracketOnError (make_reader_proc hStdOut) killThread $ \_ ->
            bracketOnError (make_reader_proc hStdErr) killThread $ \_ ->
            inner hProcess
        case r of
          -- onException
          Left (SomeException e) -> do
            terminateProcess hProcess
            cleanup_handles
            throw e
          -- cleanup when there was no exception
          Right s -> do
            cleanup_handles
            return s
  safely $ \h -> do
    -- we don't want to finish until 2 streams have been complete
    -- (stdout and stderr)
    log_loop chan (2 :: Integer)
    -- after that, we wait for the process to finish and return the exit code.
    waitForProcess h
  where
    -- t starts at the number of streams we're listening to (2) decrements each
    -- time a reader process sends EOF. We are safe from looping forever if a
    -- reader thread dies, because they send EOF in a finally handler.
    log_loop _ 0 = return ()
    log_loop chan t = do
      msg <- readChan chan
      case msg of
        BuildMsg msg -> do
          logInfo logger dflags $ withPprStyle defaultUserStyle msg
          log_loop chan t
        BuildError loc msg -> do
          putLogMsg logger dflags errorDiagnostic (mkSrcSpan loc loc)
              $ withPprStyle defaultUserStyle msg
          log_loop chan t
        EOF ->
          log_loop chan  (t-1)

readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
readerProc chan hdl filter_fn =
    (do str <- hGetContents hdl
        loop (linesPlatform (filter_fn str)) Nothing)
    `finally`
       writeChan chan EOF
        -- ToDo: check errors more carefully
        -- ToDo: in the future, the filter should be implemented as
        -- a stream transformer.
    where
        loop []     Nothing    = return ()
        loop []     (Just err) = writeChan chan err
        loop (l:ls) in_err     =
                case in_err of
                  Just err@(BuildError srcLoc msg)
                    | leading_whitespace l ->
                        loop ls (Just (BuildError srcLoc (msg $$ text l)))
                    | otherwise -> do
                        writeChan chan err
                        checkError l ls
                  Nothing ->
                        checkError l ls
                  _ -> panic "readerProc/loop"

        checkError l ls
           = case parseError l of
                Nothing -> do
                    writeChan chan (BuildMsg (text l))
                    loop ls Nothing
                Just (file, lineNum, colNum, msg) -> do
                    let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
                    loop ls (Just (BuildError srcLoc (text msg)))

        leading_whitespace []    = False
        leading_whitespace (x:_) = isSpace x

parseError :: String -> Maybe (String, Int, Int, String)
parseError s0 = case breakColon s0 of
                Just (filename, s1) ->
                    case breakIntColon s1 of
                    Just (lineNum, s2) ->
                        case breakIntColon s2 of
                        Just (columnNum, s3) ->
                            Just (filename, lineNum, columnNum, s3)
                        Nothing ->
                            Just (filename, lineNum, 0, s2)
                    Nothing -> Nothing
                Nothing -> Nothing

-- | Break a line of an error message into a filename and the rest of the line,
-- taking care to ignore colons in Windows drive letters (as noted in #17786).
-- For instance,
--
-- * @"hi.c: ABCD"@ is mapped to @Just ("hi.c", \"ABCD\")@
-- * @"C:\\hi.c: ABCD"@ is mapped to @Just ("C:\\hi.c", \"ABCD\")@
breakColon :: String -> Maybe (String, String)
breakColon = go []
  where
    -- Don't break on Windows drive letters (e.g. @C:\@ or @C:/@)
    go accum  (':':'\\':rest) = go ('\\':':':accum) rest
    go accum  (':':'/':rest)  = go ('/':':':accum) rest
    go accum  (':':rest)      = Just (reverse accum, rest)
    go accum  (c:rest)        = go (c:accum) rest
    go _accum []              = Nothing

breakIntColon :: String -> Maybe (Int, String)
breakIntColon xs = case break (':' ==) xs of
                       (ys, _:zs)
                        | not (null ys) && all isAscii ys && all isDigit ys ->
                           Just (read ys, zs)
                       _ -> Nothing

data BuildMessage
  = BuildMsg   !SDoc
  | BuildError !SrcLoc !SDoc
  | EOF

-- Divvy up text stream into lines, taking platform dependent
-- line termination into account.
linesPlatform :: String -> [String]
#if !defined(mingw32_HOST_OS)
linesPlatform ls = lines ls
#else
linesPlatform "" = []
linesPlatform xs =
  case lineBreak xs of
    (as,xs1) -> as : linesPlatform xs1
  where
   lineBreak "" = ("","")
   lineBreak ('\r':'\n':xs) = ([],xs)
   lineBreak ('\n':xs) = ([],xs)
   lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)

#endif