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