1ce34bc12b28e09cf8cd0c1afdcbc22037484638
[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 {-# OPTIONS -fno-warn-unused-do-bind #-}
11 module SysTools (
12         -- Initialisation
13         initSysTools,
14
15         -- Interface to system tools
16         runUnlit, runCpp, runCc, -- [Option] -> IO ()
17         runPp,                   -- [Option] -> IO ()
18         runSplit,                -- [Option] -> IO ()
19         runAs, runLink,          -- [Option] -> IO ()
20         runMkDLL,
21         runWindres,
22         runLlvmOpt,
23         runLlvmLlc,
24         figureLlvmVersion,
25         readElfSection,
26
27         askCc,
28
29         touch,                  -- String -> String -> IO ()
30         copy,
31         copyWithHeader,
32
33         -- Temporary-file management
34         setTmpDir,
35         newTempName,
36         cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
37         addFilesToClean,
38
39         Option(..)
40
41  ) where
42
43 #include "HsVersions.h"
44
45 import DriverPhases
46 import Config
47 import Outputable
48 import ErrUtils
49 import Panic
50 import Platform
51 import Util
52 import DynFlags
53 import StaticFlags
54 import Exception
55
56 import Data.IORef
57 import Control.Monad
58 import System.Exit
59 import System.Environment
60 import System.FilePath
61 import System.IO
62 import System.IO.Error as IO
63 import System.Directory
64 import Data.Char
65 import Data.List
66 import qualified Data.Map as Map
67 import Text.ParserCombinators.ReadP hiding (char)
68 import qualified Text.ParserCombinators.ReadP as R
69
70 #ifndef mingw32_HOST_OS
71 import qualified System.Posix.Internals
72 #else /* Must be Win32 */
73 import Foreign
74 import Foreign.C.String
75 #endif
76
77 import System.Process
78 import Control.Concurrent
79 import FastString
80 import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
81 \end{code}
82
83 How GHC finds its files
84 ~~~~~~~~~~~~~~~~~~~~~~~
85
86 [Note topdir]
87
88 GHC needs various support files (library packages, RTS etc), plus
89 various auxiliary programs (cp, gcc, etc).  It starts by finding topdir,
90 the root of GHC's support files
91
92 On Unix:
93   - ghc always has a shell wrapper that passes a -B<dir> option
94
95 On Windows:
96   - ghc never has a shell wrapper.
97   - we can find the location of the ghc binary, which is
98         $topdir/bin/<something>.exe
99     where <something> may be "ghc", "ghc-stage2", or similar
100   - we strip off the "bin/<something>.exe" to leave $topdir.
101
102 from topdir we can find package.conf, ghc-asm, etc.
103
104
105 SysTools.initSysProgs figures out exactly where all the auxiliary programs
106 are, and initialises mutable variables to make it easy to call them.
107 To to this, it makes use of definitions in Config.hs, which is a Haskell
108 file containing variables whose value is figured out by the build system.
109
110 Config.hs contains two sorts of things
111
112   cGCC,         The *names* of the programs
113   cCPP            e.g.  cGCC = gcc
114   cUNLIT                cCPP = gcc -E
115   etc           They do *not* include paths
116
117
118   cUNLIT_DIR   The *path* to the directory containing unlit, split etc
119   cSPLIT_DIR   *relative* to the root of the build tree,
120                    for use when running *in-place* in a build tree (only)
121
122
123
124 ---------------------------------------------
125 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
126
127 Another hair-brained scheme for simplifying the current tool location
128 nightmare in GHC: Simon originally suggested using another
129 configuration file along the lines of GCC's specs file - which is fine
130 except that it means adding code to read yet another configuration
131 file.  What I didn't notice is that the current package.conf is
132 general enough to do this:
133
134 Package
135     {name = "tools",    import_dirs = [],  source_dirs = [],
136      library_dirs = [], hs_libraries = [], extra_libraries = [],
137      include_dirs = [], c_includes = [],   package_deps = [],
138      extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
139      extra_cc_opts = [], extra_ld_opts = []}
140
141 Which would have the advantage that we get to collect together in one
142 place the path-specific package stuff with the path-specific tool
143 stuff.
144                 End of NOTES
145 ---------------------------------------------
146
147 %************************************************************************
148 %*                                                                      *
149 \subsection{Initialisation}
150 %*                                                                      *
151 %************************************************************************
152
153 \begin{code}
154 initSysTools :: Maybe String    -- Maybe TopDir path (without the '-B' prefix)
155              -> IO Settings     -- Set all the mutable variables above, holding
156                                 --      (a) the system programs
157                                 --      (b) the package-config file
158                                 --      (c) the GHC usage message
159 initSysTools mbMinusB
160   = do  { top_dir <- findTopDir mbMinusB
161                 -- see [Note topdir]
162                 -- NB: top_dir is assumed to be in standard Unix
163                 -- format, '/' separated
164
165         ; let settingsFile = top_dir </> "settings"
166               installed :: FilePath -> FilePath
167               installed file = top_dir </> file
168
169         ; settingsStr <- readFile settingsFile
170         ; mySettings <- case maybeReadFuzzy settingsStr of
171                         Just s ->
172                             return s
173                         Nothing ->
174                             pgmError ("Can't parse " ++ show settingsFile)
175         ; let getSetting key = case lookup key mySettings of
176                                Just xs ->
177                                    return $ case stripPrefix "$topdir" xs of
178                                             Just [] ->
179                                                 top_dir
180                                             Just xs'@(c:_)
181                                              | isPathSeparator c ->
182                                                 top_dir ++ xs'
183                                             _ ->
184                                                 xs
185                                Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
186               readSetting key = case lookup key mySettings of
187                                 Just xs ->
188                                     case maybeRead xs of
189                                     Just v -> return v
190                                     Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)
191                                 Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
192         ; targetArch <- readSetting "target arch"
193         ; targetOS <- readSetting "target os"
194         ; targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
195         ; targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
196         ; myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
197         -- On Windows, mingw is distributed with GHC,
198         -- so we look in TopDir/../mingw/bin
199         -- It would perhaps be nice to be able to override this
200         -- with the settings file, but it would be a little fiddly
201         -- to make that possible, so for now you can't.
202         ; gcc_prog <- getSetting "C compiler command"
203         ; gcc_args_str <- getSetting "C compiler flags"
204         ; let gcc_args = map Option (words gcc_args_str)
205         ; perl_path <- getSetting "perl command"
206
207         ; let pkgconfig_path = installed "package.conf.d"
208               ghc_usage_msg_path  = installed "ghc-usage.txt"
209               ghci_usage_msg_path = installed "ghci-usage.txt"
210
211                 -- For all systems, unlit, split, mangle are GHC utilities
212                 -- architecture-specific stuff is done when building Config.hs
213               unlit_path = installed cGHC_UNLIT_PGM
214
215                 -- split is a Perl script
216               split_script  = installed cGHC_SPLIT_PGM
217
218         ; windres_path <- getSetting "windres command"
219
220         ; tmpdir <- getTemporaryDirectory
221
222         ; touch_path <- getSetting "touch command"
223
224         ; let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
225               -- a call to Perl to get the invocation of split.
226               -- On Unix, scripts are invoked using the '#!' method.  Binary
227               -- installations of GHC on Unix place the correct line on the
228               -- front of the script at installation time, so we don't want
229               -- to wire-in our knowledge of $(PERL) on the host system here.
230               (split_prog,  split_args)
231                 | isWindowsHost = (perl_path,    [Option split_script])
232                 | otherwise     = (split_script, [])
233         ; mkdll_prog <- getSetting "dllwrap command"
234         ; let mkdll_args = []
235
236         -- cpp is derived from gcc on all platforms
237         -- HACK, see setPgmP below. We keep 'words' here to remember to fix
238         -- Config.hs one day.
239         ; let cpp_prog  = gcc_prog
240               cpp_args  = Option "-E"
241                         : map Option (words cRAWCPP_FLAGS)
242                        ++ gcc_args
243
244         -- Other things being equal, as and ld are simply gcc
245         ; let   as_prog  = gcc_prog
246                 as_args  = gcc_args
247                 ld_prog  = gcc_prog
248                 ld_args  = gcc_args
249
250         -- We just assume on command line
251         ; let lc_prog = "llc"
252               lo_prog = "opt"
253
254         ; return $ Settings {
255                         sTargetPlatform = Platform {
256                                               platformArch = targetArch,
257                                               platformOS   = targetOS,
258                                               platformHasGnuNonexecStack = targetHasGnuNonexecStack,
259                                               platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
260                                           },
261                         sTmpDir = normalise tmpdir,
262                         sGhcUsagePath = ghc_usage_msg_path,
263                         sGhciUsagePath = ghci_usage_msg_path,
264                         sTopDir  = top_dir,
265                         sRawSettings = mySettings,
266                         sExtraGccViaCFlags = words myExtraGccViaCFlags,
267                         sSystemPackageConfig = pkgconfig_path,
268                         sPgm_L   = unlit_path,
269                         sPgm_P   = (cpp_prog, cpp_args),
270                         sPgm_F   = "",
271                         sPgm_c   = (gcc_prog, gcc_args),
272                         sPgm_s   = (split_prog,split_args),
273                         sPgm_a   = (as_prog, as_args),
274                         sPgm_l   = (ld_prog, ld_args),
275                         sPgm_dll = (mkdll_prog,mkdll_args),
276                         sPgm_T   = touch_path,
277                         sPgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
278                         sPgm_windres = windres_path,
279                         sPgm_lo  = (lo_prog,[]),
280                         sPgm_lc  = (lc_prog,[]),
281                         -- Hans: this isn't right in general, but you can
282                         -- elaborate it in the same way as the others
283                         sOpt_L       = [],
284                         sOpt_P       = (if opt_PIC
285                                         then -- this list gets reversed
286                                              ["-D__PIC__", "-U __PIC__"]
287                                         else []),
288                         sOpt_F       = [],
289                         sOpt_c       = [],
290                         sOpt_a       = [],
291                         sOpt_l       = [],
292                         sOpt_windres = [],
293                         sOpt_lo      = [],
294                         sOpt_lc      = []
295                 }
296         }
297 \end{code}
298
299 \begin{code}
300 -- returns a Unix-format path (relying on getBaseDir to do so too)
301 findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix).
302            -> IO String    -- TopDir (in Unix format '/' separated)
303 findTopDir (Just minusb) = return (normalise minusb)
304 findTopDir Nothing
305     = do -- Get directory of executable
306          maybe_exec_dir <- getBaseDir
307          case maybe_exec_dir of
308              -- "Just" on Windows, "Nothing" on unix
309              Nothing  -> ghcError (InstallationError "missing -B<dir> option")
310              Just dir -> return dir
311 \end{code}
312
313
314 %************************************************************************
315 %*                                                                      *
316 \subsection{Running an external program}
317 %*                                                                      *
318 %************************************************************************
319
320
321 \begin{code}
322 runUnlit :: DynFlags -> [Option] -> IO ()
323 runUnlit dflags args = do
324   let p = pgm_L dflags
325   runSomething dflags "Literate pre-processor" p args
326
327 runCpp :: DynFlags -> [Option] -> IO ()
328 runCpp dflags args =   do
329   let (p,args0) = pgm_P dflags
330       args1 = args0 ++ args
331       args2 = if dopt Opt_WarnIsError dflags
332               then Option "-Werror" : args1
333               else                    args1
334   mb_env <- getGccEnv args2
335   runSomethingFiltered dflags id  "C pre-processor" p args2 mb_env
336
337 runPp :: DynFlags -> [Option] -> IO ()
338 runPp dflags args =   do
339   let p = pgm_F dflags
340   runSomething dflags "Haskell pre-processor" p args
341
342 runCc :: DynFlags -> [Option] -> IO ()
343 runCc dflags args =   do
344   let (p,args0) = pgm_c dflags
345       args1 = args0 ++ args
346   mb_env <- getGccEnv args1
347   runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
348  where
349   -- discard some harmless warnings from gcc that we can't turn off
350   cc_filter = unlines . doFilter . lines
351
352   {-
353   gcc gives warnings in chunks like so:
354       In file included from /foo/bar/baz.h:11,
355                        from /foo/bar/baz2.h:22,
356                        from wibble.c:33:
357       /foo/flibble:14: global register variable ...
358       /foo/flibble:15: warning: call-clobbered r...
359   We break it up into its chunks, remove any call-clobbered register
360   warnings from each chunk, and then delete any chunks that we have
361   emptied of warnings.
362   -}
363   doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
364   -- We can't assume that the output will start with an "In file inc..."
365   -- line, so we start off expecting a list of warnings rather than a
366   -- location stack.
367   chunkWarnings :: [String] -- The location stack to use for the next
368                             -- list of warnings
369                 -> [String] -- The remaining lines to look at
370                 -> [([String], [String])]
371   chunkWarnings loc_stack [] = [(loc_stack, [])]
372   chunkWarnings loc_stack xs
373       = case break loc_stack_start xs of
374         (warnings, lss:xs') ->
375             case span loc_start_continuation xs' of
376             (lsc, xs'') ->
377                 (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
378         _ -> [(loc_stack, xs)]
379
380   filterWarnings :: [([String], [String])] -> [([String], [String])]
381   filterWarnings [] = []
382   -- If the warnings are already empty then we are probably doing
383   -- something wrong, so don't delete anything
384   filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
385   filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
386                                        [] -> filterWarnings zs
387                                        ys' -> (xs, ys') : filterWarnings zs
388
389   unChunkWarnings :: [([String], [String])] -> [String]
390   unChunkWarnings [] = []
391   unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
392
393   loc_stack_start        s = "In file included from " `isPrefixOf` s
394   loc_start_continuation s = "                 from " `isPrefixOf` s
395   wantedWarning w
396    | "warning: call-clobbered register used" `isContainedIn` w = False
397    | otherwise = True
398
399 isContainedIn :: String -> String -> Bool
400 xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
401
402 askCc :: DynFlags -> [Option] -> IO String
403 askCc dflags args = do
404   let (p,args0) = pgm_c dflags
405       args1 = args0 ++ args
406   mb_env <- getGccEnv args1
407   runSomethingWith dflags "gcc" p args1 $ \real_args ->
408     readCreateProcess (proc p real_args){ env = mb_env }
409
410 -- Version of System.Process.readProcessWithExitCode that takes an environment
411 readCreateProcess
412     :: CreateProcess
413     -> IO (ExitCode, String)    -- ^ stdout
414 readCreateProcess proc = do
415     (_, Just outh, _, pid) <-
416         createProcess proc{ std_out = CreatePipe }
417
418     -- fork off a thread to start consuming the output
419     output  <- hGetContents outh
420     outMVar <- newEmptyMVar
421     _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
422
423     -- wait on the output
424     takeMVar outMVar
425     hClose outh
426
427     -- wait on the process
428     ex <- waitForProcess pid
429
430     return (ex, output)
431
432
433 -- If the -B<dir> option is set, add <dir> to PATH.  This works around
434 -- a bug in gcc on Windows Vista where it can't find its auxiliary
435 -- binaries (see bug #1110).
436 getGccEnv :: [Option] -> IO (Maybe [(String,String)])
437 getGccEnv opts =
438   if null b_dirs
439      then return Nothing
440      else do env <- getEnvironment
441              return (Just (map mangle_path env))
442  where
443   (b_dirs, _) = partitionWith get_b_opt opts
444
445   get_b_opt (Option ('-':'B':dir)) = Left dir
446   get_b_opt other = Right other
447
448   mangle_path (path,paths) | map toUpper path == "PATH"
449         = (path, '\"' : head b_dirs ++ "\";" ++ paths)
450   mangle_path other = other
451
452 runSplit :: DynFlags -> [Option] -> IO ()
453 runSplit dflags args = do
454   let (p,args0) = pgm_s dflags
455   runSomething dflags "Splitter" p (args0++args)
456
457 runAs :: DynFlags -> [Option] -> IO ()
458 runAs dflags args = do
459   let (p,args0) = pgm_a dflags
460       args1 = args0 ++ args
461   mb_env <- getGccEnv args1
462   runSomethingFiltered dflags id "Assembler" p args1 mb_env
463
464 -- | Run the LLVM Optimiser
465 runLlvmOpt :: DynFlags -> [Option] -> IO ()
466 runLlvmOpt dflags args = do
467   let (p,args0) = pgm_lo dflags
468   runSomething dflags "LLVM Optimiser" p (args0++args)
469
470 -- | Run the LLVM Compiler
471 runLlvmLlc :: DynFlags -> [Option] -> IO ()
472 runLlvmLlc dflags args = do
473   let (p,args0) = pgm_lc dflags
474   runSomething dflags "LLVM Compiler" p (args0++args)
475
476 -- | Figure out which version of LLVM we are running this session
477 figureLlvmVersion :: DynFlags -> IO (Maybe Int)
478 figureLlvmVersion dflags = do
479   let (pgm,opts) = pgm_lc dflags
480       args = filter notNull (map showOpt opts)
481       -- we grab the args even though they should be useless just in
482       -- case the user is using a customised 'llc' that requires some
483       -- of the options they've specified. llc doesn't care what other
484       -- options are specified when '-version' is used.
485       args' = args ++ ["-version"]
486   ver <- catchIO (do
487              (pin, pout, perr, _) <- runInteractiveProcess pgm args'
488                                              Nothing Nothing
489              {- > llc -version
490                   Low Level Virtual Machine (http://llvm.org/):
491                     llvm version 2.8 (Ubuntu 2.8-0Ubuntu1)
492                     ...
493              -}
494              hSetBinaryMode pout False
495              _     <- hGetLine pout
496              vline <- hGetLine pout
497              v     <- case filter isDigit vline of
498                             []      -> fail "no digits!"
499                             [x]     -> fail $ "only 1 digit! (" ++ show x ++ ")"
500                             (x:y:_) -> return ((read [x,y]) :: Int)
501              hClose pin
502              hClose pout
503              hClose perr
504              return $ Just v
505             )
506             (\err -> do
507                 putMsg dflags $ text $ "Error (" ++ show err ++ ")"
508                 putMsg dflags $ text "Warning: Couldn't figure out LLVM version!"
509                 putMsg dflags $ text "Make sure you have installed LLVM"
510                 return Nothing)
511   return ver
512   
513
514 runLink :: DynFlags -> [Option] -> IO ()
515 runLink dflags args = do
516   let (p,args0) = pgm_l dflags
517       args1 = args0 ++ args
518   mb_env <- getGccEnv args1
519   runSomethingFiltered dflags id "Linker" p args1 mb_env
520
521 runMkDLL :: DynFlags -> [Option] -> IO ()
522 runMkDLL dflags args = do
523   let (p,args0) = pgm_dll dflags
524       args1 = args0 ++ args
525   mb_env <- getGccEnv (args0++args)
526   runSomethingFiltered dflags id "Make DLL" p args1 mb_env
527
528 runWindres :: DynFlags -> [Option] -> IO ()
529 runWindres dflags args = do
530   let (gcc, gcc_args) = pgm_c dflags
531       windres = pgm_windres dflags
532       quote x = "\"" ++ x ++ "\""
533       args' = -- If windres.exe and gcc.exe are in a directory containing
534               -- spaces then windres fails to run gcc. We therefore need
535               -- to tell it what command to use...
536               Option ("--preprocessor=" ++
537                       unwords (map quote (gcc :
538                                           map showOpt gcc_args ++
539                                           ["-E", "-xc", "-DRC_INVOKED"])))
540               -- ...but if we do that then if windres calls popen then
541               -- it can't understand the quoting, so we have to use
542               -- --use-temp-file so that it interprets it correctly.
543               -- See #1828.
544             : Option "--use-temp-file"
545             : args
546   mb_env <- getGccEnv gcc_args
547   runSomethingFiltered dflags id "Windres" windres args' mb_env
548
549 touch :: DynFlags -> String -> String -> IO ()
550 touch dflags purpose arg =
551   runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
552
553 copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
554 copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
555
556 copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
557                -> IO ()
558 copyWithHeader dflags purpose maybe_header from to = do
559   showPass dflags purpose
560
561   hout <- openBinaryFile to   WriteMode
562   hin  <- openBinaryFile from ReadMode
563   ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
564   maybe (return ()) (hPutStr hout) maybe_header
565   hPutStr hout ls
566   hClose hout
567   hClose hin
568
569 -- | read the contents of the named section in an ELF object as a
570 -- String.
571 readElfSection :: DynFlags -> String -> FilePath -> IO (Maybe String)
572 readElfSection _dflags section exe = do
573   let
574      prog = "readelf"
575      args = [Option "-p", Option section, FileOption "" exe]
576   --
577   r <- readProcessWithExitCode prog (filter notNull (map showOpt args)) ""
578   case r of
579     (ExitSuccess, out, _err) -> return (doFilter (lines out))
580     _ -> return Nothing
581  where
582   doFilter [] = Nothing
583   doFilter (s:r) = case readP_to_S parse s of
584                     [(p,"")] -> Just p
585                     _r       -> doFilter r
586    where parse = do
587            skipSpaces; R.char '['; skipSpaces; string "0]"; skipSpaces;
588            munch (const True)
589 \end{code}
590
591 %************************************************************************
592 %*                                                                      *
593 \subsection{Managing temporary files
594 %*                                                                      *
595 %************************************************************************
596
597 \begin{code}
598 cleanTempDirs :: DynFlags -> IO ()
599 cleanTempDirs dflags
600    = unless (dopt Opt_KeepTmpFiles dflags)
601    $ do let ref = dirsToClean dflags
602         ds <- readIORef ref
603         removeTmpDirs dflags (Map.elems ds)
604         writeIORef ref Map.empty
605
606 cleanTempFiles :: DynFlags -> IO ()
607 cleanTempFiles dflags
608    = unless (dopt Opt_KeepTmpFiles dflags)
609    $ do let ref = filesToClean dflags
610         fs <- readIORef ref
611         removeTmpFiles dflags fs
612         writeIORef ref []
613
614 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
615 cleanTempFilesExcept dflags dont_delete
616    = unless (dopt Opt_KeepTmpFiles dflags)
617    $ do let ref = filesToClean dflags
618         files <- readIORef ref
619         let (to_keep, to_delete) = partition (`elem` dont_delete) files
620         writeIORef ref to_keep
621         removeTmpFiles dflags to_delete
622
623
624 -- find a temporary name that doesn't already exist.
625 newTempName :: DynFlags -> Suffix -> IO FilePath
626 newTempName dflags extn
627   = do d <- getTempDir dflags
628        x <- getProcessID
629        findTempName (d </> "ghc" ++ show x ++ "_") 0
630   where
631     findTempName :: FilePath -> Integer -> IO FilePath
632     findTempName prefix x
633       = do let filename = (prefix ++ show x) <.> extn
634            b  <- doesFileExist filename
635            if b then findTempName prefix (x+1)
636                 else do -- clean it up later
637                         consIORef (filesToClean dflags) filename
638                         return filename
639
640 -- return our temporary directory within tmp_dir, creating one if we
641 -- don't have one yet
642 getTempDir :: DynFlags -> IO FilePath
643 getTempDir dflags
644   = do let ref = dirsToClean dflags
645            tmp_dir = tmpDir dflags
646        mapping <- readIORef ref
647        case Map.lookup tmp_dir mapping of
648            Nothing ->
649                do x <- getProcessID
650                   let prefix = tmp_dir </> "ghc" ++ show x ++ "_"
651                   let
652                       mkTempDir :: Integer -> IO FilePath
653                       mkTempDir x
654                        = let dirname = prefix ++ show x
655                          in do createDirectory dirname
656                                let mapping' = Map.insert tmp_dir dirname mapping
657                                writeIORef ref mapping'
658                                debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname)
659                                return dirname
660                             `catchIO` \e ->
661                                     if isAlreadyExistsError e
662                                     then mkTempDir (x+1)
663                                     else ioError e
664                   mkTempDir 0
665            Just d -> return d
666
667 addFilesToClean :: DynFlags -> [FilePath] -> IO ()
668 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
669 addFilesToClean dflags files = mapM_ (consIORef (filesToClean dflags)) files
670
671 removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
672 removeTmpDirs dflags ds
673   = traceCmd dflags "Deleting temp dirs"
674              ("Deleting: " ++ unwords ds)
675              (mapM_ (removeWith dflags removeDirectory) ds)
676
677 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
678 removeTmpFiles dflags fs
679   = warnNon $
680     traceCmd dflags "Deleting temp files"
681              ("Deleting: " ++ unwords deletees)
682              (mapM_ (removeWith dflags removeFile) deletees)
683   where
684      -- Flat out refuse to delete files that are likely to be source input
685      -- files (is there a worse bug than having a compiler delete your source
686      -- files?)
687      --
688      -- Deleting source files is a sign of a bug elsewhere, so prominently flag
689      -- the condition.
690     warnNon act
691      | null non_deletees = act
692      | otherwise         = do
693         putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
694         act
695
696     (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
697
698 removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
699 removeWith dflags remover f = remover f `catchIO`
700   (\e ->
701    let msg = if isDoesNotExistError e
702              then ptext (sLit "Warning: deleting non-existent") <+> text f
703              else ptext (sLit "Warning: exception raised when deleting")
704                                             <+> text f <> colon
705                $$ text (show e)
706    in debugTraceMsg dflags 2 msg
707   )
708
709 -----------------------------------------------------------------------------
710 -- Running an external program
711
712 runSomething :: DynFlags
713              -> String          -- For -v message
714              -> String          -- Command name (possibly a full path)
715                                 --      assumed already dos-ified
716              -> [Option]        -- Arguments
717                                 --      runSomething will dos-ify them
718              -> IO ()
719
720 runSomething dflags phase_name pgm args =
721   runSomethingFiltered dflags id phase_name pgm args Nothing
722
723 runSomethingFiltered
724   :: DynFlags -> (String->String) -> String -> String -> [Option]
725   -> Maybe [(String,String)] -> IO ()
726
727 runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
728     runSomethingWith dflags phase_name pgm args $ \real_args -> do
729         r <- builderMainLoop dflags filter_fn pgm real_args mb_env
730         return (r,())
731
732 runSomethingWith
733   :: DynFlags -> String -> String -> [Option]
734   -> ([String] -> IO (ExitCode, a))
735   -> IO a
736
737 runSomethingWith dflags phase_name pgm args io = do
738   let real_args = filter notNull (map showOpt args)
739 #if __GLASGOW_HASKELL__ >= 701
740       cmdLine = showCommandForUser pgm real_args
741 #else
742       cmdLine = unwords (pgm:real_args)
743 #endif
744   traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
745
746 handleProc :: String -> String -> IO (ExitCode, r) -> IO r
747 handleProc pgm phase_name proc = do
748     (rc, r) <- proc `catchIO` handler
749     case rc of
750       ExitSuccess{} -> return r
751       ExitFailure n
752         -- rawSystem returns (ExitFailure 127) if the exec failed for any
753         -- reason (eg. the program doesn't exist).  This is the only clue
754         -- we have, but we need to report something to the user because in
755         -- the case of a missing program there will otherwise be no output
756         -- at all.
757        | n == 127  -> does_not_exist
758        | otherwise -> ghcError (PhaseFailed phase_name rc)
759   where
760     handler err =
761        if IO.isDoesNotExistError err
762           then does_not_exist
763           else IO.ioError err
764
765     does_not_exist = ghcError (InstallationError ("could not execute: " ++ pgm))
766
767
768 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
769                 -> [String] -> Maybe [(String, String)]
770                 -> IO ExitCode
771 builderMainLoop dflags filter_fn pgm real_args mb_env = do
772   chan <- newChan
773   (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
774
775   -- and run a loop piping the output from the compiler to the log_action in DynFlags
776   hSetBuffering hStdOut LineBuffering
777   hSetBuffering hStdErr LineBuffering
778   _ <- forkIO (readerProc chan hStdOut filter_fn)
779   _ <- forkIO (readerProc chan hStdErr filter_fn)
780   -- we don't want to finish until 2 streams have been completed
781   -- (stdout and stderr)
782   -- nor until 1 exit code has been retrieved.
783   rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
784   -- after that, we're done here.
785   hClose hStdIn
786   hClose hStdOut
787   hClose hStdErr
788   return rc
789   where
790     -- status starts at zero, and increments each time either
791     -- a reader process gets EOF, or the build proc exits.  We wait
792     -- for all of these to happen (status==3).
793     -- ToDo: we should really have a contingency plan in case any of
794     -- the threads dies, such as a timeout.
795     loop _    _        0 0 exitcode = return exitcode
796     loop chan hProcess t p exitcode = do
797       mb_code <- if p > 0
798                    then getProcessExitCode hProcess
799                    else return Nothing
800       case mb_code of
801         Just code -> loop chan hProcess t (p-1) code
802         Nothing
803           | t > 0 -> do
804               msg <- readChan chan
805               case msg of
806                 BuildMsg msg -> do
807                   log_action dflags SevInfo noSrcSpan defaultUserStyle msg
808                   loop chan hProcess t p exitcode
809                 BuildError loc msg -> do
810                   log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
811                   loop chan hProcess t p exitcode
812                 EOF ->
813                   loop chan hProcess (t-1) p exitcode
814           | otherwise -> loop chan hProcess t p exitcode
815
816 readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
817 readerProc chan hdl filter_fn =
818     (do str <- hGetContents hdl
819         loop (linesPlatform (filter_fn str)) Nothing)
820     `finally`
821        writeChan chan EOF
822         -- ToDo: check errors more carefully
823         -- ToDo: in the future, the filter should be implemented as
824         -- a stream transformer.
825     where
826         loop []     Nothing    = return ()
827         loop []     (Just err) = writeChan chan err
828         loop (l:ls) in_err     =
829                 case in_err of
830                   Just err@(BuildError srcLoc msg)
831                     | leading_whitespace l -> do
832                         loop ls (Just (BuildError srcLoc (msg $$ text l)))
833                     | otherwise -> do
834                         writeChan chan err
835                         checkError l ls
836                   Nothing -> do
837                         checkError l ls
838                   _ -> panic "readerProc/loop"
839
840         checkError l ls
841            = case parseError l of
842                 Nothing -> do
843                     writeChan chan (BuildMsg (text l))
844                     loop ls Nothing
845                 Just (file, lineNum, colNum, msg) -> do
846                     let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
847                     loop ls (Just (BuildError srcLoc (text msg)))
848
849         leading_whitespace []    = False
850         leading_whitespace (x:_) = isSpace x
851
852 parseError :: String -> Maybe (String, Int, Int, String)
853 parseError s0 = case breakColon s0 of
854                 Just (filename, s1) ->
855                     case breakIntColon s1 of
856                     Just (lineNum, s2) ->
857                         case breakIntColon s2 of
858                         Just (columnNum, s3) ->
859                             Just (filename, lineNum, columnNum, s3)
860                         Nothing ->
861                             Just (filename, lineNum, 0, s2)
862                     Nothing -> Nothing
863                 Nothing -> Nothing
864
865 breakColon :: String -> Maybe (String, String)
866 breakColon xs = case break (':' ==) xs of
867                     (ys, _:zs) -> Just (ys, zs)
868                     _ -> Nothing
869
870 breakIntColon :: String -> Maybe (Int, String)
871 breakIntColon xs = case break (':' ==) xs of
872                        (ys, _:zs)
873                         | not (null ys) && all isAscii ys && all isDigit ys ->
874                            Just (read ys, zs)
875                        _ -> Nothing
876
877 data BuildMessage
878   = BuildMsg   !SDoc
879   | BuildError !SrcLoc !SDoc
880   | EOF
881
882 traceCmd :: DynFlags -> String -> String -> IO a -> IO a
883 -- trace the command (at two levels of verbosity)
884 traceCmd dflags phase_name cmd_line action
885  = do   { let verb = verbosity dflags
886         ; showPass dflags phase_name
887         ; debugTraceMsg dflags 3 (text cmd_line)
888         ; hFlush stderr
889
890            -- And run it!
891         ; action `catchIO` handle_exn verb
892         }
893   where
894     handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
895                               ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
896                               ; ghcError (PhaseFailed phase_name (ExitFailure 1)) }
897 \end{code}
898
899 %************************************************************************
900 %*                                                                      *
901 \subsection{Support code}
902 %*                                                                      *
903 %************************************************************************
904
905 \begin{code}
906 -----------------------------------------------------------------------------
907 -- Define       getBaseDir     :: IO (Maybe String)
908
909 getBaseDir :: IO (Maybe String)
910 #if defined(mingw32_HOST_OS)
911 -- Assuming we are running ghc, accessed by path  $(stuff)/bin/ghc.exe,
912 -- return the path $(stuff)/lib.
913 getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
914   where
915     try_size size = allocaArray (fromIntegral size) $ \buf -> do
916         ret <- c_GetModuleFileName nullPtr buf size
917         case ret of
918           0 -> return Nothing
919           _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf
920             | otherwise  -> try_size (size * 2)
921     
922     rootDir s = case splitFileName $ normalise s of
923                 (d, ghc_exe)
924                  | lower ghc_exe `elem` ["ghc.exe",
925                                          "ghc-stage1.exe",
926                                          "ghc-stage2.exe",
927                                          "ghc-stage3.exe"] ->
928                     case splitFileName $ takeDirectory d of
929                     -- ghc is in $topdir/bin/ghc.exe
930                     (d', bin) | lower bin == "bin" -> takeDirectory d' </> "lib"
931                     _ -> fail
932                 _ -> fail
933         where fail = panic ("can't decompose ghc.exe path: " ++ show s)
934               lower = map toLower
935
936 foreign import stdcall unsafe "windows.h GetModuleFileNameW"
937   c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
938 #else
939 getBaseDir = return Nothing
940 #endif
941
942 #ifdef mingw32_HOST_OS
943 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
944 #else
945 getProcessID :: IO Int
946 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
947 #endif
948
949 -- Divvy up text stream into lines, taking platform dependent
950 -- line termination into account.
951 linesPlatform :: String -> [String]
952 #if !defined(mingw32_HOST_OS)
953 linesPlatform ls = lines ls
954 #else
955 linesPlatform "" = []
956 linesPlatform xs =
957   case lineBreak xs of
958     (as,xs1) -> as : linesPlatform xs1
959   where
960    lineBreak "" = ("","")
961    lineBreak ('\r':'\n':xs) = ([],xs)
962    lineBreak ('\n':xs) = ([],xs)
963    lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
964
965 #endif
966
967 \end{code}