SysTools.lhs 28.2 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 10 11 12
--
-----------------------------------------------------------------------------

\begin{code}
module SysTools (
	-- Initialisation
	initSysTools,
13

14
	-- Interface to system tools
sof's avatar
sof committed
15
	runUnlit, runCpp, runCc, -- [Option] -> IO ()
sof's avatar
sof committed
16
	runPp,                   -- [Option] -> IO ()
sof's avatar
sof committed
17 18
	runMangle, runSplit,	 -- [Option] -> IO ()
	runAs, runLink,		 -- [Option] -> IO ()
19 20 21
	runMkDLL,

	touch,			-- String -> String -> IO ()
22 23
	copy,
        copyWithHeader,
sof's avatar
sof committed
24
	normalisePath,          -- FilePath -> FilePath
25 26 27 28
	
	-- Temporary-file management
	setTmpDir,
	newTempName,
29
	cleanTempDirs, cleanTempFiles, cleanTempFilesExcept,
30 31 32
	addFilesToClean,

	-- System interface
rrt's avatar
rrt committed
33
	system, 		-- String -> IO ExitCode
34

sof's avatar
sof committed
35
	Option(..)
36 37 38

 ) where

39 40
#include "HsVersions.h"

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

import Control.Exception
import Data.IORef
import Data.Int
import Control.Monad
import System.Exit
import System.Environment
import System.IO
import SYSTEM_IO_ERROR as IO
import System.Directory
import Data.Maybe
import Data.List
61 62 63

-- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
-- lines on mingw32, so we disallow it now.
64 65
#if __GLASGOW_HASKELL__ < 500
#error GHC >= 5.00 is required for bootstrapping GHC
66 67
#endif

68
#ifndef mingw32_HOST_OS
69
#if __GLASGOW_HASKELL__ > 504
70
import qualified System.Posix.Internals
71
#else
72
import qualified Posix
73
#endif
74
#else /* Must be Win32 */
sof's avatar
sof committed
75
import List		( isPrefixOf )
76
import Util		( dropList )
sof's avatar
sof committed
77
import Foreign
78
import CString		( CString, peekCString )
rrt's avatar
rrt committed
79 80
#endif

Simon Marlow's avatar
Simon Marlow committed
81 82
import Text.Regex

83
#if __GLASGOW_HASKELL__ < 603
84
-- rawSystem comes from libghccompat.a in stage1
Ian Lynagh's avatar
Ian Lynagh committed
85 86
import Compat.RawSystem ( rawSystem )
import System.Cmd       ( system )
sof's avatar
sof committed
87
import GHC.IOBase       ( IOErrorType(..) ) 
88
#else
Ian Lynagh's avatar
Ian Lynagh committed
89
import System.Cmd       ( rawSystem, system )
90 91 92 93 94
import System.Process	( runInteractiveProcess, getProcessExitCode )
import Control.Concurrent( forkIO, newChan, readChan, writeChan )
import Data.Char        ( isSpace )
import FastString       ( mkFastString )
import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
95
#endif
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 121 122 123 124 125 126 127 128 129 130
\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
				

131 132 133
  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)
134 135 136
		


137 138 139 140 141 142 143 144 145 146 147 148 149 150
---------------------------------------------
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 = [],
151
     extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
152 153 154 155 156 157 158 159
     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
---------------------------------------------

160 161 162 163 164 165 166
%************************************************************************
%*									*
\subsection{Initialisation}
%*									*
%************************************************************************

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

169 170
	     -> DynFlags
	     -> IO DynFlags	-- Set all the mutable variables above, holding 
171 172 173
				--	(a) the system programs
				--	(b) the package-config file
				--	(c) the GHC usage message
174 175


176 177
initSysTools mbMinusB dflags
  = do  { (am_installed, top_dir) <- findTopDir mbMinusB
178 179 180
		-- top_dir
		-- 	for "installed" this is the root of GHC's support files
		--	for "in-place" it is the root of the build tree
181 182
		-- NB: top_dir is assumed to be in standard Unix
		-- format, '/' separated
183

184
	; let installed, installed_bin :: FilePath -> FilePath
185
              installed_bin pgm   =  pgmPath top_dir pgm
186
	      installed     file  =  pgmPath top_dir file
187 188
	      inplace dir   pgm   =  pgmPath (top_dir `joinFileName` 
						cPROJECT_DIR `joinFileName` dir) pgm
189

190 191
	; let pkgconfig_path
		| am_installed = installed "package.conf"
192
		| otherwise    = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
193

194 195
	      ghc_usage_msg_path
		| am_installed = installed "ghc-usage.txt"
196
		| otherwise    = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
197

198 199 200 201
	      ghci_usage_msg_path
		| am_installed = installed "ghci-usage.txt"
		| otherwise    = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"

202 203 204
		-- For all systems, unlit, split, mangle are GHC utilities
		-- architecture-specific stuff is done when building Config.hs
	      unlit_path
205 206
		| am_installed = installed_bin cGHC_UNLIT_PGM
		| otherwise    = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
207 208

		-- split and mangle are Perl scripts
209
	      split_script
210 211
		| am_installed = installed_bin cGHC_SPLIT_PGM
		| otherwise    = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
212

213
	      mangle_script
214 215
		| am_installed = installed_bin cGHC_MANGLER_PGM
		| otherwise    = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
216

217
	; let dflags0 = defaultDynFlags
218
#ifndef mingw32_HOST_OS
219
	-- check whether TMPDIR is set in the environment
220
	; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
sof's avatar
sof committed
221 222 223 224
#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
225
	  --   form.
226 227
	; e_tmpdir <- 
            IO.try (do
sof's avatar
sof committed
228 229 230
	        let len = (2048::Int)
		buf  <- mallocArray len
		ret  <- getTempPath len buf
231
		if ret == 0 then do
sof's avatar
sof committed
232
		      -- failed, consult TMPDIR.
sof's avatar
sof committed
233
 	             free buf
sof's avatar
sof committed
234
		     getEnv "TMPDIR"
235
		  else do
sof's avatar
sof committed
236
		     s <- peekCString buf
sof's avatar
sof committed
237
		     free buf
238
		     return s)
239
#endif
240 241 242
        ; let dflags1 = case e_tmpdir of
			  Left _  -> dflags0
			  Right d -> setTmpDir d dflags0
243

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

250
#if defined(mingw32_HOST_OS)
251 252 253 254 255
	--		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
256 257 258 259 260 261 262 263
	-- 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.
264 265 266 267
	; 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
268
		-- The trailing "/" is absolutely essential; gcc seems
269 270 271 272 273
		-- 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
274 275
		--	(see comments with declarations of global variables)
		--
276 277
		-- The quotes round the -B argument are in case TopDir
		-- has spaces in it
278

279
	      perl_path | am_installed = installed_bin cGHC_PERL
280 281 282
		        | otherwise    = cGHC_PERL

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

286 287
	-- 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
288 289 290 291 292 293 294 295 296 297 298
	; 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 = 
		    (pgmPath (installed "gcc-lib/") cMKDLL,
		     [ Option "--dlltool-name",
		       Option (pgmPath (installed "gcc-lib/") "dlltool"),
		       Option "--driver-name",
		       Option gcc_prog, gcc_b_arg ])
		| otherwise    = (cMKDLL, [])
299 300 301 302 303
#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.
304 305
	; let   gcc_prog   = cGCC
		gcc_args   = []
306
		touch_path = "touch"
307 308
		mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
		mkdll_args = []
309

310 311 312 313
	-- 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.
314 315
	; let (split_prog,  split_args)  = (split_script,  [])
	      (mangle_prog, mangle_args) = (mangle_script, [])
316
#endif
317

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

rrt's avatar
rrt committed
324
	-- For all systems, copy and remove are provided by the host
325 326 327 328
	-- 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
329 330
	; let	(as_prog,as_args)  = (gcc_prog,gcc_args)
		(ld_prog,ld_args)  = (gcc_prog,gcc_args)
331

332
	; return dflags1{
333 334 335 336
                        ghcUsagePath = ghc_usage_msg_path,
                        ghciUsagePath = ghci_usage_msg_path,
                        topDir  = top_dir,
                        systemPackageConfig = pkgconfig_path,
337 338 339 340 341 342 343 344
			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),
345 346 347 348 349 350
			pgm_dll = (mkdll_prog,mkdll_args),
                        pgm_T   = touch_path,
                        pgm_sysman = top_dir ++ "/ghc/rts/parallel/SysMan"
        		-- Hans: this isn't right in general, but you can 
        		-- elaborate it in the same way as the others
                }
351
	}
sof's avatar
sof committed
352

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

358 359 360 361 362 363 364
\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
365 366
--	if there is no given TopDir path, get the directory 
--	where GHC is running (only on Windows)
367 368 369 370 371 372 373 374 375 376
--
-- 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

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

381
findTopDir mbMinusB
rrt's avatar
rrt committed
382 383
  = do { top_dir <- get_proto
        -- Discover whether we're running in a build tree or in an installation,
384
	-- by looking for the package configuration file.
385
       ; am_installed <- doesFileExist (top_dir `joinFileName` "package.conf")
386

rrt's avatar
rrt committed
387
       ; return (am_installed, top_dir)
388 389
       }
  where
390
    -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
391 392 393 394 395 396 397 398
    get_proto = case mbMinusB of
                  Just minusb -> return (normalisePath minusb)
                  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
399 400 401
\end{code}


402 403 404
%************************************************************************
%*									*
\subsection{Running an external program}
sof's avatar
sof committed
405
%*									*
406 407 408 409
%************************************************************************


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

runCpp :: DynFlags -> [Option] -> IO ()
runCpp dflags args =   do 
417 418
  let (p,args0) = pgm_P dflags
  runSomething dflags "C pre-processor" p (args0 ++ args)
419 420 421

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

runCc :: DynFlags -> [Option] -> IO ()
runCc dflags args =   do 
427
  let (p,args0) = pgm_c dflags
428 429 430 431 432 433 434 435 436 437 438 439 440 441 442
  runSomethingFiltered dflags cc_filter "C Compiler" p (args0++args)
 where
  -- discard some harmless warnings from gcc that we can't turn off
  cc_filter str = unlines (do_filter (lines str))

  do_filter [] = []
  do_filter ls@(l:ls')
      | (w:rest) <- dropWhile (isJust .matchRegex r_from) ls, 
        isJust (matchRegex r_warn w)
      = do_filter rest
      | otherwise
      = l : do_filter ls'

  r_from = mkRegex "from.*:[0-9]+"
  r_warn = mkRegex "warning: call-clobbered register used"
443 444 445

runMangle :: DynFlags -> [Option] -> IO ()
runMangle dflags args = do 
446
  let (p,args0) = pgm_m dflags
447 448 449 450
  runSomething dflags "Mangler" p (args0++args)

runSplit :: DynFlags -> [Option] -> IO ()
runSplit dflags args = do 
451
  let (p,args0) = pgm_s dflags
452 453 454 455
  runSomething dflags "Splitter" p (args0++args)

runAs :: DynFlags -> [Option] -> IO ()
runAs dflags args = do 
456
  let (p,args0) = pgm_a dflags
457 458 459 460
  runSomething dflags "Assembler" p (args0++args)

runLink :: DynFlags -> [Option] -> IO ()
runLink dflags args = do 
461
  let (p,args0) = pgm_l dflags
462
  runSomething dflags "Linker" p (args0++args)
463

464 465
runMkDLL :: DynFlags -> [Option] -> IO ()
runMkDLL dflags args = do
466
  let (p,args0) = pgm_dll dflags
467
  runSomething dflags "Make DLL" p (args0++args)
468

469
touch :: DynFlags -> String -> String -> IO ()
470 471
touch dflags purpose arg =
  runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
472

473 474 475 476 477 478
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
479
  showPass dflags purpose
480 481 482 483

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

488 489 490 491 492 493 494 495 496 497
\end{code}

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

\begin{code}
GLOBAL_VAR(v_FilesToClean, [],               [String] )
498
GLOBAL_VAR(v_DirsToClean, emptyFM, FiniteMap FilePath FilePath )
499 500 501
\end{code}

\begin{code}
502 503
cleanTempDirs :: DynFlags -> IO ()
cleanTempDirs dflags
504 505
   = unless (dopt Opt_KeepTmpFiles dflags)
   $ do ds <- readIORef v_DirsToClean
506 507 508
        removeTmpDirs dflags (eltsFM ds)
        writeIORef v_DirsToClean emptyFM

509 510
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
511 512 513 514
   = unless (dopt Opt_KeepTmpFiles dflags)
   $ do fs <- readIORef v_FilesToClean
        removeTmpFiles dflags fs
        writeIORef v_FilesToClean []
515

516 517
cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
cleanTempFilesExcept dflags dont_delete
518 519 520 521 522
   = 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
523 524 525


-- find a temporary name that doesn't already exist.
526
newTempName :: DynFlags -> Suffix -> IO FilePath
527 528 529 530
newTempName dflags extn
  = do d <- getTempDir dflags
       x <- getProcessID
       findTempName (d ++ "/ghc" ++ show x ++ "_") 0
531
  where 
532
    findTempName prefix x
533
      = do let filename = (prefix ++ show x) `joinFileExt` extn
534
  	   b  <- doesFileExist filename
535
	   if b then findTempName prefix (x+1)
536
		else do consIORef v_FilesToClean filename -- clean it up later
537 538
		        return filename

539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561
-- 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 ++ "_"
                      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

562 563
addFilesToClean :: [FilePath] -> IO ()
-- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
564
addFilesToClean files = mapM_ (consIORef v_FilesToClean) files
565

566 567 568 569
removeTmpDirs :: DynFlags -> [FilePath] -> IO ()
removeTmpDirs dflags ds
  = traceCmd dflags "Deleting temp dirs"
	     ("Deleting: " ++ unwords ds)
570
	     (mapM_ (removeWith dflags removeDirectory) ds)
571

572 573
removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
removeTmpFiles dflags fs
574
  = warnNon $
575
    traceCmd dflags "Deleting temp files" 
576
	     ("Deleting: " ++ unwords deletees)
577
	     (mapM_ (removeWith dflags removeFile) deletees)
578
  where
579 580 581 582 583 584 585 586 587
     -- 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
588
        putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
589 590
	act

591
    (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
592

593 594 595 596 597 598 599 600 601 602
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
  )
603 604 605 606

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

607 608
runSomething :: DynFlags
	     -> String		-- For -v message
609 610
	     -> String		-- Command name (possibly a full path)
				-- 	assumed already dos-ified
sof's avatar
sof committed
611
	     -> [Option]	-- Arguments
612
				--	runSomething will dos-ify them
613 614
	     -> IO ()

615 616 617 618 619 620 621
runSomething dflags phase_name pgm args = 
  runSomethingFiltered dflags id phase_name pgm args

runSomethingFiltered
  :: DynFlags -> (String->String) -> String -> String -> [Option] -> IO ()

runSomethingFiltered dflags filter_fn phase_name pgm args = do
622
  let real_args = filter notNull (map showOpt args)
623
  traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
sof's avatar
sof committed
624 625
  (exit_code, doesn'tExist) <- 
     IO.catch (do
626
         rc <- builderMainLoop dflags filter_fn pgm real_args
sof's avatar
sof committed
627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653
	 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)
654

655 656 657


#if __GLASGOW_HASKELL__ < 603
658
builderMainLoop dflags filter_fn pgm real_args = do
659 660
  rawSystem pgm real_args
#else
661
builderMainLoop dflags filter_fn pgm real_args = do
662 663 664 665 666 667
  chan <- newChan
  (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing Nothing

  -- and run a loop piping the output from the compiler to the log_action in DynFlags
  hSetBuffering hStdOut LineBuffering
  hSetBuffering hStdErr LineBuffering
668 669
  forkIO (readerProc chan hStdOut filter_fn)
  forkIO (readerProc chan hStdErr filter_fn)
670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701
  rc <- loop chan hProcess 2 1 ExitSuccess
  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

702 703
readerProc chan hdl filter_fn =
    (do str <- hGetContents hdl
704
        loop (linesPlatform (filter_fn str)) Nothing) 
705 706
    `finally`
       writeChan chan EOF
707
	-- ToDo: check errors more carefully
708 709
	-- ToDo: in the future, the filter should be implemented as
	-- a stream transformer.
710
    where
711 712 713
	loop []     Nothing    = return ()	
	loop []     (Just err) = writeChan chan err
	loop (l:ls) in_err     =
714 715 716
		case in_err of
		  Just err@(BuildError srcLoc msg)
		    | leading_whitespace l -> do
717
			loop ls (Just (BuildError srcLoc (msg $$ text l)))
718 719
		    | otherwise -> do
			writeChan chan err
720
			checkError l ls
721
		  Nothing -> do
722
			checkError l ls
723

724
	checkError l ls
725 726 727
	   = case matchRegex errRegex l of
		Nothing -> do
		    writeChan chan (BuildMsg (text l))
728
		    loop ls Nothing
729 730 731 732 733 734 735
		Just (file':lineno':colno':msg:_) -> do
		    let file   = mkFastString file'
		        lineno = read lineno'::Int
		        colno  = case colno' of
		                   "" -> 0
		                   _  -> read (init colno') :: Int
		        srcLoc = mkSrcLoc file lineno colno
736
		    loop ls (Just (BuildError srcLoc (text msg)))
737

738 739
	leading_whitespace []    = False
	leading_whitespace (x:_) = isSpace x
740 741 742 743 744 745 746 747 748

errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)"

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

749 750 751 752
showOpt (FileOption pre f) = pre ++ platformPath f
showOpt (Option "") = ""
showOpt (Option s)  = s

753
traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
754 755
-- a) trace the command (at two levels of verbosity)
-- b) don't do it at all if dry-run is set
756 757
traceCmd dflags phase_name cmd_line action
 = do	{ let verb = verbosity dflags
758 759
	; showPass dflags phase_name
	; debugTraceMsg dflags 3 (text cmd_line)
760 761 762
	; hFlush stderr
	
	   -- Test for -n flag
763
	; unless (dopt Opt_DryRun dflags) $ do {
764 765

	   -- And run it!
766
	; action `IO.catch` handle_exn verb
767 768
	}}
  where
769 770
    handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
			     ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
771 772 773
	          	     ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}

774 775 776 777 778 779 780
%************************************************************************
%*									*
\subsection{Support code}
%*									*
%************************************************************************

\begin{code}
781
-----------------------------------------------------------------------------
782
-- Define	getBaseDir     :: IO (Maybe String)
783

784
getBaseDir :: IO (Maybe String)
785
#if defined(mingw32_HOST_OS)
786 787 788
-- 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
789
		buf <- mallocArray len
790
		ret <- getModuleFileName nullPtr buf len
sof's avatar
sof committed
791
		if ret == 0 then free buf >> return Nothing
sof's avatar
sof committed
792
		            else do s <- peekCString buf
sof's avatar
sof committed
793
				    free buf
sof's avatar
sof committed
794 795 796
				    return (Just (rootDir s))
  where
    rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
sof's avatar
sof committed
797

sof's avatar
sof committed
798
foreign import stdcall unsafe "GetModuleFileNameA"
799
  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
rrt's avatar
rrt committed
800
#else
801
getBaseDir = return Nothing
rrt's avatar
rrt committed
802
#endif
rrt's avatar
rrt committed
803

804
#ifdef mingw32_HOST_OS
sof's avatar
sof committed
805
foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
806 807
#elif __GLASGOW_HASKELL__ > 504
getProcessID :: IO Int
808
getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
809 810 811 812
#else
getProcessID :: IO Int
getProcessID = Posix.getProcessID
#endif
rrt's avatar
rrt committed
813

814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831
-- 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

832
\end{code}