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