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