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