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