never executed always true always false
1 {-# LANGUAGE ScopedTypeVariables #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Tasks running external programs for SysTools
6 --
7 -- (c) The GHC Team 2017
8 --
9 -----------------------------------------------------------------------------
10 module GHC.SysTools.Tasks where
11
12 import GHC.Prelude
13 import GHC.Platform
14 import GHC.ForeignSrcLang
15 import GHC.IO (catchException)
16
17 import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionStr, parseLlvmVersion)
18
19 import GHC.SysTools.Process
20 import GHC.SysTools.Info
21
22 import GHC.Driver.Session
23
24 import GHC.Utils.Exception as Exception
25 import GHC.Utils.Error
26 import GHC.Utils.Outputable
27 import GHC.Utils.Misc
28 import GHC.Utils.Logger
29 import GHC.Utils.TmpFs
30 import GHC.Utils.Constants (isWindowsHost)
31
32 import Data.List (tails, isPrefixOf)
33 import System.IO
34 import System.Process
35
36 {-
37 ************************************************************************
38 * *
39 \subsection{Running an external program}
40 * *
41 ************************************************************************
42 -}
43
44 runUnlit :: Logger -> DynFlags -> [Option] -> IO ()
45 runUnlit logger dflags args = traceToolCommand logger "unlit" $ do
46 let prog = pgm_L dflags
47 opts = getOpts dflags opt_L
48 runSomething logger "Literate pre-processor" prog
49 (map Option opts ++ args)
50
51 runCpp :: Logger -> DynFlags -> [Option] -> IO ()
52 runCpp logger dflags args = traceToolCommand logger "cpp" $ do
53 let (p,args0) = pgm_P dflags
54 args1 = map Option (getOpts dflags opt_P)
55 args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]
56 ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]
57 mb_env <- getGccEnv args2
58 runSomethingFiltered logger id "C pre-processor" p
59 (args0 ++ args1 ++ args2 ++ args) Nothing mb_env
60
61 runPp :: Logger -> DynFlags -> [Option] -> IO ()
62 runPp logger dflags args = traceToolCommand logger "pp" $ do
63 let prog = pgm_F dflags
64 opts = map Option (getOpts dflags opt_F)
65 runSomething logger "Haskell pre-processor" prog (args ++ opts)
66
67 -- | Run compiler of C-like languages and raw objects (such as gcc or clang).
68 runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
69 runCc mLanguage logger tmpfs dflags args = traceToolCommand logger "cc" $ do
70 let p = pgm_c dflags
71 args1 = map Option userOpts
72 args2 = languageOptions ++ args ++ args1
73 -- We take care to pass -optc flags in args1 last to ensure that the
74 -- user can override flags passed by GHC. See #14452.
75 mb_env <- getGccEnv args2
76 runSomethingResponseFile logger tmpfs dflags cc_filter "C Compiler" p args2 mb_env
77 where
78 -- discard some harmless warnings from gcc that we can't turn off
79 cc_filter = unlines . doFilter . lines
80
81 {-
82 gcc gives warnings in chunks like so:
83 In file included from /foo/bar/baz.h:11,
84 from /foo/bar/baz2.h:22,
85 from wibble.c:33:
86 /foo/flibble:14: global register variable ...
87 /foo/flibble:15: warning: call-clobbered r...
88 We break it up into its chunks, remove any call-clobbered register
89 warnings from each chunk, and then delete any chunks that we have
90 emptied of warnings.
91 -}
92 doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
93 -- We can't assume that the output will start with an "In file inc..."
94 -- line, so we start off expecting a list of warnings rather than a
95 -- location stack.
96 chunkWarnings :: [String] -- The location stack to use for the next
97 -- list of warnings
98 -> [String] -- The remaining lines to look at
99 -> [([String], [String])]
100 chunkWarnings loc_stack [] = [(loc_stack, [])]
101 chunkWarnings loc_stack xs
102 = case break loc_stack_start xs of
103 (warnings, lss:xs') ->
104 case span loc_start_continuation xs' of
105 (lsc, xs'') ->
106 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
107 _ -> [(loc_stack, xs)]
108
109 filterWarnings :: [([String], [String])] -> [([String], [String])]
110 filterWarnings [] = []
111 -- If the warnings are already empty then we are probably doing
112 -- something wrong, so don't delete anything
113 filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
114 filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
115 [] -> filterWarnings zs
116 ys' -> (xs, ys') : filterWarnings zs
117
118 unChunkWarnings :: [([String], [String])] -> [String]
119 unChunkWarnings [] = []
120 unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
121
122 loc_stack_start s = "In file included from " `isPrefixOf` s
123 loc_start_continuation s = " from " `isPrefixOf` s
124 wantedWarning w
125 | "warning: call-clobbered register used" `isContainedIn` w = False
126 | otherwise = True
127
128 -- force the C compiler to interpret this file as C when
129 -- compiling .hc files, by adding the -x c option.
130 -- Also useful for plain .c files, just in case GHC saw a
131 -- -x c option.
132 (languageOptions, userOpts) = case mLanguage of
133 Nothing -> ([], userOpts_c)
134 Just language -> ([Option "-x", Option languageName], opts)
135 where
136 (languageName, opts) = case language of
137 LangC -> ("c", userOpts_c)
138 LangCxx -> ("c++", userOpts_cxx)
139 LangObjc -> ("objective-c", userOpts_c)
140 LangObjcxx -> ("objective-c++", userOpts_cxx)
141 LangAsm -> ("assembler", [])
142 RawObject -> ("c", []) -- claim C for lack of a better idea
143 userOpts_c = getOpts dflags opt_c
144 userOpts_cxx = getOpts dflags opt_cxx
145
146 isContainedIn :: String -> String -> Bool
147 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
148
149 -- | Run the linker with some arguments and return the output
150 askLd :: Logger -> DynFlags -> [Option] -> IO String
151 askLd logger dflags args = traceToolCommand logger "linker" $ do
152 let (p,args0) = pgm_l dflags
153 args1 = map Option (getOpts dflags opt_l)
154 args2 = args0 ++ args1 ++ args
155 mb_env <- getGccEnv args2
156 runSomethingWith logger "gcc" p args2 $ \real_args ->
157 readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
158
159 runAs :: Logger -> DynFlags -> [Option] -> IO ()
160 runAs logger dflags args = traceToolCommand logger "as" $ do
161 let (p,args0) = pgm_a dflags
162 args1 = map Option (getOpts dflags opt_a)
163 args2 = args0 ++ args1 ++ args
164 mb_env <- getGccEnv args2
165 runSomethingFiltered logger id "Assembler" p args2 Nothing mb_env
166
167 -- | Run the LLVM Optimiser
168 runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO ()
169 runLlvmOpt logger dflags args = traceToolCommand logger "opt" $ do
170 let (p,args0) = pgm_lo dflags
171 args1 = map Option (getOpts dflags opt_lo)
172 -- We take care to pass -optlo flags (e.g. args0) last to ensure that the
173 -- user can override flags passed by GHC. See #14821.
174 runSomething logger "LLVM Optimiser" p (args1 ++ args ++ args0)
175
176 -- | Run the LLVM Compiler
177 runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO ()
178 runLlvmLlc logger dflags args = traceToolCommand logger "llc" $ do
179 let (p,args0) = pgm_lc dflags
180 args1 = map Option (getOpts dflags opt_lc)
181 runSomething logger "LLVM Compiler" p (args0 ++ args1 ++ args)
182
183 -- | Run the clang compiler (used as an assembler for the LLVM
184 -- backend on OS X as LLVM doesn't support the OS X system
185 -- assembler)
186 runClang :: Logger -> DynFlags -> [Option] -> IO ()
187 runClang logger dflags args = traceToolCommand logger "clang" $ do
188 let (clang,_) = pgm_lcc dflags
189 -- be careful what options we call clang with
190 -- see #5903 and #7617 for bugs caused by this.
191 (_,args0) = pgm_a dflags
192 args1 = map Option (getOpts dflags opt_a)
193 args2 = args0 ++ args1 ++ args
194 mb_env <- getGccEnv args2
195 catchException
196 (runSomethingFiltered logger id "Clang (Assembler)" clang args2 Nothing mb_env)
197 (\(err :: SomeException) -> do
198 errorMsg logger $
199 text ("Error running clang! you need clang installed to use the" ++
200 " LLVM backend") $+$
201 text "(or GHC tried to execute clang incorrectly)"
202 throwIO err
203 )
204
205 -- | Figure out which version of LLVM we are running this session
206 figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion)
207 figureLlvmVersion logger dflags = traceToolCommand logger "llc" $ do
208 let (pgm,opts) = pgm_lc dflags
209 args = filter notNull (map showOpt opts)
210 -- we grab the args even though they should be useless just in
211 -- case the user is using a customised 'llc' that requires some
212 -- of the options they've specified. llc doesn't care what other
213 -- options are specified when '-version' is used.
214 args' = args ++ ["-version"]
215 catchIO (do
216 (pin, pout, perr, p) <- runInteractiveProcess pgm args'
217 Nothing Nothing
218 {- > llc -version
219 LLVM (http://llvm.org/):
220 LLVM version 3.5.2
221 ...
222 -}
223 hSetBinaryMode pout False
224 _ <- hGetLine pout
225 vline <- hGetLine pout
226 let mb_ver = parseLlvmVersion vline
227 hClose pin
228 hClose pout
229 hClose perr
230 _ <- waitForProcess p
231 return mb_ver
232 )
233 (\err -> do
234 debugTraceMsg logger 2
235 (text "Error (figuring out LLVM version):" <+>
236 text (show err))
237 errorMsg logger $ vcat
238 [ text "Warning:", nest 9 $
239 text "Couldn't figure out LLVM version!" $$
240 text ("Make sure you have installed LLVM between ["
241 ++ llvmVersionStr supportedLlvmVersionLowerBound
242 ++ " and "
243 ++ llvmVersionStr supportedLlvmVersionUpperBound
244 ++ ")") ]
245 return Nothing)
246
247
248
249 runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
250 runLink logger tmpfs dflags args = traceToolCommand logger "linker" $ do
251 -- See Note [Run-time linker info]
252 --
253 -- `-optl` args come at the end, so that later `-l` options
254 -- given there manually can fill in symbols needed by
255 -- Haskell libraries coming in via `args`.
256 linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags
257 let (p,args0) = pgm_l dflags
258 optl_args = map Option (getOpts dflags opt_l)
259 args2 = args0 ++ linkargs ++ args ++ optl_args
260 mb_env <- getGccEnv args2
261 runSomethingResponseFile logger tmpfs dflags ld_filter "Linker" p args2 mb_env
262 where
263 ld_filter = case (platformOS (targetPlatform dflags)) of
264 OSSolaris2 -> sunos_ld_filter
265 _ -> id
266 {-
267 SunOS/Solaris ld emits harmless warning messages about unresolved
268 symbols in case of compiling into shared library when we do not
269 link against all the required libs. That is the case of GHC which
270 does not link against RTS library explicitly in order to be able to
271 choose the library later based on binary application linking
272 parameters. The warnings look like:
273
274 Undefined first referenced
275 symbol in file
276 stg_ap_n_fast ./T2386_Lib.o
277 stg_upd_frame_info ./T2386_Lib.o
278 templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
279 templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
280 templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
281 templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
282 newCAF ./T2386_Lib.o
283 stg_bh_upd_frame_info ./T2386_Lib.o
284 stg_ap_ppp_fast ./T2386_Lib.o
285 templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
286 stg_ap_p_fast ./T2386_Lib.o
287 stg_ap_pp_fast ./T2386_Lib.o
288 ld: warning: symbol referencing errors
289
290 this is actually coming from T2386 testcase. The emitting of those
291 warnings is also a reason why so many TH testcases fail on Solaris.
292
293 Following filter code is SunOS/Solaris linker specific and should
294 filter out only linker warnings. Please note that the logic is a
295 little bit more complex due to the simple reason that we need to preserve
296 any other linker emitted messages. If there are any. Simply speaking
297 if we see "Undefined" and later "ld: warning:..." then we omit all
298 text between (including) the marks. Otherwise we copy the whole output.
299 -}
300 sunos_ld_filter :: String -> String
301 sunos_ld_filter = unlines . sunos_ld_filter' . lines
302 sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
303 then (ld_prefix x) ++ (ld_postfix x)
304 else x
305 breakStartsWith x y = break (isPrefixOf x) y
306 ld_prefix = fst . breakStartsWith "Undefined"
307 undefined_found = not . null . snd . breakStartsWith "Undefined"
308 ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
309 ld_postfix = tail . snd . ld_warn_break
310 ld_warning_found = not . null . snd . ld_warn_break
311
312 -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline.
313 runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
314 runMergeObjects logger tmpfs dflags args =
315 traceToolCommand logger "merge-objects" $ do
316 let (p,args0) = pgm_lm dflags
317 optl_args = map Option (getOpts dflags opt_lm)
318 args2 = args0 ++ args ++ optl_args
319 -- N.B. Darwin's ld64 doesn't support response files. Consequently we only
320 -- use them on Windows where they are truly necessary.
321 if isWindowsHost
322 then do
323 mb_env <- getGccEnv args2
324 runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env
325 else do
326 runSomething logger "Merge objects" p args2
327
328 runLibtool :: Logger -> DynFlags -> [Option] -> IO ()
329 runLibtool logger dflags args = traceToolCommand logger "libtool" $ do
330 linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags
331 let args1 = map Option (getOpts dflags opt_l)
332 args2 = [Option "-static"] ++ args1 ++ args ++ linkargs
333 libtool = pgm_libtool dflags
334 mb_env <- getGccEnv args2
335 runSomethingFiltered logger id "Libtool" libtool args2 Nothing mb_env
336
337 runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO ()
338 runAr logger dflags cwd args = traceToolCommand logger "ar" $ do
339 let ar = pgm_ar dflags
340 runSomethingFiltered logger id "Ar" ar args cwd Nothing
341
342 askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String
343 askOtool logger dflags mb_cwd args = do
344 let otool = pgm_otool dflags
345 runSomethingWith logger "otool" otool args $ \real_args ->
346 readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd }
347
348 runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO ()
349 runInstallNameTool logger dflags args = do
350 let tool = pgm_install_name_tool dflags
351 runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing
352
353 runRanlib :: Logger -> DynFlags -> [Option] -> IO ()
354 runRanlib logger dflags args = traceToolCommand logger "ranlib" $ do
355 let ranlib = pgm_ranlib dflags
356 runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing
357
358 runWindres :: Logger -> DynFlags -> [Option] -> IO ()
359 runWindres logger dflags args = traceToolCommand logger "windres" $ do
360 let cc = pgm_c dflags
361 cc_args = map Option (sOpt_c (settings dflags))
362 windres = pgm_windres dflags
363 opts = map Option (getOpts dflags opt_windres)
364 quote x = "\"" ++ x ++ "\""
365 args' = -- If windres.exe and gcc.exe are in a directory containing
366 -- spaces then windres fails to run gcc. We therefore need
367 -- to tell it what command to use...
368 Option ("--preprocessor=" ++
369 unwords (map quote (cc :
370 map showOpt opts ++
371 ["-E", "-xc", "-DRC_INVOKED"])))
372 -- ...but if we do that then if windres calls popen then
373 -- it can't understand the quoting, so we have to use
374 -- --use-temp-file so that it interprets it correctly.
375 -- See #1828.
376 : Option "--use-temp-file"
377 : args
378 mb_env <- getGccEnv cc_args
379 runSomethingFiltered logger id "Windres" windres args' Nothing mb_env
380
381 touch :: Logger -> DynFlags -> String -> String -> IO ()
382 touch logger dflags purpose arg = traceToolCommand logger "touch" $
383 runSomething logger purpose (pgm_T dflags) [FileOption "" arg]
384
385 -- * Tracing utility
386
387 -- | Record in the eventlog when the given tool command starts
388 -- and finishes, prepending the given 'String' with
389 -- \"systool:\", to easily be able to collect and process
390 -- all the systool events.
391 --
392 -- For those events to show up in the eventlog, you need
393 -- to run GHC with @-v2@ or @-ddump-timings@.
394 traceToolCommand :: Logger -> String -> IO a -> IO a
395 traceToolCommand logger tool = withTiming logger (text "systool:" <> text tool) (const ())