SysTools.lhs 33.6 KB
Newer Older
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 12 13
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
14
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
15 16
-- for details

17 18 19
module SysTools (
	-- Initialisation
	initSysTools,
20

21
	-- Interface to system tools
sof's avatar
sof committed
22
	runUnlit, runCpp, runCc, -- [Option] -> IO ()
sof's avatar
sof committed
23
	runPp,                   -- [Option] -> IO ()
sof's avatar
sof committed
24 25
	runMangle, runSplit,	 -- [Option] -> IO ()
	runAs, runLink,		 -- [Option] -> IO ()
26
	runMkDLL,
27
        runWindres,
28 29

	touch,			-- String -> String -> IO ()
30 31
	copy,
        copyWithHeader,
32
        getExtraViaCOpts,
33 34 35 36
	
	-- Temporary-file management
	setTmpDir,
	newTempName,
37
	cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
38 39
	addFilesToClean,

sof's avatar
sof committed
40
	Option(..)
41 42 43

 ) where

44 45
#include "HsVersions.h"

Simon Marlow's avatar
Simon Marlow committed
46
import DriverPhases
47
import Config
48
import Outputable
Simon Marlow's avatar
Simon Marlow committed
49 50 51 52 53 54 55 56 57 58 59
import ErrUtils
import Panic
import Util
import DynFlags
import FiniteMap

import Control.Exception
import Data.IORef
import Control.Monad
import System.Exit
import System.Environment
Ian Lynagh's avatar
Ian Lynagh committed
60
import System.FilePath
Simon Marlow's avatar
Simon Marlow committed
61 62 63
import System.IO
import SYSTEM_IO_ERROR as IO
import System.Directory
64
import Data.Char
Simon Marlow's avatar
Simon Marlow committed
65 66
import Data.Maybe
import Data.List
67

68
#ifndef mingw32_HOST_OS
69
import qualified System.Posix.Internals
70
#else /* Must be Win32 */
sof's avatar
sof committed
71
import Foreign
72
import CString		( CString, peekCString )
rrt's avatar
rrt committed
73 74
#endif

75
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
76
-- rawSystem comes from libghccompat.a in stage1
Ian Lynagh's avatar
Ian Lynagh committed
77 78
import Compat.RawSystem ( rawSystem )
import System.Cmd       ( system )
sof's avatar
sof committed
79
import GHC.IOBase       ( IOErrorType(..) ) 
80
#else
81 82 83 84
import System.Process	( runInteractiveProcess, getProcessExitCode )
import Control.Concurrent( forkIO, newChan, readChan, writeChan )
import FastString       ( mkFastString )
import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
85
#endif
86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120
\end{code}


		The configuration story
		~~~~~~~~~~~~~~~~~~~~~~~

GHC needs various support files (library packages, RTS etc), plus
various auxiliary programs (cp, gcc, etc).  It finds these in one
of two places:

* When running as an *installed program*, GHC finds most of this support
  stuff in the installed library tree.  The path to this tree is passed
  to GHC via the -B flag, and given to initSysTools .

* When running *in-place* in a build tree, GHC finds most of this support
  stuff in the build tree.  The path to the build tree is, again passed
  to GHC via -B. 

GHC tells which of the two is the case by seeing whether package.conf
is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).


SysTools.initSysProgs figures out exactly where all the auxiliary programs
are, and initialises mutable variables to make it easy to call them.
To to this, it makes use of definitions in Config.hs, which is a Haskell
file containing variables whose value is figured out by the build system.

Config.hs contains two sorts of things

  cGCC, 	The *names* of the programs
  cCPP		  e.g.  cGCC = gcc
  cUNLIT	        cCPP = gcc -E
  etc		They do *not* include paths
				

121 122 123
  cUNLIT_DIR_REL   The *path* to the directory containing unlit, split etc
  cSPLIT_DIR_REL   *relative* to the root of the build tree,
		   for use when running *in-place* in a build tree (only)
124 125 126
		


127 128 129 130 131 132 133 134 135 136 137 138 139 140
---------------------------------------------
NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):

Another hair-brained scheme for simplifying the current tool location
nightmare in GHC: Simon originally suggested using another
configuration file along the lines of GCC's specs file - which is fine
except that it means adding code to read yet another configuration
file.  What I didn't notice is that the current package.conf is
general enough to do this:

Package
    {name = "tools",    import_dirs = [],  source_dirs = [],
     library_dirs = [], hs_libraries = [], extra_libraries = [],
     include_dirs = [], c_includes = [],   package_deps = [],
141
     extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
142 143 144 145 146 147 148 149
     extra_cc_opts = [], extra_ld_opts = []}

Which would have the advantage that we get to collect together in one
place the path-specific package stuff with the path-specific tool
stuff.
		End of NOTES
---------------------------------------------

150 151 152 153 154 155 156
%************************************************************************
%*									*
\subsection{Initialisation}
%*									*
%************************************************************************

\begin{code}
157
initSysTools :: Maybe String	-- Maybe TopDir path (without the '-B' prefix)
158

159 160
	     -> DynFlags
	     -> IO DynFlags	-- Set all the mutable variables above, holding 
161 162 163
				--	(a) the system programs
				--	(b) the package-config file
				--	(c) the GHC usage message
164 165


166 167
initSysTools mbMinusB dflags
  = do  { (am_installed, top_dir) <- findTopDir mbMinusB
168 169 170
		-- top_dir
		-- 	for "installed" this is the root of GHC's support files
		--	for "in-place" it is the root of the build tree
171 172
		-- NB: top_dir is assumed to be in standard Unix
		-- format, '/' separated
173

174
	; let installed, installed_bin :: FilePath -> FilePath
Ian Lynagh's avatar
Ian Lynagh committed
175 176
              installed_bin pgm   =  top_dir </> pgm
	      installed     file  =  top_dir </> file
177 178 179 180 181 182 183
	      inplace dir   pgm   =  top_dir </> 
#ifndef darwin_TARGET_OS
-- Not sure where cPROJECT_DIR makes sense, on Mac OS, building with
-- xcodebuild, it surely is a *bad* idea!  -=chak
                                     cPROJECT_DIR </> 
#endif
                                     dir </> pgm
184

185 186
	; let pkgconfig_path
		| am_installed = installed "package.conf"
187
		| otherwise    = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
188

189 190
	      ghc_usage_msg_path
		| am_installed = installed "ghc-usage.txt"
191
		| otherwise    = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
192

193 194 195 196
	      ghci_usage_msg_path
		| am_installed = installed "ghci-usage.txt"
		| otherwise    = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"

197 198 199
		-- For all systems, unlit, split, mangle are GHC utilities
		-- architecture-specific stuff is done when building Config.hs
	      unlit_path
200 201
		| am_installed = installed_bin cGHC_UNLIT_PGM
		| otherwise    = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
202 203

		-- split and mangle are Perl scripts
204
	      split_script
205 206
		| am_installed = installed_bin cGHC_SPLIT_PGM
		| otherwise    = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
207

208
	      mangle_script
209 210
		| am_installed = installed_bin cGHC_MANGLER_PGM
		| otherwise    = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
211

212
              windres_path
213
		| am_installed = installed_bin "bin/windres"
214 215
		| otherwise    = "windres"

216
	; let dflags0 = defaultDynFlags
217
#ifndef mingw32_HOST_OS
218
	-- check whether TMPDIR is set in the environment
219
	; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
sof's avatar
sof committed
220 221 222 223
#else
	  -- On Win32, consult GetTempPath() for a temp dir.
	  --  => it first tries TMP, TEMP, then finally the
	  --   Windows directory(!). The directory is in short-path
sof's avatar
sof committed
224
	  --   form.
225 226
	; e_tmpdir <- 
            IO.try (do
sof's avatar
sof committed
227 228 229
	        let len = (2048::Int)
		buf  <- mallocArray len
		ret  <- getTempPath len buf
230
		if ret == 0 then do
sof's avatar
sof committed
231
		      -- failed, consult TMPDIR.
sof's avatar
sof committed
232
 	             free buf
sof's avatar
sof committed
233
		     getEnv "TMPDIR"
234
		  else do
sof's avatar
sof committed
235
		     s <- peekCString buf
sof's avatar
sof committed
236
		     free buf
237
		     return s)
238
#endif
239 240 241
        ; let dflags1 = case e_tmpdir of
			  Left _  -> dflags0
			  Right d -> setTmpDir d dflags0
242

243 244 245 246
	-- Check that the package config exists
	; config_exists <- doesFileExist pkgconfig_path
	; when (not config_exists) $
	     throwDyn (InstallationError 
rrt's avatar
rrt committed
247
		         ("Can't find package.conf as " ++ pkgconfig_path))
248

249
#if defined(mingw32_HOST_OS)
250 251 252 253 254
	--		WINDOWS-SPECIFIC STUFF
	-- On Windows, gcc and friends are distributed with GHC,
	-- 	so when "installed" we look in TopDir/bin
	-- When "in-place" we look wherever the build-time configure 
	--	script found them
255 256 257 258 259 260 261 262
	-- When "install" we tell gcc where its specs file + exes are (-B)
	--	and also some places to pick up include files.  We need
	--	to be careful to put all necessary exes in the -B place
	--	(as, ld, cc1, etc) since if they don't get found there, gcc
	--	then tries to run unadorned "as", "ld", etc, and will
	--	pick up whatever happens to be lying around in the path,
	--	possibly including those from a cygwin install on the target,
	--	which is exactly what we're trying to avoid.
263 264 265 266
	; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
	      (gcc_prog,gcc_args)
		| am_installed = (installed_bin "gcc", [gcc_b_arg])
		| otherwise    = (cGCC, [])
rrt's avatar
rrt committed
267
		-- The trailing "/" is absolutely essential; gcc seems
268 269 270 271 272
		-- to construct file names simply by concatenating to
		-- this -B path with no extra slash We use "/" rather
		-- than "\\" because otherwise "\\\" is mangled
		-- later on; although gcc_args are in NATIVE format,
		-- gcc can cope
273 274
		--	(see comments with declarations of global variables)

275
	      perl_path | am_installed = installed_bin cGHC_PERL
276 277 278
		        | otherwise    = cGHC_PERL

	-- 'touch' is a GHC util for Windows, and similarly unlit, mangle
279 280
	; let touch_path  | am_installed = installed_bin cGHC_TOUCHY_PGM
		       	  | otherwise    = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
281

282 283
	-- On Win32 we don't want to rely on #!/bin/perl, so we prepend 
	-- a call to Perl to get the invocation of split and mangle
284 285 286 287 288
	; let (split_prog,  split_args)  = (perl_path, [Option split_script])
	      (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])

	; let (mkdll_prog, mkdll_args)
	        | am_installed = 
Ian Lynagh's avatar
Ian Lynagh committed
289
		    (installed "gcc-lib/" </> cMKDLL,
290
		     [ Option "--dlltool-name",
Ian Lynagh's avatar
Ian Lynagh committed
291
		       Option (installed "gcc-lib/" </> "dlltool"),
292 293 294
		       Option "--driver-name",
		       Option gcc_prog, gcc_b_arg ])
		| otherwise    = (cMKDLL, [])
295 296 297 298 299
#else
	--		UNIX-SPECIFIC STUFF
	-- On Unix, the "standard" tools are assumed to be
	-- in the same place whether we are running "in-place" or "installed"
	-- That place is wherever the build-time configure script found them.
300 301
	; let   gcc_prog   = cGCC
		gcc_args   = []
302
		touch_path = "touch"
303 304
		mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
		mkdll_args = []
305

306 307 308 309
	-- On Unix, scripts are invoked using the '#!' method.  Binary
	-- installations of GHC on Unix place the correct line on the front
	-- of the script at installation time, so we don't want to wire-in
	-- our knowledge of $(PERL) on the host system here.
310 311
	; let (split_prog,  split_args)  = (split_script,  [])
	      (mangle_prog, mangle_args) = (mangle_script, [])
312
#endif
313

314
	-- cpp is derived from gcc on all platforms
315 316
        -- HACK, see setPgmP below. We keep 'words' here to remember to fix
        -- Config.hs one day.
317 318
        ; let cpp_path  = (gcc_prog, gcc_args ++ 
			   (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
319

rrt's avatar
rrt committed
320
	-- For all systems, copy and remove are provided by the host
321 322 323 324
	-- system; architecture-specific stuff is done when building Config.hs
	; let	cp_path = cGHC_CP
	
	-- Other things being equal, as and ld are simply gcc
325 326
	; let	(as_prog,as_args)  = (gcc_prog,gcc_args)
		(ld_prog,ld_args)  = (gcc_prog,gcc_args)
327

328
	; return dflags1{
329 330 331 332
                        ghcUsagePath = ghc_usage_msg_path,
                        ghciUsagePath = ghci_usage_msg_path,
                        topDir  = top_dir,
                        systemPackageConfig = pkgconfig_path,
333 334 335 336 337 338 339 340
			pgm_L	= unlit_path,
			pgm_P	= cpp_path,
			pgm_F	= "",
			pgm_c	= (gcc_prog,gcc_args),
			pgm_m	= (mangle_prog,mangle_args),
			pgm_s   = (split_prog,split_args),
			pgm_a   = (as_prog,as_args),
			pgm_l	= (ld_prog,ld_args),
341 342
			pgm_dll = (mkdll_prog,mkdll_args),
                        pgm_T   = touch_path,
343 344
                        pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan",
                        pgm_windres = windres_path
345 346 347
        		-- Hans: this isn't right in general, but you can 
        		-- elaborate it in the same way as the others
                }
348
	}
sof's avatar
sof committed
349

350
#if defined(mingw32_HOST_OS)
sof's avatar
sof committed
351
foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
sof's avatar
sof committed
352
#endif
353 354
\end{code}

355 356 357 358 359 360 361
\begin{code}
-- Find TopDir
-- 	for "installed" this is the root of GHC's support files
--	for "in-place" it is the root of the build tree
--
-- Plan of action:
-- 1. Set proto_top_dir
362 363
--	if there is no given TopDir path, get the directory 
--	where GHC is running (only on Windows)
364 365 366 367 368 369 370 371 372 373
--
-- 2. If package.conf exists in proto_top_dir, we are running
--	installed; and TopDir = proto_top_dir
--
-- 3. Otherwise we are running in-place, so
--	proto_top_dir will be /...stuff.../ghc/compiler
--	Set TopDir to /...stuff..., which is the root of the build tree
--
-- This is very gruesome indeed

374 375 376
findTopDir :: Maybe String   -- Maybe TopDir path (without the '-B' prefix).
           -> IO (Bool,      -- True <=> am installed, False <=> in-place
                  String)    -- TopDir (in Unix format '/' separated)
377

378
findTopDir mbMinusB
rrt's avatar
rrt committed
379 380
  = do { top_dir <- get_proto
        -- Discover whether we're running in a build tree or in an installation,
381
	-- by looking for the package configuration file.
Ian Lynagh's avatar
Ian Lynagh committed
382
       ; am_installed <- doesFileExist (top_dir </> "package.conf")
383

rrt's avatar
rrt committed
384
       ; return (am_installed, top_dir)
385 386
       }
  where
387
    -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
388
    get_proto = case mbMinusB of
Ian Lynagh's avatar
Ian Lynagh committed
389
                  Just minusb -> return (normalise minusb)
390 391 392 393 394 395
                  Nothing
                      -> do maybe_exec_dir <- getBaseDir -- Get directory of executable
		            case maybe_exec_dir of       -- (only works on Windows; 
                                                         --  returns Nothing on Unix)
                              Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
                              Just dir -> return dir
396 397 398
\end{code}


399 400 401
%************************************************************************
%*									*
\subsection{Running an external program}
sof's avatar
sof committed
402
%*									*
403 404 405 406
%************************************************************************


\begin{code}
407 408
runUnlit :: DynFlags -> [Option] -> IO ()
runUnlit dflags args = do 
409
  let p = pgm_L dflags
410 411 412 413
  runSomething dflags "Literate pre-processor" p args

runCpp :: DynFlags -> [Option] -> IO ()
runCpp dflags args =   do 
414
  let (p,args0) = pgm_P dflags
415 416 417
      args1 = args0 ++ args
  mb_env <- getGccEnv args1
  runSomethingFiltered dflags id  "C pre-processor" p args1 mb_env
418 419 420

runPp :: DynFlags -> [Option] -> IO ()
runPp dflags args =   do 
421
  let p = pgm_F dflags
422 423 424 425
  runSomething dflags "Haskell pre-processor" p args

runCc :: DynFlags -> [Option] -> IO ()
runCc dflags args =   do 
426
  let (p,args0) = pgm_c dflags
427 428
      args1 = args0 ++ args
  mb_env <- getGccEnv args1
429
  runSomethingFiltered dflags cc_filter "C Compiler" p args1 mb_env
430 431
 where
  -- discard some harmless warnings from gcc that we can't turn off
432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482
  cc_filter = unlines . doFilter . lines

  {-
  gcc gives warnings in chunks like so:
      In file included from /foo/bar/baz.h:11,
                       from /foo/bar/baz2.h:22,
                       from wibble.c:33:
      /foo/flibble:14: global register variable ...
      /foo/flibble:15: warning: call-clobbered r...
  We break it up into its chunks, remove any call-clobbered register
  warnings from each chunk, and then delete any chunks that we have
  emptied of warnings.
  -}
  doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
  -- We can't assume that the output will start with an "In file inc..."
  -- line, so we start off expecting a list of warnings rather than a
  -- location stack.
  chunkWarnings :: [String] -- The location stack to use for the next
                            -- list of warnings
                -> [String] -- The remaining lines to look at
                -> [([String], [String])]
  chunkWarnings loc_stack [] = [(loc_stack, [])]
  chunkWarnings loc_stack xs
      = case break loc_stack_start xs of
        (warnings, lss:xs') ->
            case span loc_start_continuation xs' of
            (lsc, xs'') ->
                (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
        _ -> [(loc_stack, xs)]

  filterWarnings :: [([String], [String])] -> [([String], [String])]
  filterWarnings [] = []
  -- If the warnings are already empty then we are probably doing
  -- something wrong, so don't delete anything
  filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
  filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
                                       [] -> filterWarnings zs
                                       ys' -> (xs, ys') : filterWarnings zs

  unChunkWarnings :: [([String], [String])] -> [String]
  unChunkWarnings [] = []
  unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs

  loc_stack_start        s = "In file included from " `isPrefixOf` s
  loc_start_continuation s = "                 from " `isPrefixOf` s
  wantedWarning w
   | "warning: call-clobbered register used" `isContainedIn` w = False
   | otherwise = True

isContainedIn :: String -> String -> Bool
xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
483

484 485 486 487
-- If the -B<dir> option is set, add <dir> to PATH.  This works around
-- a bug in gcc on Windows Vista where it can't find its auxiliary
-- binaries (see bug #1110).
getGccEnv :: [Option] -> IO (Maybe [(String,String)])
488
getGccEnv opts = 
489
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
Simon Marlow's avatar
Simon Marlow committed
490
  return Nothing
491 492
#else
  if null b_dirs
493
     then return Nothing
494
     else do env <- getEnvironment
495
             return (Just (map mangle_path env))
496
 where
497
  (b_dirs, _) = partitionWith get_b_opt opts
498 499 500

  get_b_opt (Option ('-':'B':dir)) = Left dir
  get_b_opt other = Right other  
501

502 503
  mangle_path (path,paths) | map toUpper path == "PATH" 
        = (path, '\"' : head b_dirs ++ "\";" ++ paths)
504
  mangle_path other = other
505 506
#endif

507 508
runMangle :: DynFlags -> [Option] -> IO ()
runMangle dflags args = do 
509
  let (p,args0) = pgm_m dflags
510 511 512 513
  runSomething dflags "Mangler" p (args0++args)

runSplit :: DynFlags -> [Option] -> IO ()
runSplit dflags args = do 
514
  let (p,args0) = pgm_s dflags
515 516 517 518
  runSomething dflags "Splitter" p (args0++args)

runAs :: DynFlags -> [Option] -> IO ()
runAs dflags args = do 
519
  let (p,args0) = pgm_a dflags
520 521 522
      args1 = args0 ++ args
  mb_env <- getGccEnv args1
  runSomethingFiltered dflags id "Assembler" p args1 mb_env
523 524 525

runLink :: DynFlags -> [Option] -> IO ()
runLink dflags args = do 
526
  let (p,args0) = pgm_l dflags
527 528 529
      args1 = args0 ++ args
  mb_env <- getGccEnv args1
  runSomethingFiltered dflags id "Linker" p args1 mb_env
530

531 532
runMkDLL :: DynFlags -> [Option] -> IO ()
runMkDLL dflags args = do
533
  let (p,args0) = pgm_dll dflags
534 535
      args1 = args0 ++ args
  mb_env <- getGccEnv (args0++args)
536
  runSomethingFiltered dflags id "Make DLL" p args1 mb_env
537

538 539 540 541
runWindres :: DynFlags -> [Option] -> IO ()
runWindres dflags args = do
  let (gcc,gcc_args) = pgm_c dflags
      windres        = pgm_windres dflags
542 543 544
  mb_env <- getGccEnv gcc_args
  runSomethingFiltered dflags id "Windres" windres 
        -- we must tell windres where to find gcc: it might not be on PATH
545 546 547 548 549 550 551 552 553 554
        (Option ("--preprocessor=" ++ 
                 unwords (map quote (gcc : map showOpt gcc_args ++
                                     ["-E", "-xc", "-DRC_INVOKED"])))
        -- -- use-temp-file is required for windres to interpret the
        -- quoting in the preprocessor arg above correctly.  Without
        -- this, windres calls the preprocessor with popen, which gets
        -- the quoting wrong (discovered by experimentation and
        -- reading the windres sources).  See #1828.
        : Option "--use-temp-file"
        : args)
555 556
        -- we must use the PATH workaround here too, since windres invokes gcc
        mb_env
557 558
  where
        quote x = '\"' : x ++ "\""
559

560
touch :: DynFlags -> String -> String -> IO ()
561 562
touch dflags purpose arg =
  runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
563

564 565 566 567 568 569
copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to

copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
               -> IO ()
copyWithHeader dflags purpose maybe_header from to = do
570
  showPass dflags purpose
571 572 573 574

  h <- openFile to WriteMode
  ls <- readFile from -- inefficient, but it'll do for now.
	    	      -- ToDo: speed up via slurping.
575
  maybe (return ()) (hPutStr h) maybe_header
576 577
  hPutStr h ls
  hClose h
578

579 580
getExtraViaCOpts :: DynFlags -> IO [String]
getExtraViaCOpts dflags = do
Ian Lynagh's avatar
Ian Lynagh committed
581
  f <- readFile (topDir dflags </> "extra-gcc-opts")
582
  return (words f)
583 584 585 586 587 588 589 590 591 592
\end{code}

%************************************************************************
%*									*
\subsection{Managing temporary files
%*									*
%************************************************************************

\begin{code}
GLOBAL_VAR(v_FilesToClean, [],               [String] )
593
GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
594 595 596
\end{code}

\begin{code}
597 598
cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags
599 600
   = unless (dopt Opt_KeepTmpFiles dflags)
   $ do ds <- readIORef v_DirsToClean
601 602 603
        removeTmpDirs dflags (eltsFM ds)
        writeIORef v_DirsToClean emptyFM

604 605
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
606 607 608 609
   = unless (dopt Opt_KeepTmpFiles dflags)
   $ do fs <- readIORef v_FilesToClean
        removeTmpFiles dflags fs
        writeIORef v_FilesToClean []
610

611 612
cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
cleanTempFilesExcept dflags dont_delete
613 614 615 616 617
   = unless (dopt Opt_KeepTmpFiles dflags)
   $ do files <- readIORef v_FilesToClean
        let (to_keep, to_delete) = partition (`elem` dont_delete) files
        removeTmpFiles dflags to_delete
        writeIORef v_FilesToClean to_keep
618 619 620


-- find a temporary name that doesn't already exist.
621
newTempName :: DynFlags -> Suffix -> IO FilePath
622 623 624 625
newTempName dflags extn
  = do d <- getTempDir dflags
       x <- getProcessID
       findTempName (d ++ "/ghc" ++ show x ++ "_") 0
626 627
  where
    findTempName :: FilePath -> Integer -> IO FilePath
628
    findTempName prefix x
Ian Lynagh's avatar
Ian Lynagh committed
629 630 631 632 633
      = do let filename = (prefix ++ show x) <.> extn
           b  <- doesFileExist filename
           if b then findTempName prefix (x+1)
                else do consIORef v_FilesToClean filename -- clean it up later
                        return filename
634

635 636 637 638 639 640 641 642 643
-- return our temporary directory within tmp_dir, creating one if we
-- don't have one yet
getTempDir :: DynFlags -> IO FilePath
getTempDir dflags@(DynFlags{tmpDir=tmp_dir})
  = do mapping <- readIORef v_DirsToClean
       case lookupFM mapping tmp_dir of
           Nothing ->
               do x <- getProcessID
                  let prefix = tmp_dir ++ "/ghc" ++ show x ++ "_"
644 645
                  let
                      mkTempDir :: Integer -> IO FilePath
646 647 648 649 650 651 652 653 654 655 656 657 658 659
                      mkTempDir x
                       = let dirname = prefix ++ show x
                         in do createDirectory dirname
                               let mapping' = addToFM mapping tmp_dir dirname
                               writeIORef v_DirsToClean mapping'
                               debugTraceMsg dflags 2 (ptext SLIT("Created temporary directory:") <+> text dirname)
                               return dirname
                            `IO.catch` \e ->
                                    if isAlreadyExistsError e
                                    then mkTempDir (x+1)
                                    else ioError e
                  mkTempDir 0
           Just d -> return d

660 661
addFilesToClean :: [FilePath] -> IO ()
-- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
662
addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
663

664 665 666 667
removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
removeTmpDirs dflags ds
  = traceCmd dflags "Deleting temp dirs"
	     ("Deleting: " ++ unwords ds)
668
	     (mapM_ (removeWith dflags removeDirectory) ds)
669

670 671
removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
removeTmpFiles dflags fs
672
  = warnNon $
673
    traceCmd dflags "Deleting temp files" 
674
	     ("Deleting: " ++ unwords deletees)
675
	     (mapM_ (removeWith dflags removeFile) deletees)
676
  where
677 678 679 680 681 682 683 684 685
     -- Flat out refuse to delete files that are likely to be source input
     -- files (is there a worse bug than having a compiler delete your source
     -- files?)
     -- 
     -- Deleting source files is a sign of a bug elsewhere, so prominently flag
     -- the condition.
    warnNon act
     | null non_deletees = act
     | otherwise         = do
686
        putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
687 688
	act

689
    (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
690

691 692 693 694 695 696 697 698 699 700
removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()
removeWith dflags remover f = remover f `IO.catch`
  (\e ->
   let msg = if isDoesNotExistError e
             then ptext SLIT("Warning: deleting non-existent") <+> text f
             else ptext SLIT("Warning: exception raised when deleting")
                                            <+> text f <> colon
               $$ text (show e)
   in debugTraceMsg dflags 2 msg
  )
701 702 703 704

-----------------------------------------------------------------------------
-- Running an external program

705 706
runSomething :: DynFlags
	     -> String		-- For -v message
707 708
	     -> String		-- Command name (possibly a full path)
				-- 	assumed already dos-ified
sof's avatar
sof committed
709
	     -> [Option]	-- Arguments
710
				--	runSomething will dos-ify them
711 712
	     -> IO ()

713
runSomething dflags phase_name pgm args = 
714
  runSomethingFiltered dflags id phase_name pgm args Nothing
715 716

runSomethingFiltered
717 718
  :: DynFlags -> (String->String) -> String -> String -> [Option]
  -> Maybe [(String,String)] -> IO ()
719

720
runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do
721
  let real_args = filter notNull (map showOpt args)
722
  traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
sof's avatar
sof committed
723 724
  (exit_code, doesn'tExist) <- 
     IO.catch (do
725
         rc <- builderMainLoop dflags filter_fn pgm real_args mb_env
sof's avatar
sof committed
726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752
	 case rc of
	   ExitSuccess{} -> return (rc, False)
	   ExitFailure n 
             -- rawSystem returns (ExitFailure 127) if the exec failed for any
             -- reason (eg. the program doesn't exist).  This is the only clue
             -- we have, but we need to report something to the user because in
             -- the case of a missing program there will otherwise be no output
             -- at all.
	    | n == 127  -> return (rc, True)
	    | otherwise -> return (rc, False))
		-- Should 'rawSystem' generate an IO exception indicating that
		-- 'pgm' couldn't be run rather than a funky return code, catch
		-- this here (the win32 version does this, but it doesn't hurt
		-- to test for this in general.)
              (\ err -> 
	        if IO.isDoesNotExistError err 
#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
		-- the 'compat' version of rawSystem under mingw32 always
		-- maps 'errno' to EINVAL to failure.
		   || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
#endif
	         then return (ExitFailure 1, True)
	         else IO.ioError err)
  case (doesn'tExist, exit_code) of
     (True, _)        -> throwDyn (InstallationError ("could not execute: " ++ pgm))
     (_, ExitSuccess) -> return ()
     _                -> throwDyn (PhaseFailed phase_name exit_code)
753

754 755


756
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
757
builderMainLoop dflags filter_fn pgm real_args mb_env = do
758 759
  rawSystem pgm real_args
#else
760
builderMainLoop dflags filter_fn pgm real_args mb_env = do
761
  chan <- newChan
762
  (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing mb_env
763 764 765 766

  -- and run a loop piping the output from the compiler to the log_action in DynFlags
  hSetBuffering hStdOut LineBuffering
  hSetBuffering hStdErr LineBuffering
767 768
  forkIO (readerProc chan hStdOut filter_fn)
  forkIO (readerProc chan hStdErr filter_fn)
769 770 771 772 773
  -- we don't want to finish until 2 streams have been completed
  -- (stdout and stderr)
  -- nor until 1 exit code has been retrieved.
  rc <- loop chan hProcess (2::Integer) (1::Integer) ExitSuccess
  -- after that, we're done here.
774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804
  hClose hStdIn
  hClose hStdOut
  hClose hStdErr
  return rc
  where
    -- status starts at zero, and increments each time either
    -- a reader process gets EOF, or the build proc exits.  We wait
    -- for all of these to happen (status==3).
    -- ToDo: we should really have a contingency plan in case any of
    -- the threads dies, such as a timeout.
    loop chan hProcess 0 0 exitcode = return exitcode
    loop chan hProcess t p exitcode = do
      mb_code <- if p > 0
                   then getProcessExitCode hProcess
                   else return Nothing
      case mb_code of
        Just code -> loop chan hProcess t (p-1) code
	Nothing 
	  | t > 0 -> do 
	      msg <- readChan chan
              case msg of
                BuildMsg msg -> do
                  log_action dflags SevInfo noSrcSpan defaultUserStyle msg
                  loop chan hProcess t p exitcode
                BuildError loc msg -> do
                  log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
                  loop chan hProcess t p exitcode
                EOF ->
                  loop chan hProcess (t-1) p exitcode
          | otherwise -> loop chan hProcess t p exitcode

805 806
readerProc chan hdl filter_fn =
    (do str <- hGetContents hdl
807
        loop (linesPlatform (filter_fn str)) Nothing) 
808 809
    `finally`
       writeChan chan EOF
810
	-- ToDo: check errors more carefully
811 812
	-- ToDo: in the future, the filter should be implemented as
	-- a stream transformer.
813
    where
814 815 816
	loop []     Nothing    = return ()	
	loop []     (Just err) = writeChan chan err
	loop (l:ls) in_err     =
817 818 819
		case in_err of
		  Just err@(BuildError srcLoc msg)
		    | leading_whitespace l -> do
820
			loop ls (Just (BuildError srcLoc (msg $$ text l)))
821 822
		    | otherwise -> do
			writeChan chan err
823
			checkError l ls
824
		  Nothing -> do
825
			checkError l ls
826

827
	checkError l ls
828
	   = case parseError l of
829 830
		Nothing -> do
		    writeChan chan (BuildMsg (text l))
831
		    loop ls Nothing
832 833
		Just (file, lineNum, colNum, msg) -> do
		    let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
834
		    loop ls (Just (BuildError srcLoc (text msg)))
835

836 837
	leading_whitespace []    = False
	leading_whitespace (x:_) = isSpace x
838

839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862
parseError :: String -> Maybe (String, Int, Int, String)
parseError s0 = case breakColon s0 of
                Just (filename, s1) ->
                    case breakIntColon s1 of
                    Just (lineNum, s2) ->
                        case breakIntColon s2 of
                        Just (columnNum, s3) ->
                            Just (filename, lineNum, columnNum, s3)
                        Nothing ->
                            Just (filename, lineNum, 0, s2)
                    Nothing -> Nothing
                Nothing -> Nothing

breakColon :: String -> Maybe (String, String)
breakColon xs = case break (':' ==) xs of
                    (ys, _:zs) -> Just (ys, zs)
                    _ -> Nothing

breakIntColon :: String -> Maybe (Int, String)
breakIntColon xs = case break (':' ==) xs of
                       (ys, _:zs)
                        | not (null ys) && all isAscii ys && all isDigit ys ->
                           Just (read ys, zs)
                       _ -> Nothing
863 864 865 866 867 868 869

data BuildMessage
  = BuildMsg   !SDoc
  | BuildError !SrcLoc !SDoc
  | EOF
#endif

Ian Lynagh's avatar
Ian Lynagh committed
870
showOpt (FileOption pre f) = pre ++ f
871 872
showOpt (Option s)  = s

873
traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
874 875
-- a) trace the command (at two levels of verbosity)
-- b) don't do it at all if dry-run is set
876 877
traceCmd dflags phase_name cmd_line action
 = do	{ let verb = verbosity dflags
878 879
	; showPass dflags phase_name
	; debugTraceMsg dflags 3 (text cmd_line)
880 881 882
	; hFlush stderr
	
	   -- Test for -n flag
883
	; unless (dopt Opt_DryRun dflags) $ do {
884 885

	   -- And run it!
886
	; action `IO.catch` handle_exn verb
887 888
	}}
  where
889 890
    handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
			     ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
891 892 893
	          	     ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}

894 895 896 897 898 899 900
%************************************************************************
%*									*
\subsection{Support code}
%*									*
%************************************************************************

\begin{code}
901
-----------------------------------------------------------------------------
902
-- Define	getBaseDir     :: IO (Maybe String)
903

904
getBaseDir :: IO (Maybe String)
905
#if defined(mingw32_HOST_OS)
906 907 908
-- Assuming we are running ghc, accessed by path  $()/bin/ghc.exe,
-- return the path $(stuff).  Note that we drop the "bin/" directory too.
getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
sof's avatar
sof committed
909
		buf <- mallocArray len
910
		ret <- getModuleFileName nullPtr buf len
sof's avatar
sof committed
911
		if ret == 0 then free buf >> return Nothing
sof's avatar
sof committed
912
		            else do s <- peekCString buf
sof's avatar
sof committed
913
				    free buf
sof's avatar
sof committed
914 915
				    return (Just (rootDir s))
  where
Ian Lynagh's avatar
Ian Lynagh committed
916 917 918 919 920 921
    rootDir s = case splitFileName $ normalise s of
                (d, "ghc.exe") ->
                    case splitFileName $ takeDirectory d of
                    (d', "bin") -> takeDirectory d'
                    _ -> panic ("Expected \"bin\" in " ++ show s)
                _ -> panic ("Expected \"ghc.exe\" in " ++ show s)
sof's avatar
sof committed
922

sof's avatar
sof committed
923
foreign import stdcall unsafe "GetModuleFileNameA"
924
  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
rrt's avatar
rrt committed
925
#else
926
getBaseDir = return Nothing
rrt's avatar
rrt committed
927
#endif
rrt's avatar
rrt committed
928

929
#ifdef mingw32_HOST_OS
sof's avatar
sof committed
930
foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
931 932
#else
getProcessID :: IO Int
933
getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
934
#endif
rrt's avatar
rrt committed
935

936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953
-- Divvy up text stream into lines, taking platform dependent
-- line termination into account.
linesPlatform :: String -> [String]
#if !defined(mingw32_HOST_OS)
linesPlatform ls = lines ls
#else
linesPlatform "" = []
linesPlatform xs = 
  case lineBreak xs of
    (as,xs1) -> as : linesPlatform xs1
  where
   lineBreak "" = ("","")
   lineBreak ('\r':'\n':xs) = ([],xs)
   lineBreak ('\n':xs) = ([],xs)
   lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)

#endif

954
\end{code}