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