40a7a25ccdca03f69aaa32e00d6390db0e4e2057
[ghc.git] / compiler / main / SysTools.lhs
1 -----------------------------------------------------------------------------
2 --
3 -- (c) The University of Glasgow 2001-2003
4 --
5 -- Access to system tools: gcc, cp, rm etc
6 --
7 -----------------------------------------------------------------------------
8
9 \begin{code}
10 module SysTools (
11         -- Initialisation
12         initSysTools,
13
14         -- Interface to system tools
15         runUnlit, runCpp, runCc, -- [Option] -> IO ()
16         runPp,                   -- [Option] -> IO ()
17         runSplit,                -- [Option] -> IO ()
18         runAs, runLink,          -- [Option] -> IO ()
19         runMkDLL,
20         runWindres,
21         runLlvmOpt,
22         runLlvmLlc,
23         runClang,
24         figureLlvmVersion,
25         readElfSection,
26
27         linkDynLib,
28
29         askCc,
30
31         touch,                  -- String -> String -> IO ()
32         copy,
33         copyWithHeader,
34
35         -- Temporary-file management
36         setTmpDir,
37         newTempName,
38         cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
39         addFilesToClean,
40
41         Option(..)
42
43  ) where
44
45 #include "HsVersions.h"
46
47 import DriverPhases
48 import Module
49 import Packages
50 import Config
51 import Outputable
52 import ErrUtils
53 import Panic
54 import Platform
55 import Util
56 import DynFlags
57 import Exception
58
59 import Data.IORef
60 import Control.Monad
61 import System.Exit
62 import System.Environment
63 import System.FilePath
64 import System.IO
65 import System.IO.Error as IO
66 import System.Directory
67 import Data.Char
68 import Data.List
69 import qualified Data.Map as Map
70 import Text.ParserCombinators.ReadP hiding (char)
71 import qualified Text.ParserCombinators.ReadP as R
72
73 #ifndef mingw32_HOST_OS
74 import qualified System.Posix.Internals
75 #else /* Must be Win32 */
76 import Foreign
77 import Foreign.C.String
78 #endif
79
80 import System.Process
81 import Control.Concurrent
82 import FastString
83 import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
84
85 #ifdef mingw32_HOST_OS
86 # if defined(i386_HOST_ARCH)
87 #  define WINDOWS_CCONV stdcall
88 # elif defined(x86_64_HOST_ARCH)
89 #  define WINDOWS_CCONV ccall
90 # else
91 #  error Unknown mingw32 arch
92 # endif
93 #endif
94 \end{code}
95
96 How GHC finds its files
97 ~~~~~~~~~~~~~~~~~~~~~~~
98
99 [Note topdir]
100
101 GHC needs various support files (library packages, RTS etc), plus
102 various auxiliary programs (cp, gcc, etc).  It starts by finding topdir,
103 the root of GHC's support files
104
105 On Unix:
106   - ghc always has a shell wrapper that passes a -B<dir> option
107
108 On Windows:
109   - ghc never has a shell wrapper.
110   - we can find the location of the ghc binary, which is
111         $topdir/bin/<something>.exe
112     where <something> may be "ghc", "ghc-stage2", or similar
113   - we strip off the "bin/<something>.exe" to leave $topdir.
114
115 from topdir we can find package.conf, ghc-asm, etc.
116
117
118 SysTools.initSysProgs figures out exactly where all the auxiliary programs
119 are, and initialises mutable variables to make it easy to call them.
120 To to this, it makes use of definitions in Config.hs, which is a Haskell
121 file containing variables whose value is figured out by the build system.
122
123 Config.hs contains two sorts of things
124
125   cGCC,         The *names* of the programs
126   cCPP            e.g.  cGCC = gcc
127   cUNLIT                cCPP = gcc -E
128   etc           They do *not* include paths
129
130
131   cUNLIT_DIR   The *path* to the directory containing unlit, split etc
132   cSPLIT_DIR   *relative* to the root of the build tree,
133                    for use when running *in-place* in a build tree (only)
134
135
136
137 ---------------------------------------------
138 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
139
140 Another hair-brained scheme for simplifying the current tool location
141 nightmare in GHC: Simon originally suggested using another
142 configuration file along the lines of GCC's specs file - which is fine
143 except that it means adding code to read yet another configuration
144 file.  What I didn't notice is that the current package.conf is
145 general enough to do this:
146
147 Package
148     {name = "tools",    import_dirs = [],  source_dirs = [],
149      library_dirs = [], hs_libraries = [], extra_libraries = [],
150      include_dirs = [], c_includes = [],   package_deps = [],
151      extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
152      extra_cc_opts = [], extra_ld_opts = []}
153
154 Which would have the advantage that we get to collect together in one
155 place the path-specific package stuff with the path-specific tool
156 stuff.
157                 End of NOTES
158 ---------------------------------------------
159
160 %************************************************************************
161 %*                                                                      *
162 \subsection{Initialisation}
163 %*                                                                      *
164 %************************************************************************
165
166 \begin{code}
167 initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
168              -> IO Settings     -- Set all the mutable variables above, holding
169                                 --      (a) the system programs
170                                 --      (b) the package-config file
171                                 --      (c) the GHC usage message
172 initSysTools mbMinusB
173   = do top_dir <- findTopDir mbMinusB
174              -- see [Note topdir]
175              -- NB: top_dir is assumed to be in standard Unix
176              -- format, '/' separated
177
178        let settingsFile = top_dir </> "settings"
179            platformConstantsFile = top_dir </> "platformConstants"
180            installed :: FilePath -> FilePath
181            installed file = top_dir </> file
182
183        settingsStr <- readFile settingsFile
184        platformConstantsStr <- readFile platformConstantsFile
185        mySettings <- case maybeReadFuzzy settingsStr of
186                      Just s ->
187                          return s
188                      Nothing ->
189                          pgmError ("Can't parse " ++ show settingsFile)
190        platformConstants <- case maybeReadFuzzy platformConstantsStr of
191                             Just s ->
192                                 return s
193                             Nothing ->
194                                 pgmError ("Can't parse " ++
195                                           show platformConstantsFile)
196        let getSetting key = case lookup key mySettings of
197                             Just xs ->
198                                 return $ case stripPrefix "$topdir" xs of
199                                          Just [] ->
200                                              top_dir
201                                          Just xs'@(c:_)
202                                           | isPathSeparator c ->
203                                              top_dir ++ xs'
204                                          _ ->
205                                              xs
206                             Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
207            getBooleanSetting key = case lookup key mySettings of
208                                    Just "YES" -> return True
209                                    Just "NO" -> return False
210                                    Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs)
211                                    Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
212            readSetting key = case lookup key mySettings of
213                              Just xs ->
214                                  case maybeRead xs of
215                                  Just v -> return v
216                                  Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)
217                              Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
218        targetArch <- readSetting "target arch"
219        targetOS <- readSetting "target os"
220        targetWordSize <- readSetting "target word size"
221        targetUnregisterised <- getBooleanSetting "Unregisterised"
222        targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
223        targetHasIdentDirective <- readSetting "target has .ident directive"
224        targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
225        myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
226        -- On Windows, mingw is distributed with GHC,
227        -- so we look in TopDir/../mingw/bin
228        -- It would perhaps be nice to be able to override this
229        -- with the settings file, but it would be a little fiddly
230        -- to make that possible, so for now you can't.
231        gcc_prog <- getSetting "C compiler command"
232        gcc_args_str <- getSetting "C compiler flags"
233        let unreg_gcc_args = if targetUnregisterised
234                             then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
235                             else []
236            -- TABLES_NEXT_TO_CODE affects the info table layout.
237            tntc_gcc_args
238             | mkTablesNextToCode targetUnregisterised
239                = ["-DTABLES_NEXT_TO_CODE"]
240             | otherwise = []
241            gcc_args = map Option (words gcc_args_str
242                                ++ unreg_gcc_args
243                                ++ tntc_gcc_args)
244        ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
245        ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"
246        ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"
247        perl_path <- getSetting "perl command"
248
249        let pkgconfig_path = installed "package.conf.d"
250            ghc_usage_msg_path  = installed "ghc-usage.txt"
251            ghci_usage_msg_path = installed "ghci-usage.txt"
252
253              -- For all systems, unlit, split, mangle are GHC utilities
254              -- architecture-specific stuff is done when building Config.hs
255            unlit_path = installed cGHC_UNLIT_PGM
256
257              -- split is a Perl script
258            split_script  = installed cGHC_SPLIT_PGM
259
260        windres_path <- getSetting "windres command"
261
262        tmpdir <- getTemporaryDirectory
263
264        touch_path <- getSetting "touch command"
265
266        let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
267            -- a call to Perl to get the invocation of split.
268            -- On Unix, scripts are invoked using the '#!' method.  Binary
269            -- installations of GHC on Unix place the correct line on the
270            -- front of the script at installation time, so we don't want
271            -- to wire-in our knowledge of $(PERL) on the host system here.
272            (split_prog,  split_args)
273              | isWindowsHost = (perl_path,    [Option split_script])
274              | otherwise     = (split_script, [])
275        mkdll_prog <- getSetting "dllwrap command"
276        let mkdll_args = []
277
278        -- cpp is derived from gcc on all platforms
279        -- HACK, see setPgmP below. We keep 'words' here to remember to fix
280        -- Config.hs one day.
281        let cpp_prog  = gcc_prog
282            cpp_args  = Option "-E"
283                      : map Option (words cRAWCPP_FLAGS)
284                     ++ gcc_args
285
286        -- Other things being equal, as and ld are simply gcc
287        let   as_prog  = gcc_prog
288              as_args  = gcc_args
289              ld_prog  = gcc_prog
290              ld_args  = gcc_args
291
292        -- We just assume on command line
293        lc_prog <- getSetting "LLVM llc command"
294        lo_prog <- getSetting "LLVM opt command"
295
296        let platform = Platform {
297                           platformArch = targetArch,
298                           platformOS   = targetOS,
299                           platformWordSize = targetWordSize,
300                           platformUnregisterised = targetUnregisterised,
301                           platformHasGnuNonexecStack = targetHasGnuNonexecStack,
302                           platformHasIdentDirective = targetHasIdentDirective,
303                           platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
304                       }
305
306        return $ Settings {
307                     sTargetPlatform = platform,
308                     sTmpDir         = normalise tmpdir,
309                     sGhcUsagePath   = ghc_usage_msg_path,
310                     sGhciUsagePath  = ghci_usage_msg_path,
311                     sTopDir         = top_dir,
312                     sRawSettings    = mySettings,
313                     sExtraGccViaCFlags = words myExtraGccViaCFlags,
314                     sSystemPackageConfig = pkgconfig_path,
315                     sLdSupportsCompactUnwind = ldSupportsCompactUnwind,
316                     sLdSupportsBuildId       = ldSupportsBuildId,
317                     sLdIsGnuLd               = ldIsGnuLd,
318                     sPgm_L   = unlit_path,
319                     sPgm_P   = (cpp_prog, cpp_args),
320                     sPgm_F   = "",
321                     sPgm_c   = (gcc_prog, gcc_args),
322                     sPgm_s   = (split_prog,split_args),
323                     sPgm_a   = (as_prog, as_args),
324                     sPgm_l   = (ld_prog, ld_args),
325                     sPgm_dll = (mkdll_prog,mkdll_args),
326                     sPgm_T   = touch_path,
327                     sPgm_sysman  = top_dir ++ "/ghc/rts/parallel/SysMan",
328                     sPgm_windres = windres_path,
329                     sPgm_lo  = (lo_prog,[]),
330                     sPgm_lc  = (lc_prog,[]),
331                     -- Hans: this isn't right in general, but you can
332                     -- elaborate it in the same way as the others
333                     sOpt_L       = [],
334                     sOpt_P       = [],
335                     sOpt_F       = [],
336                     sOpt_c       = [],
337                     sOpt_a       = [],
338                     sOpt_l       = [],
339                     sOpt_windres = [],
340                     sOpt_lo      = [],
341                     sOpt_lc      = [],
342                     sPlatformConstants = platformConstants
343              }
344 \end{code}
345
346 \begin{code}
347 -- returns a Unix-format path (relying on getBaseDir to do so too)
348 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
349            -> IO String    -- TopDir (in Unix format '/' separated)
350 findTopDir (Just minusb) = return (normalise minusb)
351 findTopDir Nothing
352     = do -- Get directory of executable
353          maybe_exec_dir <- getBaseDir
354          case maybe_exec_dir of
355              -- "Just" on Windows, "Nothing" on unix
356              Nothing  -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
357              Just dir -> return dir
358 \end{code}
359
360
361 %************************************************************************
362 %*                                                                      *
363 \subsection{Running an external program}
364 %*                                                                      *
365 %************************************************************************
366
367
368 \begin{code}
369 runUnlit :: DynFlags -> [Option] -> IO ()
370 runUnlit dflags args = do
371   let p = pgm_L dflags
372   runSomething dflags "Literate pre-processor" p args
373
374 runCpp :: DynFlags -> [Option] -> IO ()
375 runCpp dflags args =   do
376   let (p,args0) = pgm_P dflags
377       args1 = args0 ++ args
378       args2 = if gopt Opt_WarnIsError dflags
379               then Option "-Werror" : args1
380               else                    args1
381   mb_env <- getGccEnv args2
382   runSomethingFiltered dflags id  "C pre-processor" p args2 mb_env
383
384 runPp :: DynFlags -> [Option] -> IO ()
385 runPp dflags args =   do
386   let p = pgm_F dflags
387   runSomething dflags "Haskell pre-processor" p args
388
389 runCc :: DynFlags -> [Option] -> IO ()
390 runCc dflags args =   do
391   let (p,args0) = pgm_c dflags
392       args1 = args0 ++ args
393   mb_env <- getGccEnv args1
394   runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
395  where
396   -- discard some harmless warnings from gcc that we can't turn off
397   cc_filter = unlines . doFilter . lines
398
399   {-
400   gcc gives warnings in chunks like so:
401       In file included from /foo/bar/baz.h:11,
402                        from /foo/bar/baz2.h:22,
403                        from wibble.c:33:
404       /foo/flibble:14: global register variable ...
405       /foo/flibble:15: warning: call-clobbered r...
406   We break it up into its chunks, remove any call-clobbered register
407   warnings from each chunk, and then delete any chunks that we have
408   emptied of warnings.
409   -}
410   doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
411   -- We can't assume that the output will start with an "In file inc..."
412   -- line, so we start off expecting a list of warnings rather than a
413   -- location stack.
414   chunkWarnings :: [String] -- The location stack to use for the next
415                             -- list of warnings
416                 -> [String] -- The remaining lines to look at
417                 -> [([String], [String])]
418   chunkWarnings loc_stack [] = [(loc_stack, [])]
419   chunkWarnings loc_stack xs
420       = case break loc_stack_start xs of
421         (warnings, lss:xs') ->
422             case span loc_start_continuation xs' of
423             (lsc, xs'') ->
424                 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
425         _ -> [(loc_stack, xs)]
426
427   filterWarnings :: [([String], [String])] -> [([String], [String])]
428   filterWarnings [] = []
429   -- If the warnings are already empty then we are probably doing
430   -- something wrong, so don't delete anything
431   filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
432   filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
433                                        [] -> filterWarnings zs
434                                        ys' -> (xs, ys') : filterWarnings zs
435
436   unChunkWarnings :: [([String], [String])] -> [String]
437   unChunkWarnings [] = []
438   unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
439
440   loc_stack_start        s = "In file included from " `isPrefixOf` s
441   loc_start_continuation s = "                 from " `isPrefixOf` s
442   wantedWarning w
443    | "warning: call-clobbered register used" `isContainedIn` w = False
444    | otherwise = True
445
446 isContainedIn :: String -> String -> Bool
447 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
448
449 askCc :: DynFlags -> [Option] -> IO String
450 askCc dflags args = do
451   let (p,args0) = pgm_c dflags
452       args1 = args0 ++ args
453   mb_env <- getGccEnv args1
454   runSomethingWith dflags "gcc" p args1 $ \real_args ->
455     readCreateProcess (proc p real_args){ env = mb_env }
456
457 -- Version of System.Process.readProcessWithExitCode that takes an environment
458 readCreateProcess
459     :: CreateProcess
460     -> IO (ExitCode, String)    -- ^ stdout
461 readCreateProcess proc = do
462     (_, Just outh, _, pid) <-
463         createProcess proc{ std_out = CreatePipe }
464
465     -- fork off a thread to start consuming the output
466     output  <- hGetContents outh
467     outMVar <- newEmptyMVar
468     _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
469
470     -- wait on the output
471     takeMVar outMVar
472     hClose outh
473
474     -- wait on the process
475     ex <- waitForProcess pid
476
477     return (ex, output)
478
479
480 -- If the -B<dir> option is set, add <dir> to PATH.  This works around
481 -- a bug in gcc on Windows Vista where it can't find its auxiliary
482 -- binaries (see bug #1110).
483 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
484 getGccEnv opts =
485   if null b_dirs
486      then return Nothing
487      else do env <- getEnvironment
488              return (Just (map mangle_path env))
489  where
490   (b_dirs, _) = partitionWith get_b_opt opts
491
492   get_b_opt (Option ('-':'B':dir)) = Left dir
493   get_b_opt other = Right other
494
495   mangle_path (path,paths) | map toUpper path == "PATH"
496         = (path, '\"' : head b_dirs ++ "\";" ++ paths)
497   mangle_path other = other
498
499 runSplit :: DynFlags -> [Option] -> IO ()
500 runSplit dflags args = do
501   let (p,args0) = pgm_s dflags
502   runSomething dflags "Splitter" p (args0++args)
503
504 runAs :: DynFlags -> [Option] -> IO ()
505 runAs dflags args = do
506   let (p,args0) = pgm_a dflags
507       args1 = args0 ++ args
508   mb_env <- getGccEnv args1
509   runSomethingFiltered dflags id "Assembler" p args1 mb_env
510
511 -- | Run the LLVM Optimiser
512 runLlvmOpt :: DynFlags -> [Option] -> IO ()
513 runLlvmOpt dflags args = do
514   let (p,args0) = pgm_lo dflags
515   runSomething dflags "LLVM Optimiser" p (args0++args)
516
517 -- | Run the LLVM Compiler
518 runLlvmLlc :: DynFlags -> [Option] -> IO ()
519 runLlvmLlc dflags args = do
520   let (p,args0) = pgm_lc dflags
521   runSomething dflags "LLVM Compiler" p (args0++args)
522
523 -- | Run the clang compiler (used as an assembler for the LLVM
524 -- backend on OS X as LLVM doesn't support the OS X system
525 -- assembler)
526 runClang :: DynFlags -> [Option] -> IO ()
527 runClang dflags args = do
528   -- we simply assume its available on the PATH
529   let clang = "clang"
530       -- be careful what options we call clang with
531       -- see #5903 and #7617 for bugs caused by this.
532       (_,args0) = pgm_a dflags
533       args1 = args0 ++ args
534   mb_env <- getGccEnv args1
535   Exception.catch (do
536         runSomethingFiltered dflags id "Clang (Assembler)" clang args1 mb_env
537     )
538     (\(err :: SomeException) -> do
539         errorMsg dflags $
540             text ("Error running clang! you need clang installed to use the" ++
541                 "LLVM backend") $+$
542             text "(or GHC tried to execute clang incorrectly)"
543         throwIO err
544     )
545
546 -- | Figure out which version of LLVM we are running this session
547 figureLlvmVersion :: DynFlags -> IO (Maybe Int)
548 figureLlvmVersion dflags = do
549   let (pgm,opts) = pgm_lc dflags
550       args = filter notNull (map showOpt opts)
551       -- we grab the args even though they should be useless just in
552       -- case the user is using a customised 'llc' that requires some
553       -- of the options they've specified. llc doesn't care what other
554       -- options are specified when '-version' is used.
555       args' = args ++ ["-version"]
556   ver <- catchIO (do
557              (pin, pout, perr, _) <- runInteractiveProcess pgm args'
558                                              Nothing Nothing
559              {- > llc -version
560                   Low Level Virtual Machine (http://llvm.org/):
561                     llvm version 2.8 (Ubuntu 2.8-0Ubuntu1)
562                     ...
563              -}
564              hSetBinaryMode pout False
565              _     <- hGetLine pout
566              vline <- hGetLine pout
567              v     <- case filter isDigit vline of
568                             []      -> fail "no digits!"
569                             [x]     -> fail $ "only 1 digit! (" ++ show x ++ ")"
570                             (x:y:_) -> return ((read [x,y]) :: Int)
571              hClose pin
572              hClose pout
573              hClose perr
574              return $ Just v
575             )
576             (\err -> do
577                 debugTraceMsg dflags 2
578                     (text "Error (figuring out LLVM version):" <+>
579                      text (show err))
580                 errorMsg dflags $ vcat
581                     [ text "Warning:", nest 9 $
582                           text "Couldn't figure out LLVM version!" $$
583                           text "Make sure you have installed LLVM"]
584                 return Nothing)
585   return ver
586   
587
588 runLink :: DynFlags -> [Option] -> IO ()
589 runLink dflags args = do
590   let (p,args0) = pgm_l dflags
591       args1 = args0 ++ args
592   mb_env <- getGccEnv args1
593   runSomethingFiltered dflags id "Linker" p args1 mb_env
594
595 runMkDLL :: DynFlags -> [Option] -> IO ()
596 runMkDLL dflags args = do
597   let (p,args0) = pgm_dll dflags
598       args1 = args0 ++ args
599   mb_env <- getGccEnv (args0++args)
600   runSomethingFiltered dflags id "Make DLL" p args1 mb_env
601
602 runWindres :: DynFlags -> [Option] -> IO ()
603 runWindres dflags args = do
604   let (gcc, gcc_args) = pgm_c dflags
605       windres = pgm_windres dflags
606       quote x = "\"" ++ x ++ "\""
607       args' = -- If windres.exe and gcc.exe are in a directory containing
608               -- spaces then windres fails to run gcc. We therefore need
609               -- to tell it what command to use...
610               Option ("--preprocessor=" ++
611                       unwords (map quote (gcc :
612                                           map showOpt gcc_args ++
613                                           ["-E", "-xc", "-DRC_INVOKED"])))
614               -- ...but if we do that then if windres calls popen then
615               -- it can't understand the quoting, so we have to use
616               -- --use-temp-file so that it interprets it correctly.
617               -- See #1828.
618             : Option "--use-temp-file"
619             : args
620   mb_env <- getGccEnv gcc_args
621   runSomethingFiltered dflags id "Windres" windres args' mb_env
622
623 touch :: DynFlags -> String -> String -> IO ()
624 touch dflags purpose arg =
625   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
626
627 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
628 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
629
630 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
631                -> IO ()
632 copyWithHeader dflags purpose maybe_header from to = do
633   showPass dflags purpose
634
635   hout <- openBinaryFile to   WriteMode
636   hin  <- openBinaryFile from ReadMode
637   ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
638   maybe (return ()) (header hout) maybe_header
639   hPutStr hout ls
640   hClose hout
641   hClose hin
642  where
643   -- write the header string in UTF-8.  The header is something like
644   --   {-# LINE "foo.hs" #-}
645   -- and we want to make sure a Unicode filename isn't mangled.
646   header h str = do
647    hSetEncoding h utf8
648    hPutStr h str
649    hSetBinaryMode h True
650
651 -- | read the contents of the named section in an ELF object as a
652 -- String.
653 readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String)
654 readElfSection _dflags section exe = do
655   let
656      prog = "readelf"
657      args = [Option "-p", Option section, FileOption "" exe]
658   --
659   r <- readProcessWithExitCode prog (filter notNull (map showOpt args)) ""
660   case r of
661     (ExitSuccess, out, _err) -> return (doFilter (lines out))
662     _ -> return Nothing
663  where
664   doFilter [] = Nothing
665   doFilter (s:r) = case readP_to_S parse s of
666                     [(p,"")] -> Just p
667                     _r       -> doFilter r
668    where parse = do
669            skipSpaces
670            _ <- R.char '['
671            skipSpaces
672            _ <- string "0]"
673            skipSpaces
674            munch (const True)
675 \end{code}
676
677 %************************************************************************
678 %*                                                                      *
679 \subsection{Managing temporary files
680 %*                                                                      *
681 %************************************************************************
682
683 \begin{code}
684 cleanTempDirs :: DynFlags -> IO ()
685 cleanTempDirs dflags
686    = unless (gopt Opt_KeepTmpFiles dflags)
687    $ do let ref = dirsToClean dflags
688         ds <- readIORef ref
689         removeTmpDirs dflags (Map.elems ds)
690         writeIORef ref Map.empty
691
692 cleanTempFiles :: DynFlags -> IO ()
693 cleanTempFiles dflags
694    = unless (gopt Opt_KeepTmpFiles dflags)
695    $ do let ref = filesToClean dflags
696         fs <- readIORef ref
697         removeTmpFiles dflags fs
698         writeIORef ref []
699
700 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
701 cleanTempFilesExcept dflags dont_delete
702    = unless (gopt Opt_KeepTmpFiles dflags)
703    $ do let ref = filesToClean dflags
704         files <- readIORef ref
705         let (to_keep, to_delete) = partition (`elem` dont_delete) files
706         writeIORef ref to_keep
707         removeTmpFiles dflags to_delete
708
709
710 -- find a temporary name that doesn't already exist.
711 newTempName :: DynFlags -> Suffix -> IO FilePath
712 newTempName dflags extn
713   = do d <- getTempDir dflags
714        x <- getProcessID
715        findTempName (d </> "ghc" ++ show x ++ "_") 0
716   where
717     findTempName :: FilePath -> Integer -> IO FilePath
718     findTempName prefix x
719       = do let filename = (prefix ++ show x) <.> extn
720            b  <- doesFileExist filename
721            if b then findTempName prefix (x+1)
722                 else do -- clean it up later
723                         consIORef (filesToClean dflags) filename
724                         return filename
725
726 -- return our temporary directory within tmp_dir, creating one if we
727 -- don't have one yet
728 getTempDir :: DynFlags -> IO FilePath
729 getTempDir dflags
730   = do let ref = dirsToClean dflags
731            tmp_dir = tmpDir dflags
732        mapping <- readIORef ref
733        case Map.lookup tmp_dir mapping of
734            Nothing ->
735                do x <- getProcessID
736                   let prefix = tmp_dir </> "ghc" ++ show x ++ "_"
737                   let
738                       mkTempDir :: Integer -> IO FilePath
739                       mkTempDir x
740                        = let dirname = prefix ++ show x
741                          in do createDirectory dirname
742                                let mapping' = Map.insert tmp_dir dirname mapping
743                                writeIORef ref mapping'
744                                debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
745                                return dirname
746                             `catchIO` \e ->
747                                     if isAlreadyExistsError e
748                                     then mkTempDir (x+1)
749                                     else ioError e
750                   mkTempDir 0
751            Just d -> return d
752
753 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
754 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
755 addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files
756
757 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
758 removeTmpDirs dflags ds
759   = traceCmd dflags "Deleting temp dirs"
760              ("Deleting: " ++ unwords ds)
761              (mapM_ (removeWith dflags removeDirectory) ds)
762
763 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
764 removeTmpFiles dflags fs
765   = warnNon $
766     traceCmd dflags "Deleting temp files"
767              ("Deleting: " ++ unwords deletees)
768              (mapM_ (removeWith dflags removeFile) deletees)
769   where
770      -- Flat out refuse to delete files that are likely to be source input
771      -- files (is there a worse bug than having a compiler delete your source
772      -- files?)
773      --
774      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
775      -- the condition.
776     warnNon act
777      | null non_deletees = act
778      | otherwise         = do
779         putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
780         act
781
782     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
783
784 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
785 removeWith dflags remover f = remover f `catchIO`
786   (\e ->
787    let msg = if isDoesNotExistError e
788              then ptext (sLit "Warning: deleting non-existent") <+> text f
789              else ptext (sLit "Warning: exception raised when deleting")
790                                             <+> text f <> colon
791                $$ text (show e)
792    in debugTraceMsg dflags 2 msg
793   )
794
795 -----------------------------------------------------------------------------
796 -- Running an external program
797
798 runSomething :: DynFlags
799              -> String          -- For -v message
800              -> String          -- Command name (possibly a full path)
801                                 --      assumed already dos-ified
802              -> [Option]        -- Arguments
803                                 --      runSomething will dos-ify them
804              -> IO ()
805
806 runSomething dflags phase_name pgm args =
807   runSomethingFiltered dflags id phase_name pgm args Nothing
808
809 runSomethingFiltered
810   :: DynFlags -> (String->String) -> String -> String -> [Option]
811   -> Maybe [(String,String)] -> IO ()
812
813 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
814     runSomethingWith dflags phase_name pgm args $ \real_args -> do
815         r <- builderMainLoop dflags filter_fn pgm real_args mb_env
816         return (r,())
817
818 runSomethingWith
819   :: DynFlags -> String -> String -> [Option]
820   -> ([String] -> IO (ExitCode, a))
821   -> IO a
822
823 runSomethingWith dflags phase_name pgm args io = do
824   let real_args = filter notNull (map showOpt args)
825       cmdLine = showCommandForUser pgm real_args
826   traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
827
828 handleProc :: String -> String -> IO (ExitCode, r) -> IO r
829 handleProc pgm phase_name proc = do
830     (rc, r) <- proc `catchIO` handler
831     case rc of
832       ExitSuccess{} -> return r
833       ExitFailure n
834         -- rawSystem returns (ExitFailure 127) if the exec failed for any
835         -- reason (eg. the program doesn't exist).  This is the only clue
836         -- we have, but we need to report something to the user because in
837         -- the case of a missing program there will otherwise be no output
838         -- at all.
839        | n == 127  -> does_not_exist
840        | otherwise -> throwGhcExceptionIO (PhaseFailed phase_name rc)
841   where
842     handler err =
843        if IO.isDoesNotExistError err
844           then does_not_exist
845           else IO.ioError err
846
847     does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
848
849
850 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
851                 -> [String] -> Maybe [(String, String)]
852                 -> IO ExitCode
853 builderMainLoop dflags filter_fn pgm real_args mb_env = do
854   chan <- newChan
855   (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
856
857   -- and run a loop piping the output from the compiler to the log_action in DynFlags
858   hSetBuffering hStdOut LineBuffering
859   hSetBuffering hStdErr LineBuffering
860   _ <- forkIO (readerProc chan hStdOut filter_fn)
861   _ <- forkIO (readerProc chan hStdErr filter_fn)
862   -- we don't want to finish until 2 streams have been completed
863   -- (stdout and stderr)
864   -- nor until 1 exit code has been retrieved.
865   rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
866   -- after that, we're done here.
867   hClose hStdIn
868   hClose hStdOut
869   hClose hStdErr
870   return rc
871   where
872     -- status starts at zero, and increments each time either
873     -- a reader process gets EOF, or the build proc exits.  We wait
874     -- for all of these to happen (status==3).
875     -- ToDo: we should really have a contingency plan in case any of
876     -- the threads dies, such as a timeout.
877     loop _    _        0 0 exitcode = return exitcode
878     loop chan hProcess t p exitcode = do
879       mb_code <- if p > 0
880                    then getProcessExitCode hProcess
881                    else return Nothing
882       case mb_code of
883         Just code -> loop chan hProcess t (p-1) code
884         Nothing
885           | t > 0 -> do
886               msg <- readChan chan
887               case msg of
888                 BuildMsg msg -> do
889                   log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
890                   loop chan hProcess t p exitcode
891                 BuildError loc msg -> do
892                   log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
893                   loop chan hProcess t p exitcode
894                 EOF ->
895                   loop chan hProcess (t-1) p exitcode
896           | otherwise -> loop chan hProcess t p exitcode
897
898 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
899 readerProc chan hdl filter_fn =
900     (do str <- hGetContents hdl
901         loop (linesPlatform (filter_fn str)) Nothing)
902     `finally`
903        writeChan chan EOF
904         -- ToDo: check errors more carefully
905         -- ToDo: in the future, the filter should be implemented as
906         -- a stream transformer.
907     where
908         loop []     Nothing    = return ()
909         loop []     (Just err) = writeChan chan err
910         loop (l:ls) in_err     =
911                 case in_err of
912                   Just err@(BuildError srcLoc msg)
913                     | leading_whitespace l -> do
914                         loop ls (Just (BuildError srcLoc (msg $$ text l)))
915                     | otherwise -> do
916                         writeChan chan err
917                         checkError l ls
918                   Nothing -> do
919                         checkError l ls
920                   _ -> panic "readerProc/loop"
921
922         checkError l ls
923            = case parseError l of
924                 Nothing -> do
925                     writeChan chan (BuildMsg (text l))
926                     loop ls Nothing
927                 Just (file, lineNum, colNum, msg) -> do
928                     let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
929                     loop ls (Just (BuildError srcLoc (text msg)))
930
931         leading_whitespace []    = False
932         leading_whitespace (x:_) = isSpace x
933
934 parseError :: String -> Maybe (String, Int, Int, String)
935 parseError s0 = case breakColon s0 of
936                 Just (filename, s1) ->
937                     case breakIntColon s1 of
938                     Just (lineNum, s2) ->
939                         case breakIntColon s2 of
940                         Just (columnNum, s3) ->
941                             Just (filename, lineNum, columnNum, s3)
942                         Nothing ->
943                             Just (filename, lineNum, 0, s2)
944                     Nothing -> Nothing
945                 Nothing -> Nothing
946
947 breakColon :: String -> Maybe (String, String)
948 breakColon xs = case break (':' ==) xs of
949                     (ys, _:zs) -> Just (ys, zs)
950                     _ -> Nothing
951
952 breakIntColon :: String -> Maybe (Int, String)
953 breakIntColon xs = case break (':' ==) xs of
954                        (ys, _:zs)
955                         | not (null ys) && all isAscii ys && all isDigit ys ->
956                            Just (read ys, zs)
957                        _ -> Nothing
958
959 data BuildMessage
960   = BuildMsg   !SDoc
961   | BuildError !SrcLoc !SDoc
962   | EOF
963
964 traceCmd :: DynFlags -> String -> String -> IO a -> IO a
965 -- trace the command (at two levels of verbosity)
966 traceCmd dflags phase_name cmd_line action
967  = do   { let verb = verbosity dflags
968         ; showPass dflags phase_name
969         ; debugTraceMsg dflags 3 (text cmd_line)
970         ; case flushErr dflags of
971               FlushErr io -> io
972
973            -- And run it!
974         ; action `catchIO` handle_exn verb
975         }
976   where
977     handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
978                               ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
979                               ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) }
980 \end{code}
981
982 %************************************************************************
983 %*                                                                      *
984 \subsection{Support code}
985 %*                                                                      *
986 %************************************************************************
987
988 \begin{code}
989 -----------------------------------------------------------------------------
990 -- Define       getBaseDir     :: IO (Maybe String)
991
992 getBaseDir :: IO (Maybe String)
993 #if defined(mingw32_HOST_OS)
994 -- Assuming we are running ghc, accessed by path  $(stuff)/bin/ghc.exe,
995 -- return the path $(stuff)/lib.
996 getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
997   where
998     try_size size = allocaArray (fromIntegral size) $ \buf -> do
999         ret <- c_GetModuleFileName nullPtr buf size
1000         case ret of
1001           0 -> return Nothing
1002           _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
1003             | otherwise  -> try_size (size * 2)
1004     
1005     rootDir s = case splitFileName $ normalise s of
1006                 (d, ghc_exe)
1007                  | lower ghc_exe `elem` ["ghc.exe",
1008                                          "ghc-stage1.exe",
1009                                          "ghc-stage2.exe",
1010                                          "ghc-stage3.exe"] ->
1011                     case splitFileName $ takeDirectory d of
1012                     -- ghc is in $topdir/bin/ghc.exe
1013                     (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
1014                     _ -> fail
1015                 _ -> fail
1016         where fail = panic ("can't decompose ghc.exe path: " ++ show s)
1017               lower = map toLower
1018
1019 foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
1020   c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
1021 #else
1022 getBaseDir = return Nothing
1023 #endif
1024
1025 #ifdef mingw32_HOST_OS
1026 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
1027 #else
1028 getProcessID :: IO Int
1029 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
1030 #endif
1031
1032 -- Divvy up text stream into lines, taking platform dependent
1033 -- line termination into account.
1034 linesPlatform :: String -> [String]
1035 #if !defined(mingw32_HOST_OS)
1036 linesPlatform ls = lines ls
1037 #else
1038 linesPlatform "" = []
1039 linesPlatform xs =
1040   case lineBreak xs of
1041     (as,xs1) -> as : linesPlatform xs1
1042   where
1043    lineBreak "" = ("","")
1044    lineBreak ('\r':'\n':xs) = ([],xs)
1045    lineBreak ('\n':xs) = ([],xs)
1046    lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
1047
1048 #endif
1049
1050 linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
1051 linkDynLib dflags o_files dep_packages
1052  = do
1053     let verbFlags = getVerbFlags dflags
1054     let o_file = outputFile dflags
1055
1056     pkgs <- getPreloadPackagesAnd dflags dep_packages
1057
1058     let pkg_lib_paths = collectLibraryPaths pkgs
1059     let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1060         get_pkg_lib_path_opts l
1061          | osElfTarget (platformOS (targetPlatform dflags)) &&
1062            dynLibLoader dflags == SystemDependent &&
1063            not (gopt Opt_Static dflags)
1064             = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1065          | otherwise = ["-L" ++ l]
1066
1067     let lib_paths = libraryPaths dflags
1068     let lib_path_opts = map ("-L"++) lib_paths
1069
1070     -- We don't want to link our dynamic libs against the RTS package,
1071     -- because the RTS lib comes in several flavours and we want to be
1072     -- able to pick the flavour when a binary is linked.
1073     -- On Windows we need to link the RTS import lib as Windows does
1074     -- not allow undefined symbols.
1075     -- The RTS library path is still added to the library search path
1076     -- above in case the RTS is being explicitly linked in (see #3807).
1077     let platform = targetPlatform dflags
1078         os = platformOS platform
1079         pkgs_no_rts = case os of
1080                       OSMinGW32 ->
1081                           pkgs
1082                       _ ->
1083                           filter ((/= rtsPackageId) . packageConfigId) pkgs
1084     let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts
1085
1086         -- probably _stub.o files
1087     let extra_ld_inputs = ldInputs dflags
1088
1089     let extra_ld_opts = getOpts dflags opt_l
1090
1091     case os of
1092         OSMinGW32 -> do
1093             -------------------------------------------------------------
1094             -- Making a DLL
1095             -------------------------------------------------------------
1096             let output_fn = case o_file of
1097                             Just s -> s
1098                             Nothing -> "HSdll.dll"
1099
1100             runLink dflags (
1101                     map Option verbFlags
1102                  ++ [ Option "-o"
1103                     , FileOption "" output_fn
1104                     , Option "-shared"
1105                     ] ++
1106                     [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1107                     | gopt Opt_SharedImplib dflags
1108                     ]
1109                  ++ map (FileOption "") o_files
1110                  ++ map Option (
1111
1112                  -- Permit the linker to auto link _symbol to _imp_symbol
1113                  -- This lets us link against DLLs without needing an "import library"
1114                     ["-Wl,--enable-auto-import"]
1115
1116                  ++ extra_ld_inputs
1117                  ++ lib_path_opts
1118                  ++ extra_ld_opts
1119                  ++ pkg_lib_path_opts
1120                  ++ pkg_link_opts
1121                 ))
1122         OSDarwin -> do
1123             -------------------------------------------------------------------
1124             -- Making a darwin dylib
1125             -------------------------------------------------------------------
1126             -- About the options used for Darwin:
1127             -- -dynamiclib
1128             --   Apple's way of saying -shared
1129             -- -undefined dynamic_lookup:
1130             --   Without these options, we'd have to specify the correct
1131             --   dependencies for each of the dylibs. Note that we could
1132             --   (and should) do without this for all libraries except
1133             --   the RTS; all we need to do is to pass the correct
1134             --   HSfoo_dyn.dylib files to the link command.
1135             --   This feature requires Mac OS X 10.3 or later; there is
1136             --   a similar feature, -flat_namespace -undefined suppress,
1137             --   which works on earlier versions, but it has other
1138             --   disadvantages.
1139             -- -single_module
1140             --   Build the dynamic library as a single "module", i.e. no
1141             --   dynamic binding nonsense when referring to symbols from
1142             --   within the library. The NCG assumes that this option is
1143             --   specified (on i386, at least).
1144             -- -install_name
1145             --   Mac OS/X stores the path where a dynamic library is (to
1146             --   be) installed in the library itself.  It's called the
1147             --   "install name" of the library. Then any library or
1148             --   executable that links against it before it's installed
1149             --   will search for it in its ultimate install location.
1150             --   By default we set the install name to the absolute path
1151             --   at build time, but it can be overridden by the
1152             --   -dylib-install-name option passed to ghc. Cabal does
1153             --   this.
1154             -------------------------------------------------------------------
1155
1156             let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1157
1158             instName <- case dylibInstallName dflags of
1159                 Just n -> return n
1160                 Nothing -> do
1161                     pwd <- getCurrentDirectory
1162                     return $ pwd `combine` output_fn
1163             runLink dflags (
1164                     map Option verbFlags
1165                  ++ [ Option "-dynamiclib"
1166                     , Option "-o"
1167                     , FileOption "" output_fn
1168                     ]
1169                  ++ map Option (
1170                     o_files
1171                  ++ [ "-undefined", "dynamic_lookup", "-single_module" ]
1172                  ++ (if platformArch platform == ArchX86_64
1173                      then [ ]
1174                      else [ "-Wl,-read_only_relocs,suppress" ])
1175                  ++ [ "-install_name", instName ]
1176                  ++ extra_ld_inputs
1177                  ++ lib_path_opts
1178                  ++ extra_ld_opts
1179                  ++ pkg_lib_path_opts
1180                  ++ pkg_link_opts
1181                 ))
1182         _ -> do
1183             -------------------------------------------------------------------
1184             -- Making a DSO
1185             -------------------------------------------------------------------
1186
1187             let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1188             let buildingRts = thisPackage dflags == rtsPackageId
1189             let bsymbolicFlag = if buildingRts
1190                                 then -- -Bsymbolic breaks the way we implement
1191                                      -- hooks in the RTS
1192                                      []
1193                                 else -- we need symbolic linking to resolve
1194                                      -- non-PIC intra-package-relocations
1195                                      ["-Wl,-Bsymbolic"]
1196
1197             runLink dflags (
1198                     map Option verbFlags
1199                  ++ [ Option "-o"
1200                     , FileOption "" output_fn
1201                     ]
1202                  ++ map Option (
1203                     o_files
1204                  ++ [ "-shared" ]
1205                  ++ bsymbolicFlag
1206                     -- Set the library soname. We use -h rather than -soname as
1207                     -- Solaris 10 doesn't support the latter:
1208                  ++ [ "-Wl,-h," ++ takeFileName output_fn ]
1209                  ++ extra_ld_inputs
1210                  ++ lib_path_opts
1211                  ++ extra_ld_opts
1212                  ++ pkg_lib_path_opts
1213                  ++ pkg_link_opts
1214                 ))
1215
1216 \end{code}