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