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