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