Avoid repeated list elem checks
[ghc.git] / compiler / main / SysTools.hs
1 {-
2 -----------------------------------------------------------------------------
3 --
4 -- (c) The University of Glasgow 2001-2003
5 --
6 -- Access to system tools: gcc, cp, rm etc
7 --
8 -----------------------------------------------------------------------------
9 -}
10
11 {-# LANGUAGE CPP, ScopedTypeVariables #-}
12
13 module SysTools (
14 -- Initialisation
15 initSysTools,
16
17 -- Interface to system tools
18 runUnlit, runCpp, runCc, -- [Option] -> IO ()
19 runPp, -- [Option] -> IO ()
20 runSplit, -- [Option] -> IO ()
21 runAs, runLink, runLibtool, -- [Option] -> IO ()
22 runMkDLL,
23 runWindres,
24 runLlvmOpt,
25 runLlvmLlc,
26 runClang,
27 figureLlvmVersion,
28
29 getLinkerInfo,
30 getCompilerInfo,
31
32 linkDynLib,
33
34 askCc,
35
36 touch, -- String -> String -> IO ()
37 copy,
38 copyWithHeader,
39
40 -- Temporary-file management
41 setTmpDir,
42 newTempName, newTempLibName,
43 cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
44 addFilesToClean,
45
46 Option(..),
47
48 -- frameworks
49 getPkgFrameworkOpts,
50 getFrameworkOpts
51
52
53 ) where
54
55 #include "HsVersions.h"
56
57 import DriverPhases
58 import Module
59 import Packages
60 import Config
61 import Outputable
62 import ErrUtils
63 import Panic
64 import Platform
65 import Util
66 import DynFlags
67 import Exception
68
69 import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion)
70
71 import Data.IORef
72 import Control.Monad
73 import System.Exit
74 import System.Environment
75 import System.FilePath
76 import System.IO
77 import System.IO.Error as IO
78 import System.Directory
79 import Data.Char
80 import Data.List
81 import qualified Data.Map as Map
82 import qualified Data.Set as Set
83
84 #ifndef mingw32_HOST_OS
85 import qualified System.Posix.Internals
86 #else /* Must be Win32 */
87 import Foreign
88 import Foreign.C.String
89 #if MIN_VERSION_Win32(2,5,0)
90 import qualified System.Win32.Types as Win32
91 #else
92 import qualified System.Win32.Info as Win32
93 #endif
94 import Control.Exception (finally)
95 import Foreign.Ptr (FunPtr, castPtrToFunPtr)
96 import System.Win32.Types (DWORD, LPTSTR, HANDLE)
97 import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE)
98 import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS )
99 import System.Win32.DLL (loadLibrary, getProcAddress)
100 import Data.Bits((.|.))
101 #endif
102
103 import System.Process
104 import Control.Concurrent
105 import FastString
106 import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
107
108 #ifdef mingw32_HOST_OS
109 # if defined(i386_HOST_ARCH)
110 # define WINDOWS_CCONV stdcall
111 # elif defined(x86_64_HOST_ARCH)
112 # define WINDOWS_CCONV ccall
113 # else
114 # error Unknown mingw32 arch
115 # endif
116 #endif
117
118 {-
119 How GHC finds its files
120 ~~~~~~~~~~~~~~~~~~~~~~~
121
122 [Note topdir]
123
124 GHC needs various support files (library packages, RTS etc), plus
125 various auxiliary programs (cp, gcc, etc). It starts by finding topdir,
126 the root of GHC's support files
127
128 On Unix:
129 - ghc always has a shell wrapper that passes a -B<dir> option
130
131 On Windows:
132 - ghc never has a shell wrapper.
133 - we can find the location of the ghc binary, which is
134 $topdir/bin/<something>.exe
135 where <something> may be "ghc", "ghc-stage2", or similar
136 - we strip off the "bin/<something>.exe" to leave $topdir.
137
138 from topdir we can find package.conf, ghc-asm, etc.
139
140
141 SysTools.initSysProgs figures out exactly where all the auxiliary programs
142 are, and initialises mutable variables to make it easy to call them.
143 To to this, it makes use of definitions in Config.hs, which is a Haskell
144 file containing variables whose value is figured out by the build system.
145
146 Config.hs contains two sorts of things
147
148 cGCC, The *names* of the programs
149 cCPP e.g. cGCC = gcc
150 cUNLIT cCPP = gcc -E
151 etc They do *not* include paths
152
153
154 cUNLIT_DIR The *path* to the directory containing unlit, split etc
155 cSPLIT_DIR *relative* to the root of the build tree,
156 for use when running *in-place* in a build tree (only)
157
158
159
160 ---------------------------------------------
161 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
162
163 Another hair-brained scheme for simplifying the current tool location
164 nightmare in GHC: Simon originally suggested using another
165 configuration file along the lines of GCC's specs file - which is fine
166 except that it means adding code to read yet another configuration
167 file. What I didn't notice is that the current package.conf is
168 general enough to do this:
169
170 Package
171 {name = "tools", import_dirs = [], source_dirs = [],
172 library_dirs = [], hs_libraries = [], extra_libraries = [],
173 include_dirs = [], c_includes = [], package_deps = [],
174 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
175 extra_cc_opts = [], extra_ld_opts = []}
176
177 Which would have the advantage that we get to collect together in one
178 place the path-specific package stuff with the path-specific tool
179 stuff.
180 End of NOTES
181 ---------------------------------------------
182
183 ************************************************************************
184 * *
185 \subsection{Initialisation}
186 * *
187 ************************************************************************
188 -}
189
190 initSysTools :: Maybe String -- Maybe TopDir path (without the '-B' prefix)
191 -> IO Settings -- Set all the mutable variables above, holding
192 -- (a) the system programs
193 -- (b) the package-config file
194 -- (c) the GHC usage message
195 initSysTools mbMinusB
196 = do top_dir <- findTopDir mbMinusB
197 -- see [Note topdir]
198 -- NB: top_dir is assumed to be in standard Unix
199 -- format, '/' separated
200
201 let settingsFile = top_dir </> "settings"
202 platformConstantsFile = top_dir </> "platformConstants"
203 installed :: FilePath -> FilePath
204 installed file = top_dir </> file
205 libexec :: FilePath -> FilePath
206 libexec file = top_dir </> "bin" </> file
207
208 settingsStr <- readFile settingsFile
209 platformConstantsStr <- readFile platformConstantsFile
210 mySettings <- case maybeReadFuzzy settingsStr of
211 Just s ->
212 return s
213 Nothing ->
214 pgmError ("Can't parse " ++ show settingsFile)
215 platformConstants <- case maybeReadFuzzy platformConstantsStr of
216 Just s ->
217 return s
218 Nothing ->
219 pgmError ("Can't parse " ++
220 show platformConstantsFile)
221 let getSetting key = case lookup key mySettings of
222 Just xs ->
223 return $ case stripPrefix "$topdir" xs of
224 Just [] ->
225 top_dir
226 Just xs'@(c:_)
227 | isPathSeparator c ->
228 top_dir ++ xs'
229 _ ->
230 xs
231 Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
232 getBooleanSetting key = case lookup key mySettings of
233 Just "YES" -> return True
234 Just "NO" -> return False
235 Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs)
236 Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
237 readSetting key = case lookup key mySettings of
238 Just xs ->
239 case maybeRead xs of
240 Just v -> return v
241 Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)
242 Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
243 crossCompiling <- getBooleanSetting "cross compiling"
244 targetArch <- readSetting "target arch"
245 targetOS <- readSetting "target os"
246 targetWordSize <- readSetting "target word size"
247 targetUnregisterised <- getBooleanSetting "Unregisterised"
248 targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
249 targetHasIdentDirective <- readSetting "target has .ident directive"
250 targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
251 myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
252 -- On Windows, mingw is distributed with GHC,
253 -- so we look in TopDir/../mingw/bin
254 -- It would perhaps be nice to be able to override this
255 -- with the settings file, but it would be a little fiddly
256 -- to make that possible, so for now you can't.
257 gcc_prog <- getSetting "C compiler command"
258 gcc_args_str <- getSetting "C compiler flags"
259 gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"
260 cpp_prog <- getSetting "Haskell CPP command"
261 cpp_args_str <- getSetting "Haskell CPP flags"
262 let unreg_gcc_args = if targetUnregisterised
263 then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
264 else []
265 -- TABLES_NEXT_TO_CODE affects the info table layout.
266 tntc_gcc_args
267 | mkTablesNextToCode targetUnregisterised
268 = ["-DTABLES_NEXT_TO_CODE"]
269 | otherwise = []
270 cpp_args= map Option (words cpp_args_str)
271 gcc_args = map Option (words gcc_args_str
272 ++ unreg_gcc_args
273 ++ tntc_gcc_args)
274 ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
275 ldSupportsBuildId <- getBooleanSetting "ld supports build-id"
276 ldSupportsFilelist <- getBooleanSetting "ld supports filelist"
277 ldIsGnuLd <- getBooleanSetting "ld is GNU ld"
278 perl_path <- getSetting "perl command"
279
280 let pkgconfig_path = installed "package.conf.d"
281 ghc_usage_msg_path = installed "ghc-usage.txt"
282 ghci_usage_msg_path = installed "ghci-usage.txt"
283
284 -- For all systems, unlit, split, mangle are GHC utilities
285 -- architecture-specific stuff is done when building Config.hs
286 unlit_path = libexec cGHC_UNLIT_PGM
287
288 -- split is a Perl script
289 split_script = libexec cGHC_SPLIT_PGM
290
291 windres_path <- getSetting "windres command"
292 libtool_path <- getSetting "libtool command"
293
294 tmpdir <- getTemporaryDirectory
295
296 touch_path <- getSetting "touch command"
297
298 let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
299 -- a call to Perl to get the invocation of split.
300 -- On Unix, scripts are invoked using the '#!' method. Binary
301 -- installations of GHC on Unix place the correct line on the
302 -- front of the script at installation time, so we don't want
303 -- to wire-in our knowledge of $(PERL) on the host system here.
304 (split_prog, split_args)
305 | isWindowsHost = (perl_path, [Option split_script])
306 | otherwise = (split_script, [])
307 mkdll_prog <- getSetting "dllwrap command"
308 let mkdll_args = []
309
310 -- cpp is derived from gcc on all platforms
311 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
312 -- Config.hs one day.
313
314
315 -- Other things being equal, as and ld are simply gcc
316 gcc_link_args_str <- getSetting "C compiler link flags"
317 let as_prog = gcc_prog
318 as_args = gcc_args
319 ld_prog = gcc_prog
320 ld_args = gcc_args ++ map Option (words gcc_link_args_str)
321
322 -- We just assume on command line
323 lc_prog <- getSetting "LLVM llc command"
324 lo_prog <- getSetting "LLVM opt command"
325
326 let iserv_prog = libexec "ghc-iserv"
327
328 let platform = Platform {
329 platformArch = targetArch,
330 platformOS = targetOS,
331 platformWordSize = targetWordSize,
332 platformUnregisterised = targetUnregisterised,
333 platformHasGnuNonexecStack = targetHasGnuNonexecStack,
334 platformHasIdentDirective = targetHasIdentDirective,
335 platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols,
336 platformIsCrossCompiling = crossCompiling
337 }
338
339 return $ Settings {
340 sTargetPlatform = platform,
341 sTmpDir = normalise tmpdir,
342 sGhcUsagePath = ghc_usage_msg_path,
343 sGhciUsagePath = ghci_usage_msg_path,
344 sTopDir = top_dir,
345 sRawSettings = mySettings,
346 sExtraGccViaCFlags = words myExtraGccViaCFlags,
347 sSystemPackageConfig = pkgconfig_path,
348 sLdSupportsCompactUnwind = ldSupportsCompactUnwind,
349 sLdSupportsBuildId = ldSupportsBuildId,
350 sLdSupportsFilelist = ldSupportsFilelist,
351 sLdIsGnuLd = ldIsGnuLd,
352 sGccSupportsNoPie = gccSupportsNoPie,
353 sProgramName = "ghc",
354 sProjectVersion = cProjectVersion,
355 sPgm_L = unlit_path,
356 sPgm_P = (cpp_prog, cpp_args),
357 sPgm_F = "",
358 sPgm_c = (gcc_prog, gcc_args),
359 sPgm_s = (split_prog,split_args),
360 sPgm_a = (as_prog, as_args),
361 sPgm_l = (ld_prog, ld_args),
362 sPgm_dll = (mkdll_prog,mkdll_args),
363 sPgm_T = touch_path,
364 sPgm_windres = windres_path,
365 sPgm_libtool = libtool_path,
366 sPgm_lo = (lo_prog,[]),
367 sPgm_lc = (lc_prog,[]),
368 sPgm_i = iserv_prog,
369 sOpt_L = [],
370 sOpt_P = [],
371 sOpt_F = [],
372 sOpt_c = [],
373 sOpt_a = [],
374 sOpt_l = [],
375 sOpt_windres = [],
376 sOpt_lo = [],
377 sOpt_lc = [],
378 sOpt_i = [],
379 sPlatformConstants = platformConstants
380 }
381
382 -- returns a Unix-format path (relying on getBaseDir to do so too)
383 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
384 -> IO String -- TopDir (in Unix format '/' separated)
385 findTopDir (Just minusb) = return (normalise minusb)
386 findTopDir Nothing
387 = do -- Get directory of executable
388 maybe_exec_dir <- getBaseDir
389 case maybe_exec_dir of
390 -- "Just" on Windows, "Nothing" on unix
391 Nothing -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
392 Just dir -> return dir
393
394 {-
395 ************************************************************************
396 * *
397 \subsection{Running an external program}
398 * *
399 ************************************************************************
400 -}
401
402 runUnlit :: DynFlags -> [Option] -> IO ()
403 runUnlit dflags args = do
404 let prog = pgm_L dflags
405 opts = getOpts dflags opt_L
406 runSomething dflags "Literate pre-processor" prog
407 (map Option opts ++ args)
408
409 runCpp :: DynFlags -> [Option] -> IO ()
410 runCpp dflags args = do
411 let (p,args0) = pgm_P dflags
412 args1 = map Option (getOpts dflags opt_P)
413 args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]
414 ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]
415 mb_env <- getGccEnv args2
416 runSomethingFiltered dflags id "C pre-processor" p
417 (args0 ++ args1 ++ args2 ++ args) mb_env
418
419 runPp :: DynFlags -> [Option] -> IO ()
420 runPp dflags args = do
421 let prog = pgm_F dflags
422 opts = map Option (getOpts dflags opt_F)
423 runSomething dflags "Haskell pre-processor" prog (args ++ opts)
424
425 runCc :: DynFlags -> [Option] -> IO ()
426 runCc dflags args = do
427 let (p,args0) = pgm_c dflags
428 args1 = map Option (getOpts dflags opt_c)
429 args2 = args0 ++ args1 ++ args
430 mb_env <- getGccEnv args2
431 runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env
432 where
433 -- discard some harmless warnings from gcc that we can't turn off
434 cc_filter = unlines . doFilter . lines
435
436 {-
437 gcc gives warnings in chunks like so:
438 In file included from /foo/bar/baz.h:11,
439 from /foo/bar/baz2.h:22,
440 from wibble.c:33:
441 /foo/flibble:14: global register variable ...
442 /foo/flibble:15: warning: call-clobbered r...
443 We break it up into its chunks, remove any call-clobbered register
444 warnings from each chunk, and then delete any chunks that we have
445 emptied of warnings.
446 -}
447 doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
448 -- We can't assume that the output will start with an "In file inc..."
449 -- line, so we start off expecting a list of warnings rather than a
450 -- location stack.
451 chunkWarnings :: [String] -- The location stack to use for the next
452 -- list of warnings
453 -> [String] -- The remaining lines to look at
454 -> [([String], [String])]
455 chunkWarnings loc_stack [] = [(loc_stack, [])]
456 chunkWarnings loc_stack xs
457 = case break loc_stack_start xs of
458 (warnings, lss:xs') ->
459 case span loc_start_continuation xs' of
460 (lsc, xs'') ->
461 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
462 _ -> [(loc_stack, xs)]
463
464 filterWarnings :: [([String], [String])] -> [([String], [String])]
465 filterWarnings [] = []
466 -- If the warnings are already empty then we are probably doing
467 -- something wrong, so don't delete anything
468 filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
469 filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
470 [] -> filterWarnings zs
471 ys' -> (xs, ys') : filterWarnings zs
472
473 unChunkWarnings :: [([String], [String])] -> [String]
474 unChunkWarnings [] = []
475 unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
476
477 loc_stack_start s = "In file included from " `isPrefixOf` s
478 loc_start_continuation s = " from " `isPrefixOf` s
479 wantedWarning w
480 | "warning: call-clobbered register used" `isContainedIn` w = False
481 | otherwise = True
482
483 isContainedIn :: String -> String -> Bool
484 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
485
486 askCc :: DynFlags -> [Option] -> IO String
487 askCc dflags args = do
488 let (p,args0) = pgm_c dflags
489 args1 = map Option (getOpts dflags opt_c)
490 args2 = args0 ++ args1 ++ args
491 mb_env <- getGccEnv args2
492 runSomethingWith dflags "gcc" p args2 $ \real_args ->
493 readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
494
495 -- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
496 -- inherited from the parent process, and output to stderr is not captured.
497 readCreateProcessWithExitCode'
498 :: CreateProcess
499 -> IO (ExitCode, String) -- ^ stdout
500 readCreateProcessWithExitCode' proc = do
501 (_, Just outh, _, pid) <-
502 createProcess proc{ std_out = CreatePipe }
503
504 -- fork off a thread to start consuming the output
505 output <- hGetContents outh
506 outMVar <- newEmptyMVar
507 _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
508
509 -- wait on the output
510 takeMVar outMVar
511 hClose outh
512
513 -- wait on the process
514 ex <- waitForProcess pid
515
516 return (ex, output)
517
518 replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
519 replaceVar (var, value) env =
520 (var, value) : filter (\(var',_) -> var /= var') env
521
522 -- | Version of @System.Process.readProcessWithExitCode@ that takes a
523 -- key-value tuple to insert into the environment.
524 readProcessEnvWithExitCode
525 :: String -- ^ program path
526 -> [String] -- ^ program args
527 -> (String, String) -- ^ addition to the environment
528 -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
529 readProcessEnvWithExitCode prog args env_update = do
530 current_env <- getEnvironment
531 readCreateProcessWithExitCode (proc prog args) {
532 env = Just (replaceVar env_update current_env) } ""
533
534 -- Don't let gcc localize version info string, #8825
535 c_locale_env :: (String, String)
536 c_locale_env = ("LANGUAGE", "C")
537
538 -- If the -B<dir> option is set, add <dir> to PATH. This works around
539 -- a bug in gcc on Windows Vista where it can't find its auxiliary
540 -- binaries (see bug #1110).
541 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
542 getGccEnv opts =
543 if null b_dirs
544 then return Nothing
545 else do env <- getEnvironment
546 return (Just (map mangle_path env))
547 where
548 (b_dirs, _) = partitionWith get_b_opt opts
549
550 get_b_opt (Option ('-':'B':dir)) = Left dir
551 get_b_opt other = Right other
552
553 mangle_path (path,paths) | map toUpper path == "PATH"
554 = (path, '\"' : head b_dirs ++ "\";" ++ paths)
555 mangle_path other = other
556
557 runSplit :: DynFlags -> [Option] -> IO ()
558 runSplit dflags args = do
559 let (p,args0) = pgm_s dflags
560 runSomething dflags "Splitter" p (args0++args)
561
562 runAs :: DynFlags -> [Option] -> IO ()
563 runAs dflags args = do
564 let (p,args0) = pgm_a dflags
565 args1 = map Option (getOpts dflags opt_a)
566 args2 = args0 ++ args1 ++ args
567 mb_env <- getGccEnv args2
568 runSomethingFiltered dflags id "Assembler" p args2 mb_env
569
570 -- | Run the LLVM Optimiser
571 runLlvmOpt :: DynFlags -> [Option] -> IO ()
572 runLlvmOpt dflags args = do
573 let (p,args0) = pgm_lo dflags
574 args1 = map Option (getOpts dflags opt_lo)
575 runSomething dflags "LLVM Optimiser" p (args0 ++ args1 ++ args)
576
577 -- | Run the LLVM Compiler
578 runLlvmLlc :: DynFlags -> [Option] -> IO ()
579 runLlvmLlc dflags args = do
580 let (p,args0) = pgm_lc dflags
581 args1 = map Option (getOpts dflags opt_lc)
582 runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)
583
584 -- | Run the clang compiler (used as an assembler for the LLVM
585 -- backend on OS X as LLVM doesn't support the OS X system
586 -- assembler)
587 runClang :: DynFlags -> [Option] -> IO ()
588 runClang dflags args = do
589 -- we simply assume its available on the PATH
590 let clang = "clang"
591 -- be careful what options we call clang with
592 -- see #5903 and #7617 for bugs caused by this.
593 (_,args0) = pgm_a dflags
594 args1 = map Option (getOpts dflags opt_a)
595 args2 = args0 ++ args1 ++ args
596 mb_env <- getGccEnv args2
597 Exception.catch (do
598 runSomethingFiltered dflags id "Clang (Assembler)" clang args2 mb_env
599 )
600 (\(err :: SomeException) -> do
601 errorMsg dflags $
602 text ("Error running clang! you need clang installed to use the" ++
603 " LLVM backend") $+$
604 text "(or GHC tried to execute clang incorrectly)"
605 throwIO err
606 )
607
608 -- | Figure out which version of LLVM we are running this session
609 figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int))
610 figureLlvmVersion dflags = do
611 let (pgm,opts) = pgm_lc dflags
612 args = filter notNull (map showOpt opts)
613 -- we grab the args even though they should be useless just in
614 -- case the user is using a customised 'llc' that requires some
615 -- of the options they've specified. llc doesn't care what other
616 -- options are specified when '-version' is used.
617 args' = args ++ ["-version"]
618 ver <- catchIO (do
619 (pin, pout, perr, _) <- runInteractiveProcess pgm args'
620 Nothing Nothing
621 {- > llc -version
622 LLVM (http://llvm.org/):
623 LLVM version 3.5.2
624 ...
625 -}
626 hSetBinaryMode pout False
627 _ <- hGetLine pout
628 vline <- dropWhile (not . isDigit) `fmap` hGetLine pout
629 v <- case span (/= '.') vline of
630 ("",_) -> fail "no digits!"
631 (x,y) -> return (read x
632 , read $ takeWhile isDigit $ drop 1 y)
633
634 hClose pin
635 hClose pout
636 hClose perr
637 return $ Just v
638 )
639 (\err -> do
640 debugTraceMsg dflags 2
641 (text "Error (figuring out LLVM version):" <+>
642 text (show err))
643 errorMsg dflags $ vcat
644 [ text "Warning:", nest 9 $
645 text "Couldn't figure out LLVM version!" $$
646 text ("Make sure you have installed LLVM " ++
647 llvmVersionStr supportedLlvmVersion) ]
648 return Nothing)
649 return ver
650
651 {- Note [Windows stack usage]
652
653 See: Trac #8870 (and #8834 for related info) and #12186
654
655 On Windows, occasionally we need to grow the stack. In order to do
656 this, we would normally just bump the stack pointer - but there's a
657 catch on Windows.
658
659 If the stack pointer is bumped by more than a single page, then the
660 pages between the initial pointer and the resulting location must be
661 properly committed by the Windows virtual memory subsystem. This is
662 only needed in the event we bump by more than one page (i.e 4097 bytes
663 or more).
664
665 Windows compilers solve this by emitting a call to a special function
666 called _chkstk, which does this committing of the pages for you.
667
668 The reason this was causing a segfault was because due to the fact the
669 new code generator tends to generate larger functions, we needed more
670 stack space in GHC itself. In the x86 codegen, we needed approximately
671 ~12kb of stack space in one go, which caused the process to segfault,
672 as the intervening pages were not committed.
673
674 GCC can emit such a check for us automatically but only when the flag
675 -fstack-check is used.
676
677 See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html
678 for more information.
679
680 -}
681
682 {- Note [Run-time linker info]
683
684 See also: Trac #5240, Trac #6063, Trac #10110
685
686 Before 'runLink', we need to be sure to get the relevant information
687 about the linker we're using at runtime to see if we need any extra
688 options. For example, GNU ld requires '--reduce-memory-overheads' and
689 '--hash-size=31' in order to use reasonable amounts of memory (see
690 trac #5240.) But this isn't supported in GNU gold.
691
692 Generally, the linker changing from what was detected at ./configure
693 time has always been possible using -pgml, but on Linux it can happen
694 'transparently' by installing packages like binutils-gold, which
695 change what /usr/bin/ld actually points to.
696
697 Clang vs GCC notes:
698
699 For gcc, 'gcc -Wl,--version' gives a bunch of output about how to
700 invoke the linker before the version information string. For 'clang',
701 the version information for 'ld' is all that's output. For this
702 reason, we typically need to slurp up all of the standard error output
703 and look through it.
704
705 Other notes:
706
707 We cache the LinkerInfo inside DynFlags, since clients may link
708 multiple times. The definition of LinkerInfo is there to avoid a
709 circular dependency.
710
711 -}
712
713 {- Note [ELF needed shared libs]
714
715 Some distributions change the link editor's default handling of
716 ELF DT_NEEDED tags to include only those shared objects that are
717 needed to resolve undefined symbols. For Template Haskell we need
718 the last temporary shared library also if it is not needed for the
719 currently linked temporary shared library. We specify --no-as-needed
720 to override the default. This flag exists in GNU ld and GNU gold.
721
722 The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
723 (Mach-O) the flag is not needed.
724
725 -}
726
727 {- Note [Windows static libGCC]
728
729 The GCC versions being upgraded to in #10726 are configured with
730 dynamic linking of libgcc supported. This results in libgcc being
731 linked dynamically when a shared library is created.
732
733 This introduces thus an extra dependency on GCC dll that was not
734 needed before by shared libraries created with GHC. This is a particular
735 issue on Windows because you get a non-obvious error due to this missing
736 dependency. This dependent dll is also not commonly on your path.
737
738 For this reason using the static libgcc is preferred as it preserves
739 the same behaviour that existed before. There are however some very good
740 reasons to have the shared version as well as described on page 181 of
741 https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :
742
743 "There are several situations in which an application should use the
744 shared ‘libgcc’ instead of the static version. The most common of these
745 is when the application wishes to throw and catch exceptions across different
746 shared libraries. In that case, each of the libraries as well as the application
747 itself should use the shared ‘libgcc’. "
748
749 -}
750
751 neededLinkArgs :: LinkerInfo -> [Option]
752 neededLinkArgs (GnuLD o) = o
753 neededLinkArgs (GnuGold o) = o
754 neededLinkArgs (DarwinLD o) = o
755 neededLinkArgs (SolarisLD o) = o
756 neededLinkArgs (AixLD o) = o
757 neededLinkArgs UnknownLD = []
758
759 -- Grab linker info and cache it in DynFlags.
760 getLinkerInfo :: DynFlags -> IO LinkerInfo
761 getLinkerInfo dflags = do
762 info <- readIORef (rtldInfo dflags)
763 case info of
764 Just v -> return v
765 Nothing -> do
766 v <- getLinkerInfo' dflags
767 writeIORef (rtldInfo dflags) (Just v)
768 return v
769
770 -- See Note [Run-time linker info].
771 getLinkerInfo' :: DynFlags -> IO LinkerInfo
772 getLinkerInfo' dflags = do
773 let platform = targetPlatform dflags
774 os = platformOS platform
775 (pgm,args0) = pgm_l dflags
776 args1 = map Option (getOpts dflags opt_l)
777 args2 = args0 ++ args1
778 args3 = filter notNull (map showOpt args2)
779
780 -- Try to grab the info from the process output.
781 parseLinkerInfo stdo _stde _exitc
782 | any ("GNU ld" `isPrefixOf`) stdo =
783 -- GNU ld specifically needs to use less memory. This especially
784 -- hurts on small object files. Trac #5240.
785 -- Set DT_NEEDED for all shared libraries. Trac #10110.
786 -- TODO: Investigate if these help or hurt when using split sections.
787 return (GnuLD $ map Option ["-Wl,--hash-size=31",
788 "-Wl,--reduce-memory-overheads",
789 -- ELF specific flag
790 -- see Note [ELF needed shared libs]
791 "-Wl,--no-as-needed"])
792
793 | any ("GNU gold" `isPrefixOf`) stdo =
794 -- GNU gold only needs --no-as-needed. Trac #10110.
795 -- ELF specific flag, see Note [ELF needed shared libs]
796 return (GnuGold [Option "-Wl,--no-as-needed"])
797
798 -- Unknown linker.
799 | otherwise = fail "invalid --version output, or linker is unsupported"
800
801 -- Process the executable call
802 info <- catchIO (do
803 case os of
804 OSSolaris2 ->
805 -- Solaris uses its own Solaris linker. Even all
806 -- GNU C are recommended to configure with Solaris
807 -- linker instead of using GNU binutils linker. Also
808 -- all GCC distributed with Solaris follows this rule
809 -- precisely so we assume here, the Solaris linker is
810 -- used.
811 return $ SolarisLD []
812 OSAIX ->
813 -- IBM AIX uses its own non-binutils linker as well
814 return $ AixLD []
815 OSDarwin ->
816 -- Darwin has neither GNU Gold or GNU LD, but a strange linker
817 -- that doesn't support --version. We can just assume that's
818 -- what we're using.
819 return $ DarwinLD []
820 OSiOS ->
821 -- Ditto for iOS
822 return $ DarwinLD []
823 OSMinGW32 ->
824 -- GHC doesn't support anything but GNU ld on Windows anyway.
825 -- Process creation is also fairly expensive on win32, so
826 -- we short-circuit here.
827 return $ GnuLD $ map Option
828 [ -- Reduce ld memory usage
829 "-Wl,--hash-size=31"
830 , "-Wl,--reduce-memory-overheads"
831 -- Emit gcc stack checks
832 -- Note [Windows stack usage]
833 , "-fstack-check"
834 -- Force static linking of libGCC
835 -- Note [Windows static libGCC]
836 , "-static-libgcc" ]
837 _ -> do
838 -- In practice, we use the compiler as the linker here. Pass
839 -- -Wl,--version to get linker version info.
840 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm
841 (["-Wl,--version"] ++ args3)
842 c_locale_env
843 -- Split the output by lines to make certain kinds
844 -- of processing easier. In particular, 'clang' and 'gcc'
845 -- have slightly different outputs for '-Wl,--version', but
846 -- it's still easy to figure out.
847 parseLinkerInfo (lines stdo) (lines stde) exitc
848 )
849 (\err -> do
850 debugTraceMsg dflags 2
851 (text "Error (figuring out linker information):" <+>
852 text (show err))
853 errorMsg dflags $ hang (text "Warning:") 9 $
854 text "Couldn't figure out linker information!" $$
855 text "Make sure you're using GNU ld, GNU gold" <+>
856 text "or the built in OS X linker, etc."
857 return UnknownLD)
858 return info
859
860 -- Grab compiler info and cache it in DynFlags.
861 getCompilerInfo :: DynFlags -> IO CompilerInfo
862 getCompilerInfo dflags = do
863 info <- readIORef (rtccInfo dflags)
864 case info of
865 Just v -> return v
866 Nothing -> do
867 v <- getCompilerInfo' dflags
868 writeIORef (rtccInfo dflags) (Just v)
869 return v
870
871 -- See Note [Run-time linker info].
872 getCompilerInfo' :: DynFlags -> IO CompilerInfo
873 getCompilerInfo' dflags = do
874 let (pgm,_) = pgm_c dflags
875 -- Try to grab the info from the process output.
876 parseCompilerInfo _stdo stde _exitc
877 -- Regular GCC
878 | any ("gcc version" `isInfixOf`) stde =
879 return GCC
880 -- Regular clang
881 | any ("clang version" `isInfixOf`) stde =
882 return Clang
883 -- XCode 5.1 clang
884 | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
885 return AppleClang51
886 -- XCode 5 clang
887 | any ("Apple LLVM version" `isPrefixOf`) stde =
888 return AppleClang
889 -- XCode 4.1 clang
890 | any ("Apple clang version" `isPrefixOf`) stde =
891 return AppleClang
892 -- Unknown linker.
893 | otherwise = fail "invalid -v output, or compiler is unsupported"
894
895 -- Process the executable call
896 info <- catchIO (do
897 (exitc, stdo, stde) <-
898 readProcessEnvWithExitCode pgm ["-v"] c_locale_env
899 -- Split the output by lines to make certain kinds
900 -- of processing easier.
901 parseCompilerInfo (lines stdo) (lines stde) exitc
902 )
903 (\err -> do
904 debugTraceMsg dflags 2
905 (text "Error (figuring out C compiler information):" <+>
906 text (show err))
907 errorMsg dflags $ hang (text "Warning:") 9 $
908 text "Couldn't figure out C compiler information!" $$
909 text "Make sure you're using GNU gcc, or clang"
910 return UnknownCC)
911 return info
912
913 runLink :: DynFlags -> [Option] -> IO ()
914 runLink dflags args = do
915 -- See Note [Run-time linker info]
916 linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
917 let (p,args0) = pgm_l dflags
918 args1 = map Option (getOpts dflags opt_l)
919 args2 = args0 ++ linkargs ++ args1 ++ args
920 mb_env <- getGccEnv args2
921 runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env
922 where
923 ld_filter = case (platformOS (targetPlatform dflags)) of
924 OSSolaris2 -> sunos_ld_filter
925 _ -> id
926 {-
927 SunOS/Solaris ld emits harmless warning messages about unresolved
928 symbols in case of compiling into shared library when we do not
929 link against all the required libs. That is the case of GHC which
930 does not link against RTS library explicitly in order to be able to
931 choose the library later based on binary application linking
932 parameters. The warnings look like:
933
934 Undefined first referenced
935 symbol in file
936 stg_ap_n_fast ./T2386_Lib.o
937 stg_upd_frame_info ./T2386_Lib.o
938 templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
939 templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
940 templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
941 templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
942 newCAF ./T2386_Lib.o
943 stg_bh_upd_frame_info ./T2386_Lib.o
944 stg_ap_ppp_fast ./T2386_Lib.o
945 templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
946 stg_ap_p_fast ./T2386_Lib.o
947 stg_ap_pp_fast ./T2386_Lib.o
948 ld: warning: symbol referencing errors
949
950 this is actually coming from T2386 testcase. The emitting of those
951 warnings is also a reason why so many TH testcases fail on Solaris.
952
953 Following filter code is SunOS/Solaris linker specific and should
954 filter out only linker warnings. Please note that the logic is a
955 little bit more complex due to the simple reason that we need to preserve
956 any other linker emitted messages. If there are any. Simply speaking
957 if we see "Undefined" and later "ld: warning:..." then we omit all
958 text between (including) the marks. Otherwise we copy the whole output.
959 -}
960 sunos_ld_filter :: String -> String
961 sunos_ld_filter = unlines . sunos_ld_filter' . lines
962 sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
963 then (ld_prefix x) ++ (ld_postfix x)
964 else x
965 breakStartsWith x y = break (isPrefixOf x) y
966 ld_prefix = fst . breakStartsWith "Undefined"
967 undefined_found = not . null . snd . breakStartsWith "Undefined"
968 ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
969 ld_postfix = tail . snd . ld_warn_break
970 ld_warning_found = not . null . snd . ld_warn_break
971
972
973 runLibtool :: DynFlags -> [Option] -> IO ()
974 runLibtool dflags args = do
975 linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
976 let args1 = map Option (getOpts dflags opt_l)
977 args2 = [Option "-static"] ++ args1 ++ args ++ linkargs
978 libtool = pgm_libtool dflags
979 mb_env <- getGccEnv args2
980 runSomethingFiltered dflags id "Linker" libtool args2 mb_env
981
982 runMkDLL :: DynFlags -> [Option] -> IO ()
983 runMkDLL dflags args = do
984 let (p,args0) = pgm_dll dflags
985 args1 = args0 ++ args
986 mb_env <- getGccEnv (args0++args)
987 runSomethingFiltered dflags id "Make DLL" p args1 mb_env
988
989 runWindres :: DynFlags -> [Option] -> IO ()
990 runWindres dflags args = do
991 let (gcc, gcc_args) = pgm_c dflags
992 windres = pgm_windres dflags
993 opts = map Option (getOpts dflags opt_windres)
994 quote x = "\"" ++ x ++ "\""
995 args' = -- If windres.exe and gcc.exe are in a directory containing
996 -- spaces then windres fails to run gcc. We therefore need
997 -- to tell it what command to use...
998 Option ("--preprocessor=" ++
999 unwords (map quote (gcc :
1000 map showOpt gcc_args ++
1001 map showOpt opts ++
1002 ["-E", "-xc", "-DRC_INVOKED"])))
1003 -- ...but if we do that then if windres calls popen then
1004 -- it can't understand the quoting, so we have to use
1005 -- --use-temp-file so that it interprets it correctly.
1006 -- See #1828.
1007 : Option "--use-temp-file"
1008 : args
1009 mb_env <- getGccEnv gcc_args
1010 runSomethingFiltered dflags id "Windres" windres args' mb_env
1011
1012 touch :: DynFlags -> String -> String -> IO ()
1013 touch dflags purpose arg =
1014 runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
1015
1016 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
1017 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
1018
1019 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
1020 -> IO ()
1021 copyWithHeader dflags purpose maybe_header from to = do
1022 showPass dflags purpose
1023
1024 hout <- openBinaryFile to WriteMode
1025 hin <- openBinaryFile from ReadMode
1026 ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
1027 maybe (return ()) (header hout) maybe_header
1028 hPutStr hout ls
1029 hClose hout
1030 hClose hin
1031 where
1032 -- write the header string in UTF-8. The header is something like
1033 -- {-# LINE "foo.hs" #-}
1034 -- and we want to make sure a Unicode filename isn't mangled.
1035 header h str = do
1036 hSetEncoding h utf8
1037 hPutStr h str
1038 hSetBinaryMode h True
1039
1040
1041
1042 {-
1043 ************************************************************************
1044 * *
1045 \subsection{Managing temporary files
1046 * *
1047 ************************************************************************
1048 -}
1049
1050 cleanTempDirs :: DynFlags -> IO ()
1051 cleanTempDirs dflags
1052 = unless (gopt Opt_KeepTmpFiles dflags)
1053 $ mask_
1054 $ do let ref = dirsToClean dflags
1055 ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)
1056 removeTmpDirs dflags (Map.elems ds)
1057
1058 cleanTempFiles :: DynFlags -> IO ()
1059 cleanTempFiles dflags
1060 = unless (gopt Opt_KeepTmpFiles dflags)
1061 $ mask_
1062 $ do let ref = filesToClean dflags
1063 fs <- atomicModifyIORef' ref $ \fs -> ([],fs)
1064 removeTmpFiles dflags fs
1065
1066 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
1067 cleanTempFilesExcept dflags dont_delete
1068 = unless (gopt Opt_KeepTmpFiles dflags)
1069 $ mask_
1070 $ do let ref = filesToClean dflags
1071 to_delete <- atomicModifyIORef' ref $ \files ->
1072 let res@(_to_keep, _to_delete) =
1073 partition (`Set.member` dont_delete_set) files
1074 in res
1075 removeTmpFiles dflags to_delete
1076 where dont_delete_set = Set.fromList dont_delete
1077
1078
1079 -- Return a unique numeric temp file suffix
1080 newTempSuffix :: DynFlags -> IO Int
1081 newTempSuffix dflags = atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)
1082
1083 -- Find a temporary name that doesn't already exist.
1084 newTempName :: DynFlags -> Suffix -> IO FilePath
1085 newTempName dflags extn
1086 = do d <- getTempDir dflags
1087 findTempName (d </> "ghc_") -- See Note [Deterministic base name]
1088 where
1089 findTempName :: FilePath -> IO FilePath
1090 findTempName prefix
1091 = do n <- newTempSuffix dflags
1092 let filename = prefix ++ show n <.> extn
1093 b <- doesFileExist filename
1094 if b then findTempName prefix
1095 else do -- clean it up later
1096 consIORef (filesToClean dflags) filename
1097 return filename
1098
1099 newTempLibName :: DynFlags -> Suffix -> IO (FilePath, FilePath, String)
1100 newTempLibName dflags extn
1101 = do d <- getTempDir dflags
1102 findTempName d ("ghc_")
1103 where
1104 findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)
1105 findTempName dir prefix
1106 = do n <- newTempSuffix dflags -- See Note [Deterministic base name]
1107 let libname = prefix ++ show n
1108 filename = dir </> "lib" ++ libname <.> extn
1109 b <- doesFileExist filename
1110 if b then findTempName dir prefix
1111 else do -- clean it up later
1112 consIORef (filesToClean dflags) filename
1113 return (filename, dir, libname)
1114
1115
1116 -- Return our temporary directory within tmp_dir, creating one if we
1117 -- don't have one yet.
1118 getTempDir :: DynFlags -> IO FilePath
1119 getTempDir dflags = do
1120 mapping <- readIORef dir_ref
1121 case Map.lookup tmp_dir mapping of
1122 Nothing -> do
1123 pid <- getProcessID
1124 let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"
1125 mask_ $ mkTempDir prefix
1126 Just dir -> return dir
1127 where
1128 tmp_dir = tmpDir dflags
1129 dir_ref = dirsToClean dflags
1130
1131 mkTempDir :: FilePath -> IO FilePath
1132 mkTempDir prefix = do
1133 n <- newTempSuffix dflags
1134 let our_dir = prefix ++ show n
1135
1136 -- 1. Speculatively create our new directory.
1137 createDirectory our_dir
1138
1139 -- 2. Update the dirsToClean mapping unless an entry already exists
1140 -- (i.e. unless another thread beat us to it).
1141 their_dir <- atomicModifyIORef' dir_ref $ \mapping ->
1142 case Map.lookup tmp_dir mapping of
1143 Just dir -> (mapping, Just dir)
1144 Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing)
1145
1146 -- 3. If there was an existing entry, return it and delete the
1147 -- directory we created. Otherwise return the directory we created.
1148 case their_dir of
1149 Nothing -> do
1150 debugTraceMsg dflags 2 $
1151 text "Created temporary directory:" <+> text our_dir
1152 return our_dir
1153 Just dir -> do
1154 removeDirectory our_dir
1155 return dir
1156 `catchIO` \e -> if isAlreadyExistsError e
1157 then mkTempDir prefix else ioError e
1158
1159 -- Note [Deterministic base name]
1160 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1161 --
1162 -- The filename of temporary files, especially the basename of C files, can end
1163 -- up in the output in some form, e.g. as part of linker debug information. In the
1164 -- interest of bit-wise exactly reproducible compilation (#4012), the basename of
1165 -- the temporary file no longer contains random information (it used to contain
1166 -- the process id).
1167 --
1168 -- This is ok, as the temporary directory used contains the pid (see getTempDir).
1169
1170 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
1171 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
1172 addFilesToClean dflags new_files
1173 = atomicModifyIORef' (filesToClean dflags) $ \files -> (new_files++files, ())
1174
1175 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
1176 removeTmpDirs dflags ds
1177 = traceCmd dflags "Deleting temp dirs"
1178 ("Deleting: " ++ unwords ds)
1179 (mapM_ (removeWith dflags removeDirectory) ds)
1180
1181 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
1182 removeTmpFiles dflags fs
1183 = warnNon $
1184 traceCmd dflags "Deleting temp files"
1185 ("Deleting: " ++ unwords deletees)
1186 (mapM_ (removeWith dflags removeFile) deletees)
1187 where
1188 -- Flat out refuse to delete files that are likely to be source input
1189 -- files (is there a worse bug than having a compiler delete your source
1190 -- files?)
1191 --
1192 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
1193 -- the condition.
1194 warnNon act
1195 | null non_deletees = act
1196 | otherwise = do
1197 putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
1198 act
1199
1200 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
1201
1202 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
1203 removeWith dflags remover f = remover f `catchIO`
1204 (\e ->
1205 let msg = if isDoesNotExistError e
1206 then text "Warning: deleting non-existent" <+> text f
1207 else text "Warning: exception raised when deleting"
1208 <+> text f <> colon
1209 $$ text (show e)
1210 in debugTraceMsg dflags 2 msg
1211 )
1212
1213 -----------------------------------------------------------------------------
1214 -- Running an external program
1215
1216 runSomething :: DynFlags
1217 -> String -- For -v message
1218 -> String -- Command name (possibly a full path)
1219 -- assumed already dos-ified
1220 -> [Option] -- Arguments
1221 -- runSomething will dos-ify them
1222 -> IO ()
1223
1224 runSomething dflags phase_name pgm args =
1225 runSomethingFiltered dflags id phase_name pgm args Nothing
1226
1227 -- | Run a command, placing the arguments in an external response file.
1228 --
1229 -- This command is used in order to avoid overlong command line arguments on
1230 -- Windows. The command line arguments are first written to an external,
1231 -- temporary response file, and then passed to the linker via @filepath.
1232 -- response files for passing them in. See:
1233 --
1234 -- https://gcc.gnu.org/wiki/Response_Files
1235 -- https://ghc.haskell.org/trac/ghc/ticket/10777
1236 runSomethingResponseFile
1237 :: DynFlags -> (String->String) -> String -> String -> [Option]
1238 -> Maybe [(String,String)] -> IO ()
1239
1240 runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
1241 runSomethingWith dflags phase_name pgm args $ \real_args -> do
1242 fp <- getResponseFile real_args
1243 let args = ['@':fp]
1244 r <- builderMainLoop dflags filter_fn pgm args mb_env
1245 return (r,())
1246 where
1247 getResponseFile args = do
1248 fp <- newTempName dflags "rsp"
1249 withFile fp WriteMode $ \h -> do
1250 #if defined(mingw32_HOST_OS)
1251 hSetEncoding h latin1
1252 #else
1253 hSetEncoding h utf8
1254 #endif
1255 hPutStr h $ unlines $ map escape args
1256 return fp
1257
1258 -- Note: Response files have backslash-escaping, double quoting, and are
1259 -- whitespace separated (some implementations use newline, others any
1260 -- whitespace character). Therefore, escape any backslashes, newlines, and
1261 -- double quotes in the argument, and surround the content with double
1262 -- quotes.
1263 --
1264 -- Another possibility that could be considered would be to convert
1265 -- backslashes in the argument to forward slashes. This would generally do
1266 -- the right thing, since backslashes in general only appear in arguments
1267 -- as part of file paths on Windows, and the forward slash is accepted for
1268 -- those. However, escaping is more reliable, in case somehow a backslash
1269 -- appears in a non-file.
1270 escape x = concat
1271 [ "\""
1272 , concatMap
1273 (\c ->
1274 case c of
1275 '\\' -> "\\\\"
1276 '\n' -> "\\n"
1277 '\"' -> "\\\""
1278 _ -> [c])
1279 x
1280 , "\""
1281 ]
1282
1283 runSomethingFiltered
1284 :: DynFlags -> (String->String) -> String -> String -> [Option]
1285 -> Maybe [(String,String)] -> IO ()
1286
1287 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
1288 runSomethingWith dflags phase_name pgm args $ \real_args -> do
1289 r <- builderMainLoop dflags filter_fn pgm real_args mb_env
1290 return (r,())
1291
1292 runSomethingWith
1293 :: DynFlags -> String -> String -> [Option]
1294 -> ([String] -> IO (ExitCode, a))
1295 -> IO a
1296
1297 runSomethingWith dflags phase_name pgm args io = do
1298 let real_args = filter notNull (map showOpt args)
1299 cmdLine = showCommandForUser pgm real_args
1300 traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
1301
1302 handleProc :: String -> String -> IO (ExitCode, r) -> IO r
1303 handleProc pgm phase_name proc = do
1304 (rc, r) <- proc `catchIO` handler
1305 case rc of
1306 ExitSuccess{} -> return r
1307 ExitFailure n -> throwGhcExceptionIO (
1308 ProgramError ("`" ++ takeFileName pgm ++ "'" ++
1309 " failed in phase `" ++ phase_name ++ "'." ++
1310 " (Exit code: " ++ show n ++ ")"))
1311 where
1312 handler err =
1313 if IO.isDoesNotExistError err
1314 then does_not_exist
1315 else throwGhcExceptionIO (ProgramError $ show err)
1316
1317 does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
1318
1319
1320 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
1321 -> [String] -> Maybe [(String, String)]
1322 -> IO ExitCode
1323 builderMainLoop dflags filter_fn pgm real_args mb_env = do
1324 chan <- newChan
1325 (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
1326
1327 -- and run a loop piping the output from the compiler to the log_action in DynFlags
1328 hSetBuffering hStdOut LineBuffering
1329 hSetBuffering hStdErr LineBuffering
1330 _ <- forkIO (readerProc chan hStdOut filter_fn)
1331 _ <- forkIO (readerProc chan hStdErr filter_fn)
1332 -- we don't want to finish until 2 streams have been completed
1333 -- (stdout and stderr)
1334 -- nor until 1 exit code has been retrieved.
1335 rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
1336 -- after that, we're done here.
1337 hClose hStdIn
1338 hClose hStdOut
1339 hClose hStdErr
1340 return rc
1341 where
1342 -- status starts at zero, and increments each time either
1343 -- a reader process gets EOF, or the build proc exits. We wait
1344 -- for all of these to happen (status==3).
1345 -- ToDo: we should really have a contingency plan in case any of
1346 -- the threads dies, such as a timeout.
1347 loop _ _ 0 0 exitcode = return exitcode
1348 loop chan hProcess t p exitcode = do
1349 mb_code <- if p > 0
1350 then getProcessExitCode hProcess
1351 else return Nothing
1352 case mb_code of
1353 Just code -> loop chan hProcess t (p-1) code
1354 Nothing
1355 | t > 0 -> do
1356 msg <- readChan chan
1357 case msg of
1358 BuildMsg msg -> do
1359 log_action dflags dflags NoReason SevInfo noSrcSpan
1360 (defaultUserStyle dflags) msg
1361 loop chan hProcess t p exitcode
1362 BuildError loc msg -> do
1363 log_action dflags dflags NoReason SevError (mkSrcSpan loc loc)
1364 (defaultUserStyle dflags) msg
1365 loop chan hProcess t p exitcode
1366 EOF ->
1367 loop chan hProcess (t-1) p exitcode
1368 | otherwise -> loop chan hProcess t p exitcode
1369
1370 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
1371 readerProc chan hdl filter_fn =
1372 (do str <- hGetContents hdl
1373 loop (linesPlatform (filter_fn str)) Nothing)
1374 `finally`
1375 writeChan chan EOF
1376 -- ToDo: check errors more carefully
1377 -- ToDo: in the future, the filter should be implemented as
1378 -- a stream transformer.
1379 where
1380 loop [] Nothing = return ()
1381 loop [] (Just err) = writeChan chan err
1382 loop (l:ls) in_err =
1383 case in_err of
1384 Just err@(BuildError srcLoc msg)
1385 | leading_whitespace l -> do
1386 loop ls (Just (BuildError srcLoc (msg $$ text l)))
1387 | otherwise -> do
1388 writeChan chan err
1389 checkError l ls
1390 Nothing -> do
1391 checkError l ls
1392 _ -> panic "readerProc/loop"
1393
1394 checkError l ls
1395 = case parseError l of
1396 Nothing -> do
1397 writeChan chan (BuildMsg (text l))
1398 loop ls Nothing
1399 Just (file, lineNum, colNum, msg) -> do
1400 let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
1401 loop ls (Just (BuildError srcLoc (text msg)))
1402
1403 leading_whitespace [] = False
1404 leading_whitespace (x:_) = isSpace x
1405
1406 parseError :: String -> Maybe (String, Int, Int, String)
1407 parseError s0 = case breakColon s0 of
1408 Just (filename, s1) ->
1409 case breakIntColon s1 of
1410 Just (lineNum, s2) ->
1411 case breakIntColon s2 of
1412 Just (columnNum, s3) ->
1413 Just (filename, lineNum, columnNum, s3)
1414 Nothing ->
1415 Just (filename, lineNum, 0, s2)
1416 Nothing -> Nothing
1417 Nothing -> Nothing
1418
1419 breakColon :: String -> Maybe (String, String)
1420 breakColon xs = case break (':' ==) xs of
1421 (ys, _:zs) -> Just (ys, zs)
1422 _ -> Nothing
1423
1424 breakIntColon :: String -> Maybe (Int, String)
1425 breakIntColon xs = case break (':' ==) xs of
1426 (ys, _:zs)
1427 | not (null ys) && all isAscii ys && all isDigit ys ->
1428 Just (read ys, zs)
1429 _ -> Nothing
1430
1431 data BuildMessage
1432 = BuildMsg !SDoc
1433 | BuildError !SrcLoc !SDoc
1434 | EOF
1435
1436 traceCmd :: DynFlags -> String -> String -> IO a -> IO a
1437 -- trace the command (at two levels of verbosity)
1438 traceCmd dflags phase_name cmd_line action
1439 = do { let verb = verbosity dflags
1440 ; showPass dflags phase_name
1441 ; debugTraceMsg dflags 3 (text cmd_line)
1442 ; case flushErr dflags of
1443 FlushErr io -> io
1444
1445 -- And run it!
1446 ; action `catchIO` handle_exn verb
1447 }
1448 where
1449 handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
1450 ; debugTraceMsg dflags 2 (text "Failed:" <+> text cmd_line <+> text (show exn))
1451 ; throwGhcExceptionIO (ProgramError (show exn))}
1452
1453 {-
1454 ************************************************************************
1455 * *
1456 \subsection{Support code}
1457 * *
1458 ************************************************************************
1459 -}
1460
1461 -----------------------------------------------------------------------------
1462 -- Define getBaseDir :: IO (Maybe String)
1463
1464 getBaseDir :: IO (Maybe String)
1465 #if defined(mingw32_HOST_OS)
1466 -- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe,
1467 -- return the path $(stuff)/lib.
1468 getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
1469 where
1470 try_size size = allocaArray (fromIntegral size) $ \buf -> do
1471 ret <- c_GetModuleFileName nullPtr buf size
1472 case ret of
1473 0 -> return Nothing
1474 _ | ret < size -> do path <- peekCWString buf
1475 real <- getFinalPath path -- try to resolve symlinks paths
1476 return $ (Just . rootDir . sanitize . maybe path id) real
1477 | otherwise -> try_size (size * 2)
1478
1479 -- getFinalPath returns paths in full raw form.
1480 -- Unfortunately GHC isn't set up to handle these
1481 -- So if the call succeeded, we need to drop the
1482 -- \\?\ prefix.
1483 sanitize s = if "\\\\?\\" `isPrefixOf` s
1484 then drop 4 s
1485 else s
1486
1487 rootDir s = case splitFileName $ normalise s of
1488 (d, ghc_exe)
1489 | lower ghc_exe `elem` ["ghc.exe",
1490 "ghc-stage1.exe",
1491 "ghc-stage2.exe",
1492 "ghc-stage3.exe"] ->
1493 case splitFileName $ takeDirectory d of
1494 -- ghc is in $topdir/bin/ghc.exe
1495 (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
1496 _ -> fail
1497 _ -> fail
1498 where fail = panic ("can't decompose ghc.exe path: " ++ show s)
1499 lower = map toLower
1500
1501 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
1502 c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1503
1504 -- Attempt to resolve symlinks in order to find the actual location GHC
1505 -- is located at. See Trac #11759.
1506 getFinalPath :: FilePath -> IO (Maybe FilePath)
1507 getFinalPath name = do
1508 dllHwnd <- failIfNull "LoadLibray" $ loadLibrary "kernel32.dll"
1509 -- Note: The API GetFinalPathNameByHandleW is only available starting from Windows Vista.
1510 -- This means that we can't bind directly to it since it may be missing.
1511 -- Instead try to find it's address at runtime and if we don't succeed consider the
1512 -- function failed.
1513 addr_m <- (fmap Just $ failIfNull "getProcAddress" $ getProcAddress dllHwnd "GetFinalPathNameByHandleW")
1514 `catch` (\(_ :: SomeException) -> return Nothing)
1515 case addr_m of
1516 Nothing -> return Nothing
1517 Just addr -> do handle <- failIf (==iNVALID_HANDLE_VALUE) "CreateFile"
1518 $ createFile name
1519 gENERIC_READ
1520 fILE_SHARE_READ
1521 Nothing
1522 oPEN_EXISTING
1523 (fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS)
1524 Nothing
1525 let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr
1526 path <- Win32.try "GetFinalPathName"
1527 (\buf len -> fnPtr handle buf len 0) 512
1528 `finally` closeHandle handle
1529 return $ Just path
1530
1531 type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD
1532
1533 foreign import WINDOWS_CCONV unsafe "dynamic"
1534 makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath
1535 #else
1536 getBaseDir = return Nothing
1537 #endif
1538
1539 #ifdef mingw32_HOST_OS
1540 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
1541 #else
1542 getProcessID :: IO Int
1543 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
1544 #endif
1545
1546 -- Divvy up text stream into lines, taking platform dependent
1547 -- line termination into account.
1548 linesPlatform :: String -> [String]
1549 #if !defined(mingw32_HOST_OS)
1550 linesPlatform ls = lines ls
1551 #else
1552 linesPlatform "" = []
1553 linesPlatform xs =
1554 case lineBreak xs of
1555 (as,xs1) -> as : linesPlatform xs1
1556 where
1557 lineBreak "" = ("","")
1558 lineBreak ('\r':'\n':xs) = ([],xs)
1559 lineBreak ('\n':xs) = ([],xs)
1560 lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
1561
1562 #endif
1563
1564 {-
1565 Note [No PIE eating while linking]
1566 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1567 As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by
1568 default in their gcc builds. This is incompatible with -r as it implies that we
1569 are producing an executable. Consequently, we must manually pass -no-pie to gcc
1570 when joining object files or linking dynamic libraries. See #12759.
1571 -}
1572
1573 linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
1574 linkDynLib dflags0 o_files dep_packages
1575 = do
1576 let -- This is a rather ugly hack to fix dynamically linked
1577 -- GHC on Windows. If GHC is linked with -threaded, then
1578 -- it links against libHSrts_thr. But if base is linked
1579 -- against libHSrts, then both end up getting loaded,
1580 -- and things go wrong. We therefore link the libraries
1581 -- with the same RTS flags that we link GHC with.
1582 dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0
1583 else dflags0
1584 dflags2 = if cGhcDebugged then addWay' WayDebug dflags1
1585 else dflags1
1586 dflags = updateWays dflags2
1587
1588 verbFlags = getVerbFlags dflags
1589 o_file = outputFile dflags
1590
1591 pkgs <- getPreloadPackagesAnd dflags dep_packages
1592
1593 let pkg_lib_paths = collectLibraryPaths dflags pkgs
1594 let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1595 get_pkg_lib_path_opts l
1596 | ( osElfTarget (platformOS (targetPlatform dflags)) ||
1597 osMachOTarget (platformOS (targetPlatform dflags)) ) &&
1598 dynLibLoader dflags == SystemDependent &&
1599 WayDyn `elem` ways dflags
1600 = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]
1601 -- See Note [-Xlinker -rpath vs -Wl,-rpath]
1602 | otherwise = ["-L" ++ l]
1603
1604 let lib_paths = libraryPaths dflags
1605 let lib_path_opts = map ("-L"++) lib_paths
1606
1607 -- We don't want to link our dynamic libs against the RTS package,
1608 -- because the RTS lib comes in several flavours and we want to be
1609 -- able to pick the flavour when a binary is linked.
1610 -- On Windows we need to link the RTS import lib as Windows does
1611 -- not allow undefined symbols.
1612 -- The RTS library path is still added to the library search path
1613 -- above in case the RTS is being explicitly linked in (see #3807).
1614 let platform = targetPlatform dflags
1615 os = platformOS platform
1616 pkgs_no_rts = case os of
1617 OSMinGW32 ->
1618 pkgs
1619 _ ->
1620 filter ((/= rtsUnitId) . packageConfigId) pkgs
1621 let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts
1622 in package_hs_libs ++ extra_libs ++ other_flags
1623
1624 -- probably _stub.o files
1625 -- and last temporary shared object file
1626 let extra_ld_inputs = ldInputs dflags
1627
1628 -- frameworks
1629 pkg_framework_opts <- getPkgFrameworkOpts dflags platform
1630 (map unitId pkgs)
1631 let framework_opts = getFrameworkOpts dflags platform
1632
1633 case os of
1634 OSMinGW32 -> do
1635 -------------------------------------------------------------
1636 -- Making a DLL
1637 -------------------------------------------------------------
1638 let output_fn = case o_file of
1639 Just s -> s
1640 Nothing -> "HSdll.dll"
1641
1642 runLink dflags (
1643 map Option verbFlags
1644 ++ [ Option "-o"
1645 , FileOption "" output_fn
1646 , Option "-shared"
1647 ] ++
1648 [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1649 | gopt Opt_SharedImplib dflags
1650 ]
1651 ++ map (FileOption "") o_files
1652
1653 -- Permit the linker to auto link _symbol to _imp_symbol
1654 -- This lets us link against DLLs without needing an "import library"
1655 ++ [Option "-Wl,--enable-auto-import"]
1656
1657 ++ extra_ld_inputs
1658 ++ map Option (
1659 lib_path_opts
1660 ++ pkg_lib_path_opts
1661 ++ pkg_link_opts
1662 ))
1663 OSDarwin -> do
1664 -------------------------------------------------------------------
1665 -- Making a darwin dylib
1666 -------------------------------------------------------------------
1667 -- About the options used for Darwin:
1668 -- -dynamiclib
1669 -- Apple's way of saying -shared
1670 -- -undefined dynamic_lookup:
1671 -- Without these options, we'd have to specify the correct
1672 -- dependencies for each of the dylibs. Note that we could
1673 -- (and should) do without this for all libraries except
1674 -- the RTS; all we need to do is to pass the correct
1675 -- HSfoo_dyn.dylib files to the link command.
1676 -- This feature requires Mac OS X 10.3 or later; there is
1677 -- a similar feature, -flat_namespace -undefined suppress,
1678 -- which works on earlier versions, but it has other
1679 -- disadvantages.
1680 -- -single_module
1681 -- Build the dynamic library as a single "module", i.e. no
1682 -- dynamic binding nonsense when referring to symbols from
1683 -- within the library. The NCG assumes that this option is
1684 -- specified (on i386, at least).
1685 -- -install_name
1686 -- Mac OS/X stores the path where a dynamic library is (to
1687 -- be) installed in the library itself. It's called the
1688 -- "install name" of the library. Then any library or
1689 -- executable that links against it before it's installed
1690 -- will search for it in its ultimate install location.
1691 -- By default we set the install name to the absolute path
1692 -- at build time, but it can be overridden by the
1693 -- -dylib-install-name option passed to ghc. Cabal does
1694 -- this.
1695 -------------------------------------------------------------------
1696
1697 let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1698
1699 instName <- case dylibInstallName dflags of
1700 Just n -> return n
1701 Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)
1702 runLink dflags (
1703 map Option verbFlags
1704 ++ [ Option "-dynamiclib"
1705 , Option "-o"
1706 , FileOption "" output_fn
1707 ]
1708 ++ map Option o_files
1709 ++ [ Option "-undefined",
1710 Option "dynamic_lookup",
1711 Option "-single_module" ]
1712 ++ (if platformArch platform == ArchX86_64
1713 then [ ]
1714 else [ Option "-Wl,-read_only_relocs,suppress" ])
1715 ++ [ Option "-install_name", Option instName ]
1716 ++ map Option lib_path_opts
1717 ++ extra_ld_inputs
1718 ++ map Option framework_opts
1719 ++ map Option pkg_lib_path_opts
1720 ++ map Option pkg_link_opts
1721 ++ map Option pkg_framework_opts
1722 )
1723 OSiOS -> throwGhcExceptionIO (ProgramError "dynamic libraries are not supported on iOS target")
1724 _ -> do
1725 -------------------------------------------------------------------
1726 -- Making a DSO
1727 -------------------------------------------------------------------
1728
1729 let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1730 let bsymbolicFlag = -- we need symbolic linking to resolve
1731 -- non-PIC intra-package-relocations
1732 ["-Wl,-Bsymbolic"]
1733
1734 runLink dflags (
1735 map Option verbFlags
1736 ++ [ Option "-o"
1737 , FileOption "" output_fn
1738 ]
1739 -- See Note [No PIE eating when linking]
1740 ++ (if sGccSupportsNoPie (settings dflags)
1741 then [Option "-no-pie"]
1742 else [])
1743 ++ map Option o_files
1744 ++ [ Option "-shared" ]
1745 ++ map Option bsymbolicFlag
1746 -- Set the library soname. We use -h rather than -soname as
1747 -- Solaris 10 doesn't support the latter:
1748 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]
1749 ++ extra_ld_inputs
1750 ++ map Option lib_path_opts
1751 ++ map Option pkg_lib_path_opts
1752 ++ map Option pkg_link_opts
1753 )
1754
1755 getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String]
1756 getPkgFrameworkOpts dflags platform dep_packages
1757 | platformUsesFrameworks platform = do
1758 pkg_framework_path_opts <- do
1759 pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1760 return $ map ("-F" ++) pkg_framework_paths
1761
1762 pkg_framework_opts <- do
1763 pkg_frameworks <- getPackageFrameworks dflags dep_packages
1764 return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1765
1766 return (pkg_framework_path_opts ++ pkg_framework_opts)
1767
1768 | otherwise = return []
1769
1770 getFrameworkOpts :: DynFlags -> Platform -> [String]
1771 getFrameworkOpts dflags platform
1772 | platformUsesFrameworks platform = framework_path_opts ++ framework_opts
1773 | otherwise = []
1774 where
1775 framework_paths = frameworkPaths dflags
1776 framework_path_opts = map ("-F" ++) framework_paths
1777
1778 frameworks = cmdlineFrameworks dflags
1779 -- reverse because they're added in reverse order from the cmd line:
1780 framework_opts = concat [ ["-framework", fw]
1781 | fw <- reverse frameworks ]