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