SysTools.lhs 27.4 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
	getTopDir,		-- IO String	-- The value of $topdir
15
	getPackageConfigPath,	-- IO String	-- Where package.conf is
16
        getUsageMsgPaths,       -- IO (String,String)
17
18

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

	touch,			-- String -> String -> IO ()
	copy,			-- String -> String -> String -> IO ()
sof's avatar
sof committed
27
	normalisePath,          -- FilePath -> FilePath
28
29
30
31
	
	-- Temporary-file management
	setTmpDir,
	newTempName,
32
	cleanTempFiles, cleanTempFilesExcept,
33
34
35
	addFilesToClean,

	-- System interface
rrt's avatar
rrt committed
36
	system, 		-- String -> IO ExitCode
37
38

	-- Misc
sof's avatar
sof committed
39
40
41
	getSysMan,		-- IO String	Parallel system only
	
	Option(..)
42
43
44

 ) where

45
46
#include "HsVersions.h"

47
import DriverPhases     ( isHaskellUserSrcFilename )
48
import Config
49
import Outputable
50
import ErrUtils		( putMsg, debugTraceMsg, showPass, Severity(..), Messages )
51
import Panic		( GhcException(..) )
52
53
import Util		( Suffix, global, notNull, consIORef, joinFileName,
			  normalisePath, pgmPath, platformPath, joinFileExt )
54
55
import DynFlags		( DynFlags(..), DynFlag(..), dopt, Option(..),
			  setTmpDir, defaultDynFlags )
56

57
import EXCEPTION	( throwDyn, finally )
58
59
60
import DATA_IOREF	( IORef, readIORef, writeIORef )
import DATA_INT
    
61
import Monad		( when, unless )
62
import System		( ExitCode(..), getEnv, system )
63
import IO		( try, catch, hGetContents,
sof's avatar
sof committed
64
65
			  openFile, hPutStr, hClose, hFlush, IOMode(..), 
			  stderr, ioError, isDoesNotExistError )
66
import Directory	( doesFileExist, removeFile )
67
import Maybe		( isJust )
sof's avatar
sof committed
68
import List             ( partition )
69
70
71

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

76
#ifndef mingw32_HOST_OS
77
#if __GLASGOW_HASKELL__ > 504
78
import qualified System.Posix.Internals
79
#else
80
import qualified Posix
81
#endif
82
#else /* Must be Win32 */
sof's avatar
sof committed
83
import List		( isPrefixOf )
84
import Util		( dropList )
sof's avatar
sof committed
85
import Foreign
86
import CString		( CString, peekCString )
rrt's avatar
rrt committed
87
88
#endif

Simon Marlow's avatar
Simon Marlow committed
89
90
import Text.Regex

91
#if __GLASGOW_HASKELL__ < 603
92
93
-- rawSystem comes from libghccompat.a in stage1
import Compat.RawSystem	( rawSystem )
sof's avatar
sof committed
94
95
import GHC.IOBase       ( IOErrorType(..) ) 
import System.IO.Error  ( ioeGetErrorType )
96
#else
97
98
99
100
101
102
import System.Process	( runInteractiveProcess, getProcessExitCode )
import System.IO        ( hSetBuffering, hGetLine, BufferMode(..) )
import Control.Concurrent( forkIO, newChan, readChan, writeChan )
import Data.Char        ( isSpace )
import FastString       ( mkFastString )
import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
103
#endif
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
131
132
133
134
135
136
137
138
\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
				

139
140
141
  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)
142
143
144
		


145
146
147
148
149
150
151
152
153
154
155
156
157
158
---------------------------------------------
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 = [],
159
     extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
160
161
162
163
164
165
166
167
168
     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
---------------------------------------------


169
170
171
172
173
174
%************************************************************************
%*									*
\subsection{Global variables to contain system programs}
%*									*
%************************************************************************

175
All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
176
177
(See remarks under pathnames below)

178
179
180
181
182
\begin{code}
GLOBAL_VAR(v_Pgm_T,    error "pgm_T",    String)	-- touch
GLOBAL_VAR(v_Pgm_CP,   error "pgm_CP", 	 String)	-- cp

GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
183
GLOBAL_VAR(v_Path_usages,  	  error "ghc_usage.txt",       (String,String))
184

185
186
GLOBAL_VAR(v_TopDir,	error "TopDir",	String)		-- -B<dir>

187
188
-- Parallel system only
GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String)	-- system manager
189
190
191
192

-- ways to get at some of these variables from outside this module
getPackageConfigPath = readIORef v_Path_package_config
getTopDir	     = readIORef v_TopDir
193
194
195
196
197
198
199
200
201
202
\end{code}


%************************************************************************
%*									*
\subsection{Initialisation}
%*									*
%************************************************************************

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

205
206
	     -> DynFlags
	     -> IO DynFlags	-- Set all the mutable variables above, holding 
207
208
209
				--	(a) the system programs
				--	(b) the package-config file
				--	(c) the GHC usage message
210
211


212
213
initSysTools mbMinusB dflags
  = do  { (am_installed, top_dir) <- findTopDir mbMinusB
214
	; writeIORef v_TopDir top_dir
215
216
217
		-- top_dir
		-- 	for "installed" this is the root of GHC's support files
		--	for "in-place" it is the root of the build tree
218
		-- NB: top_dir is assumed to be in standard Unix format '/' separated
219

220
	; let installed, installed_bin :: FilePath -> FilePath
221
              installed_bin pgm   =  pgmPath top_dir pgm
222
	      installed     file  =  pgmPath top_dir file
223
224
	      inplace dir   pgm   =  pgmPath (top_dir `joinFileName` 
						cPROJECT_DIR `joinFileName` dir) pgm
225

226
227
	; let pkgconfig_path
		| am_installed = installed "package.conf"
228
		| otherwise    = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
229

230
231
	      ghc_usage_msg_path
		| am_installed = installed "ghc-usage.txt"
232
		| otherwise    = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
233

234
235
236
237
	      ghci_usage_msg_path
		| am_installed = installed "ghci-usage.txt"
		| otherwise    = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"

238
239
240
		-- For all systems, unlit, split, mangle are GHC utilities
		-- architecture-specific stuff is done when building Config.hs
	      unlit_path
241
242
		| am_installed = installed_bin cGHC_UNLIT_PGM
		| otherwise    = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
243
244

		-- split and mangle are Perl scripts
245
	      split_script
246
247
		| am_installed = installed_bin cGHC_SPLIT_PGM
		| otherwise    = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
248

249
	      mangle_script
250
251
		| am_installed = installed_bin cGHC_MANGLER_PGM
		| otherwise    = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
252

253
	; let dflags0 = defaultDynFlags
254
#ifndef mingw32_HOST_OS
255
	-- check whether TMPDIR is set in the environment
256
	; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
sof's avatar
sof committed
257
258
259
260
#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
261
	  --   form.
262
263
	; e_tmpdir <- 
            IO.try (do
sof's avatar
sof committed
264
265
266
	        let len = (2048::Int)
		buf  <- mallocArray len
		ret  <- getTempPath len buf
267
		if ret == 0 then do
sof's avatar
sof committed
268
		      -- failed, consult TMPDIR.
sof's avatar
sof committed
269
 	             free buf
sof's avatar
sof committed
270
		     getEnv "TMPDIR"
271
		  else do
sof's avatar
sof committed
272
		     s <- peekCString buf
sof's avatar
sof committed
273
		     free buf
274
		     return s)
275
#endif
276
277
278
        ; let dflags1 = case e_tmpdir of
			  Left _  -> dflags0
			  Right d -> setTmpDir d dflags0
279

280
281
282
283
	-- Check that the package config exists
	; config_exists <- doesFileExist pkgconfig_path
	; when (not config_exists) $
	     throwDyn (InstallationError 
rrt's avatar
rrt committed
284
		         ("Can't find package.conf as " ++ pkgconfig_path))
285

286
#if defined(mingw32_HOST_OS)
287
288
289
290
291
	--		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
292
293
294
295
296
297
298
299
	-- 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.
300
301
302
303
	; 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
304
		-- The trailing "/" is absolutely essential; gcc seems
305
306
307
308
309
		-- 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
310
311
		--	(see comments with declarations of global variables)
		--
312
313
		-- The quotes round the -B argument are in case TopDir
		-- has spaces in it
314

315
	      perl_path | am_installed = installed_bin cGHC_PERL
316
317
318
		        | otherwise    = cGHC_PERL

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

322
323
	-- 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
324
325
326
327
328
329
330
331
332
333
334
	; 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, [])
335
336
337
338
339
#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.
340
341
	; let   gcc_prog   = cGCC
		gcc_args   = []
342
		touch_path = "touch"
343
344
		mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
		mkdll_args = []
345

346
347
348
349
	-- 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.
350
351
	; let (split_prog,  split_args)  = (split_script,  [])
	      (mangle_prog, mangle_args) = (mangle_script, [])
352
#endif
353

354
	-- cpp is derived from gcc on all platforms
355
356
        -- HACK, see setPgmP below. We keep 'words' here to remember to fix
        -- Config.hs one day.
357
358
        ; let cpp_path  = (gcc_prog, gcc_args ++ 
			   (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
359

rrt's avatar
rrt committed
360
	-- For all systems, copy and remove are provided by the host
361
362
363
364
	-- 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
365
366
	; let	(as_prog,as_args)  = (gcc_prog,gcc_args)
		(ld_prog,ld_args)  = (gcc_prog,gcc_args)
367
368
369

	-- Initialise the global vars
	; writeIORef v_Path_package_config pkgconfig_path
370
371
	; writeIORef v_Path_usages 	   (ghc_usage_msg_path,
					    ghci_usage_msg_path)
372
373
374
375
376
377
378
379

	; writeIORef v_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

	; writeIORef v_Pgm_T   	 	   touch_path
	; writeIORef v_Pgm_CP  	 	   cp_path

380
	; return dflags1{
381
382
383
384
385
386
387
388
389
			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),
			pgm_dll = (mkdll_prog,mkdll_args) }
390
	}
sof's avatar
sof committed
391

392
#if defined(mingw32_HOST_OS)
sof's avatar
sof committed
393
foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
sof's avatar
sof committed
394
#endif
395
396
\end{code}

397
398
399
400
401
402
403
\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
404
405
--	if there is no given TopDir path, get the directory 
--	where GHC is running (only on Windows)
406
407
408
409
410
411
412
413
414
415
--
-- 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

416
417
418
findTopDir :: Maybe String   -- Maybe TopDir path (without the '-B' prefix).
           -> IO (Bool,      -- True <=> am installed, False <=> in-place
                  String)    -- TopDir (in Unix format '/' separated)
419

420
findTopDir mbMinusB
rrt's avatar
rrt committed
421
422
  = do { top_dir <- get_proto
        -- Discover whether we're running in a build tree or in an installation,
423
	-- by looking for the package configuration file.
424
       ; am_installed <- doesFileExist (top_dir `joinFileName` "package.conf")
425

rrt's avatar
rrt committed
426
       ; return (am_installed, top_dir)
427
428
       }
  where
429
    -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
430
431
432
433
434
435
436
437
    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
438
439
440
\end{code}


441
442
443
%************************************************************************
%*									*
\subsection{Running an external program}
sof's avatar
sof committed
444
%*									*
445
446
447
448
%************************************************************************


\begin{code}
449
450
runUnlit :: DynFlags -> [Option] -> IO ()
runUnlit dflags args = do 
451
  let p = pgm_L dflags
452
453
454
455
  runSomething dflags "Literate pre-processor" p args

runCpp :: DynFlags -> [Option] -> IO ()
runCpp dflags args =   do 
456
457
  let (p,args0) = pgm_P dflags
  runSomething dflags "C pre-processor" p (args0 ++ args)
458
459
460

runPp :: DynFlags -> [Option] -> IO ()
runPp dflags args =   do 
461
  let p = pgm_F dflags
462
463
464
465
  runSomething dflags "Haskell pre-processor" p args

runCc :: DynFlags -> [Option] -> IO ()
runCc dflags args =   do 
466
  let (p,args0) = pgm_c dflags
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
  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"
482
483
484

runMangle :: DynFlags -> [Option] -> IO ()
runMangle dflags args = do 
485
  let (p,args0) = pgm_m dflags
486
487
488
489
  runSomething dflags "Mangler" p (args0++args)

runSplit :: DynFlags -> [Option] -> IO ()
runSplit dflags args = do 
490
  let (p,args0) = pgm_s dflags
491
492
493
494
  runSomething dflags "Splitter" p (args0++args)

runAs :: DynFlags -> [Option] -> IO ()
runAs dflags args = do 
495
  let (p,args0) = pgm_a dflags
496
497
498
499
  runSomething dflags "Assembler" p (args0++args)

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

503
504
runMkDLL :: DynFlags -> [Option] -> IO ()
runMkDLL dflags args = do
505
  let (p,args0) = pgm_dll dflags
506
  runSomething dflags "Make DLL" p (args0++args)
507

508
509
510
511
touch :: DynFlags -> String -> String -> IO ()
touch dflags purpose arg =  do 
  p <- readIORef v_Pgm_T
  runSomething dflags purpose p [FileOption "" arg]
512

513
514
copy :: DynFlags -> String -> String -> String -> IO ()
copy dflags purpose from to = do
515
  showPass dflags purpose
516
517
518
519
520
521

  h <- openFile to WriteMode
  ls <- readFile from -- inefficient, but it'll do for now.
	    	      -- ToDo: speed up via slurping.
  hPutStr h ls
  hClose h
522

523
524
525
526
527
528
529
530
531
\end{code}

\begin{code}
getSysMan :: IO String	-- How to invoke the system manager 
			-- (parallel system only)
getSysMan = readIORef v_Pgm_sysman
\end{code}

\begin{code}
532
533
534
getUsageMsgPaths :: IO (FilePath,FilePath)
	  -- the filenames of the usage messages (ghc, ghci)
getUsageMsgPaths = readIORef v_Path_usages
535
536
537
538
539
540
541
542
543
544
545
546
547
548
\end{code}


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

\begin{code}
GLOBAL_VAR(v_FilesToClean, [],               [String] )
\end{code}

\begin{code}
549
550
cleanTempFiles :: DynFlags -> IO ()
cleanTempFiles dflags
551
   = do fs <- readIORef v_FilesToClean
552
	removeTmpFiles dflags fs
553
	writeIORef v_FilesToClean []
554

555
556
cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
cleanTempFilesExcept dflags dont_delete
557
558
   = do files <- readIORef v_FilesToClean
	let (to_keep, to_delete) = partition (`elem` dont_delete) files
559
	removeTmpFiles dflags to_delete
560
	writeIORef v_FilesToClean to_keep
561
562
563


-- find a temporary name that doesn't already exist.
564
565
newTempName :: DynFlags -> Suffix -> IO FilePath
newTempName DynFlags{tmpDir=tmp_dir} extn
566
  = do x <- getProcessID
567
       findTempName (tmp_dir ++ "/ghc" ++ show x ++ "_") 0
568
  where 
569
    findTempName prefix x
570
      = do let filename = (prefix ++ show x) `joinFileExt` extn
571
  	   b  <- doesFileExist filename
572
	   if b then findTempName prefix (x+1)
573
		else do consIORef v_FilesToClean filename -- clean it up later
574
575
576
577
		        return filename

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

580
581
removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
removeTmpFiles dflags fs
582
  = warnNon $
583
    traceCmd dflags "Deleting temp files" 
584
585
	     ("Deleting: " ++ unwords deletees)
	     (mapM_ rm deletees)
586
  where
587
588
589
590
591
592
593
594
595
     -- 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
596
        putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
597
598
	act

599
    (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
600

601
    rm f = removeFile f `IO.catch` 
602
		(\_ignored -> 
603
		    debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting non-existent") <+> text f)
604
		)
605
606
607
608
609


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

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

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

658
659
660


#if __GLASGOW_HASKELL__ < 603
661
builderMainLoop dflags filter_fn pgm real_args = do
662
663
  rawSystem pgm real_args
#else
664
builderMainLoop dflags filter_fn pgm real_args = do
665
666
667
668
669
670
  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
671
672
  forkIO (readerProc chan hStdOut filter_fn)
  forkIO (readerProc chan hStdErr filter_fn)
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
702
703
704
  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

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

727
	checkError l ls
728
729
730
	   = case matchRegex errRegex l of
		Nothing -> do
		    writeChan chan (BuildMsg (text l))
731
		    loop ls Nothing
732
733
734
735
736
737
738
		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
739
		    loop ls (Just (BuildError srcLoc (text msg)))
740

741
742
	leading_whitespace []    = False
	leading_whitespace (x:_) = isSpace x
743
744
745
746
747
748
749
750
751

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

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

752
753
754
755
showOpt (FileOption pre f) = pre ++ platformPath f
showOpt (Option "") = ""
showOpt (Option s)  = s

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

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

777
778
779
780
781
782
783
%************************************************************************
%*									*
\subsection{Support code}
%*									*
%************************************************************************

\begin{code}
784
-----------------------------------------------------------------------------
785
-- Define	getBaseDir     :: IO (Maybe String)
786

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

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

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

817
\end{code}