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