SysTools.lhs 25.2 KB
Newer Older
1
-----------------------------------------------------------------------------
rrt's avatar
rrt committed
2
-- $Id: SysTools.lhs,v 1.52 2001/08/15 15:02:04 rrt Exp $
3
4
--
-- (c) The University of Glasgow 2001
5
--
6
-- Access to system tools: gcc, cp, rm etc
7
8
9
10
11
12
13
14
15
16
17
--
-----------------------------------------------------------------------------

\begin{code}
module SysTools (
	-- Initialisation
	initSysTools,
	setPgm,			-- String -> IO ()
				-- Command-line override
	setDryRun,

18
19
	getTopDir,		-- IO String	-- The value of $libdir
	getPackageConfigPath,	-- IO String	-- Where package.conf is
20
21

	-- Interface to system tools
sof's avatar
sof committed
22
23
24
	runUnlit, runCpp, runCc, -- [Option] -> IO ()
	runMangle, runSplit,	 -- [Option] -> IO ()
	runAs, runLink,		 -- [Option] -> IO ()
25
	runMkDLL,
rrt's avatar
rrt committed
26
27
28
29
#ifdef ILX
        runIlx2il, runIlasm,     -- [String] -> IO ()
#endif

30
31
32

	touch,			-- String -> String -> IO ()
	copy,			-- String -> String -> String -> IO ()
rrt's avatar
rrt committed
33
	unDosifyPath,           -- String -> String
34
35
36
37
38
39
40
41
42
	
	-- Temporary-file management
	setTmpDir,
	newTempName,
	cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
	addFilesToClean,

	-- System interface
	getProcessID,		-- IO Int
rrt's avatar
rrt committed
43
	system, 		-- String -> IO ExitCode
44
45
46

	-- Misc
	showGhcUsage,		-- IO ()	Shows usage message and exits
sof's avatar
sof committed
47
48
49
	getSysMan,		-- IO String	Parallel system only
	
	Option(..)
50
51
52
53
54

 ) where

import DriverUtil
import Config
55
import Outputable
56
57
58
59
import Panic		( progName, GhcException(..) )
import Util		( global )
import CmdLineOpts	( dynFlag, verbosity )

60
import Exception	( throwDyn, catchAllIO )
rrt's avatar
rrt committed
61
import IO
62
63
64
import Directory	( doesFileExist, removeFile )
import IOExts		( IORef, readIORef, writeIORef )
import Monad		( when, unless )
rrt's avatar
rrt committed
65
import System		( ExitCode(..), exitWith, getEnv, system )
sof's avatar
sof committed
66
67
68
import CString
import Int
import Addr
rrt's avatar
rrt committed
69
    
70
#include "../includes/config.h"
71

rrt's avatar
rrt committed
72
#ifndef mingw32_TARGET_OS
73
import qualified Posix
rrt's avatar
rrt committed
74
#else
sof's avatar
sof committed
75
76
import List		( isPrefixOf )
import MarshalArray
rrt's avatar
rrt committed
77
78
#endif

rrt's avatar
rrt committed
79
80
81
82
83
84
-- use the line below when we can be sure of compiling with GHC >=
-- 5.02, and remove the implementation of rawSystem at the end of this
-- file
import PrelIOBase -- this can be removed when SystemExts is used
import CError     ( throwErrnoIfMinus1 ) -- as can this
-- import SystemExts       ( rawSystem )
85

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
121
122
123
124
125
126
127
128
#include "HsVersions.h"

\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
				

  cUNLIT_DIR	The *path* to the directory containing unlit, split etc
  cSPLIT_DIR	*relative* to the root of the build tree,
		for use when running *in-place* in a build tree (only)
		


129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
---------------------------------------------
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 = [],
     extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${libdir}/bin/unlit", ... etc.],
     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
---------------------------------------------


153
154
155
156
157
158
%************************************************************************
%*									*
\subsection{Global variables to contain system programs}
%*									*
%************************************************************************

159
All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
160
161
(See remarks under pathnames below)

162
163
164
165
166
167
168
\begin{code}
GLOBAL_VAR(v_Pgm_L,   	error "pgm_L",   String)	-- unlit
GLOBAL_VAR(v_Pgm_P,   	error "pgm_P",   String)	-- cpp
GLOBAL_VAR(v_Pgm_c,   	error "pgm_c",   String)	-- gcc
GLOBAL_VAR(v_Pgm_m,   	error "pgm_m",   String)	-- asm code mangler
GLOBAL_VAR(v_Pgm_s,   	error "pgm_s",   String)	-- asm code splitter
GLOBAL_VAR(v_Pgm_a,   	error "pgm_a",   String)	-- as
rrt's avatar
rrt committed
169
170
171
172
#ifdef ILX
GLOBAL_VAR(v_Pgm_I,     error "pgm_I",   String)        -- ilx2il
GLOBAL_VAR(v_Pgm_i,     error "pgm_i",   String)        -- ilasm
#endif
173
174
175
176
177
178
179
180
181
GLOBAL_VAR(v_Pgm_l,   	error "pgm_l",   String)	-- ld
GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String)	-- mkdll

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)
GLOBAL_VAR(v_Path_usage,  	  error "ghc_usage.txt",       String)

182
183
GLOBAL_VAR(v_TopDir,	error "TopDir",	String)		-- -B<dir>

184
185
-- Parallel system only
GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String)	-- system manager
186
187
188
189

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


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

\begin{code}
200
initSysTools :: [String]	-- Command-line arguments starting "-B"
201

202
	     -> IO ()		-- Set all the mutable variables above, holding 
203
204
205
				--	(a) the system programs
				--	(b) the package-config file
				--	(c) the GHC usage message
206
207


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

216
	; let installed, installed_bin :: FilePath -> FilePath
rrt's avatar
rrt committed
217
              installed_bin pgm   =  pgmPath (top_dir `slash` "extra-bin") pgm
218
219
	      installed     file  =  pgmPath top_dir file
	      inplace dir   pgm   =  pgmPath (top_dir `slash` dir) pgm
220

221
222
223
	; let pkgconfig_path
		| am_installed = installed "package.conf"
		| otherwise    = inplace cGHC_DRIVER_DIR "package.conf.inplace"
224

225
226
227
	      ghc_usage_msg_path
		| am_installed = installed "ghc-usage.txt"
		| otherwise    = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
228

229
230
231
232
233
		-- For all systems, unlit, split, mangle are GHC utilities
		-- architecture-specific stuff is done when building Config.hs
	      unlit_path
		| am_installed = installed_bin cGHC_UNLIT
		| otherwise    = inplace cGHC_UNLIT_DIR cGHC_UNLIT
234
235

		-- split and mangle are Perl scripts
236
237
238
	      split_script
		| am_installed = installed_bin cGHC_SPLIT
		| otherwise    = inplace cGHC_SPLIT_DIR cGHC_SPLIT
239

240
241
242
243
	      mangle_script
		| am_installed = installed_bin cGHC_MANGLER
		| otherwise    = inplace cGHC_MANGLER_DIR cGHC_MANGLER

244
245
246
247
248
249
250
251
#ifndef mingw32_TARGET_OS
	-- check whether TMPDIR is set in the environment
	; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
	      	     setTmpDir dir
	      	     return ()
                 )
#endif

252
253
254
255
	-- Check that the package config exists
	; config_exists <- doesFileExist pkgconfig_path
	; when (not config_exists) $
	     throwDyn (InstallationError 
rrt's avatar
rrt committed
256
		         ("Can't find package.conf as " ++ pkgconfig_path))
257

258
259
260
261
262
263
#if defined(mingw32_TARGET_OS)
	--		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
264
265
266
267
268
269
270
271
	-- 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.
rrt's avatar
rrt committed
272
	; let gcc_path 	| am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
273
		       	| otherwise    = cGCC
rrt's avatar
rrt committed
274
		-- The trailing "/" is absolutely essential; gcc seems
275
		-- to construct file names simply by concatenating to this
rrt's avatar
rrt committed
276
277
278
		-- -B path with no extra slash
		-- We use "/" rather than "\\" because otherwise "\\\" is mangled
		-- later on; although gcc_path is in NATIVE format, gcc can cope
279
280
281
282
		--	(see comments with declarations of global variables)
		--
		-- The quotes round the -B argument are in case TopDir has spaces in it

283
	      perl_path | am_installed = installed_bin cGHC_PERL
284
285
286
		        | otherwise    = cGHC_PERL

	-- 'touch' is a GHC util for Windows, and similarly unlit, mangle
287
	; let touch_path  | am_installed = installed_bin cGHC_TOUCHY
288
289
		       	  | otherwise    = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY

290
291
	-- 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
rrt's avatar
rrt committed
292
293
	; let split_path  = perl_path ++ " \"" ++ split_script ++ "\""
	      mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
294

295
296
297
298
299
300
	; let mkdll_path = cMKDLL
#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.
301
	; let   gcc_path   = cGCC
302
		touch_path = cGHC_TOUCHY
rrt's avatar
rrt committed
303
		mkdll_path = panic "Can't build DLLs on a non-Win32 system"
304

305
306
307
308
	-- 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.
309
310
311
	; let split_path  = split_script
	      mangle_path = mangle_script
#endif
312

313
314
315
	-- cpp is derived from gcc on all platforms
        ; let cpp_path  = gcc_path ++ " -E " ++ cRAWCPP_FLAGS

rrt's avatar
rrt committed
316
	-- For all systems, copy and remove are provided by the host
317
318
319
320
321
322
323
	-- 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
	; let	as_path  = gcc_path
		ld_path  = gcc_path

rrt's avatar
rrt committed
324
325
326
327
328
#ifdef ILX
       -- ilx2il and ilasm are specified in Config.hs
       ; let    ilx2il_path = cILX2IL
		ilasm_path  = cILASM
#endif
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
				       
	-- Initialise the global vars
	; writeIORef v_Path_package_config pkgconfig_path
	; writeIORef v_Path_usage 	   ghc_usage_msg_path

	; 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_L   	 	   unlit_path
	; writeIORef v_Pgm_P   	 	   cpp_path
	; writeIORef v_Pgm_c   	 	   gcc_path
	; writeIORef v_Pgm_m   	 	   mangle_path
	; writeIORef v_Pgm_s   	 	   split_path
	; writeIORef v_Pgm_a   	 	   as_path
rrt's avatar
rrt committed
344
345
346
347
#ifdef ILX
	; writeIORef v_Pgm_I               ilx2il_path
	; writeIORef v_Pgm_i               ilasm_path
#endif
348
349
350
351
352
	; writeIORef v_Pgm_l   	 	   ld_path
	; writeIORef v_Pgm_MkDLL 	   mkdll_path
	; writeIORef v_Pgm_T   	 	   touch_path
	; writeIORef v_Pgm_CP  	 	   cp_path

353
	; return ()
354
355
356
357
358
	}
\end{code}

setPgm is called when a command-line option like
	-pgmLld
rrt's avatar
rrt committed
359
is used to override a particular program with a new one
360
361
362
363
364
365
366
367
368
369
370
371

\begin{code}
setPgm :: String -> IO ()
-- The string is the flag, minus the '-pgm' prefix
-- So the first character says which program to override

setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
rrt's avatar
rrt committed
372
373
374
375
#ifdef ILX
setPgm ('I' : pgm) = writeIORef v_Pgm_I pgm
setPgm ('i' : pgm) = writeIORef v_Pgm_i pgm
#endif
376
377
378
379
setPgm pgm	   = unknownFlagErr ("-pgm" ++ pgm)
\end{code}


380
381
382
383
384
385
386
387
388
\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
-- 	a) look for (the last) -B flag, and use it
--	b) if there are no -B flags, get the directory 
rrt's avatar
rrt committed
389
--	   where GHC is running (only on Windows)
390
391
392
393
394
395
396
397
398
399
--
-- 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

400
findTopDir :: [String]
401
	  -> IO (Bool, 		-- True <=> am installed, False <=> in-place
402
	         String)	-- TopDir (in Unix format '/' separated)
403

404
findTopDir minusbs
rrt's avatar
rrt committed
405
406
  = do { top_dir <- get_proto
        -- Discover whether we're running in a build tree or in an installation,
407
	-- by looking for the package configuration file.
rrt's avatar
rrt committed
408
       ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
409

rrt's avatar
rrt committed
410
       ; return (am_installed, top_dir)
411
412
       }
  where
rrt's avatar
rrt committed
413
    -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
rrt's avatar
rrt committed
414
415
    get_proto | not (null minusbs)
	      = return (unDosifyPath (drop 2 (last minusbs)))	-- 2 for "-B"
416
	      | otherwise	   
417
	      = do { maybe_exec_dir <- getExecDir -- Get directory of executable
418
419
420
		   ; case maybe_exec_dir of	  -- (only works on Windows; 
						  --  returns Nothing on Unix)
			Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
rrt's avatar
rrt committed
421
			Just dir -> return dir
422
		   }
423
424
425
\end{code}


sof's avatar
sof committed
426
427
428
429
430
431
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
%************************************************************************
%*									*
\subsection{Command-line options}
n%*									*
%************************************************************************

When invoking external tools as part of the compilation pipeline, we
pass these a sequence of options on the command-line. Rather than
just using a list of Strings, we use a type that allows us to distinguish
between filepaths and 'other stuff'. [The reason being, of course, that
this type gives us a handle on transforming filenames, and filenames only,
to whatever format they're expected to be on a particular platform.]


\begin{code}
data Option
 = FileOption String
 | Option     String
 
showOptions :: [Option] -> String
showOptions ls = unwords (map (quote.showOpt) ls)
 where
   showOpt (FileOption f) = dosifyPath f
   showOpt (Option s)     = s

#if defined(mingw32_TARGET_OS)
   quote "" = ""
   quote s  = "\"" ++ s ++ "\""
#else
   quote = id
#endif

\end{code}


461
462
463
464
465
466
467
468
%************************************************************************
%*									*
\subsection{Running an external program}
n%*									*
%************************************************************************


\begin{code}
sof's avatar
sof committed
469
runUnlit :: [Option] -> IO ()
470
471
472
runUnlit args = do p <- readIORef v_Pgm_L
		   runSomething "Literate pre-processor" p args

sof's avatar
sof committed
473
runCpp :: [Option] -> IO ()
474
475
476
runCpp args =   do p <- readIORef v_Pgm_P
		   runSomething "C pre-processor" p args

sof's avatar
sof committed
477
runCc :: [Option] -> IO ()
478
479
480
runCc args =   do p <- readIORef v_Pgm_c
	          runSomething "C Compiler" p args

sof's avatar
sof committed
481
runMangle :: [Option] -> IO ()
482
483
484
runMangle args = do p <- readIORef v_Pgm_m
		    runSomething "Mangler" p args

sof's avatar
sof committed
485
runSplit :: [Option] -> IO ()
486
487
488
runSplit args = do p <- readIORef v_Pgm_s
		   runSomething "Splitter" p args

sof's avatar
sof committed
489
runAs :: [Option] -> IO ()
490
491
492
runAs args = do p <- readIORef v_Pgm_a
		runSomething "Assembler" p args

sof's avatar
sof committed
493
runLink :: [Option] -> IO ()
494
495
496
runLink args = do p <- readIORef v_Pgm_l
	          runSomething "Linker" p args

rrt's avatar
rrt committed
497
498
499
500
501
502
503
504
505
506
#ifdef ILX
runIlx2il :: [String] -> IO ()
runIlx2il args = do p <- readIORef v_Pgm_I
	            runSomething "Ilx2Il" p args

runIlasm :: [String] -> IO ()
runIlasm args = do p <- readIORef v_Pgm_i
	           runSomething "Ilasm" p args
#endif

sof's avatar
sof committed
507
runMkDLL :: [Option] -> IO ()
508
509
510
511
512
runMkDLL args = do p <- readIORef v_Pgm_MkDLL
	           runSomething "Make DLL" p args

touch :: String -> String -> IO ()
touch purpose arg =  do p <- readIORef v_Pgm_T
sof's avatar
sof committed
513
			runSomething purpose p [FileOption arg]
514
515

copy :: String -> String -> String -> IO ()
516
517
518
519
520
521
522
523
524
copy purpose from to = do
  verb <- dynFlag verbosity
  when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)

  h <- openFile to WriteMode
  ls <- readFile from -- inefficient, but it'll do for now.
	    	      -- ToDo: speed up via slurping.
  hPutStr h ls
  hClose h
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
\end{code}

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

%************************************************************************
%*									*
\subsection{GHC Usage message}
%*									*
%************************************************************************

Show the usage message and exit

\begin{code}
showGhcUsage = do { usage_path <- readIORef v_Path_usage
		  ; usage      <- readFile usage_path
		  ; dump usage
rrt's avatar
rrt committed
545
		  ; exitWith ExitSuccess }
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
  where
     dump ""	      = return ()
     dump ('$':'$':s) = hPutStr stderr progName >> dump s
     dump (c:s)	      = hPutChar stderr c >> dump s
\end{code}


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

\begin{code}
GLOBAL_VAR(v_FilesToClean, [],               [String] )
GLOBAL_VAR(v_TmpDir,       cDEFAULT_TMPDIR,  String   )
	-- v_TmpDir has no closing '/'
\end{code}

\begin{code}
setTmpDir dir = writeIORef v_TmpDir dir

cleanTempFiles :: Int -> IO ()
cleanTempFiles verb = do fs <- readIORef v_FilesToClean
			 removeTmpFiles verb fs

cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
cleanTempFilesExcept verb dont_delete
  = do fs <- readIORef v_FilesToClean
       let leftovers = filter (`notElem` dont_delete) fs
       removeTmpFiles verb leftovers
       writeIORef v_FilesToClean dont_delete


-- find a temporary name that doesn't already exist.
newTempName :: Suffix -> IO FilePath
newTempName extn
  = do x <- getProcessID
       tmp_dir <- readIORef v_TmpDir
       findTempName tmp_dir x
  where 
    findTempName tmp_dir x
      = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
  	   b  <- doesFileExist filename
	   if b then findTempName tmp_dir (x+1)
		else do add v_FilesToClean filename -- clean it up later
		        return filename

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

removeTmpFiles :: Int -> [FilePath] -> IO ()
removeTmpFiles verb fs
  = traceCmd "Deleting temp files" 
sof's avatar
sof committed
601
	     ("Deleting: " ++ unwords fs)
602
603
	     (mapM_ rm fs)
  where
604
605
606
607
608
    rm f = removeFile f `catchAllIO` 
		(\_ignored -> 
		    when (verb >= 2) $
		      hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
		)
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630

\end{code}


%************************************************************************
%*									*
\subsection{Running a program}
%*									*
%************************************************************************

\begin{code}
GLOBAL_VAR(v_Dry_run, False, Bool)

setDryRun :: IO () 
setDryRun = writeIORef v_Dry_run True

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

runSomething :: String		-- For -v message
	     -> String		-- Command name (possibly a full path)
				-- 	assumed already dos-ified
sof's avatar
sof committed
631
	     -> [Option]	-- Arguments
632
				--	runSomething will dos-ify them
633
634
635
636
	     -> IO ()

runSomething phase_name pgm args
 = traceCmd phase_name cmd_line $
rrt's avatar
rrt committed
637
638
639
640
641
642
   do   {
#ifndef mingw32_TARGET_OS
	  exit_code <- system cmd_line
#else
          exit_code <- rawSystem cmd_line
#endif
643
644
645
646
647
	; if exit_code /= ExitSuccess
	  then throwDyn (PhaseFailed phase_name exit_code)
  	  else return ()
	}
  where
sof's avatar
sof committed
648
    cmd_line = pgm ++ ' ':showOptions args -- unwords (pgm : dosifyPaths (map quote args))
rrt's avatar
rrt committed
649
	-- The pgm is already in native format (appropriate dir separators)
sof's avatar
sof committed
650
#if defined(mingw32_TARGET_OS)
rrt's avatar
rrt committed
651
652
    quote "" = ""
    quote s  = "\"" ++ s ++ "\""
sof's avatar
sof committed
653
654
655
#else
    quote = id
#endif
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681

traceCmd :: String -> String -> IO () -> IO ()
-- a) trace the command (at two levels of verbosity)
-- b) don't do it at all if dry-run is set
traceCmd phase_name cmd_line action
 = do	{ verb <- dynFlag verbosity
	; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
	; when (verb >= 3) $ hPutStrLn stderr cmd_line
	; hFlush stderr
	
	   -- Test for -n flag
	; n <- readIORef v_Dry_run
	; unless n $ do {

	   -- And run it!
	; action `catchAllIO` handle_exn verb
	}}
  where
    handle_exn verb exn = do { when (verb >= 2) (hPutStr   stderr "\n")
			     ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
	          	     ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}


%************************************************************************
%*									*
682
\subsection{Path names}
683
684
685
%*									*
%************************************************************************

686
687
688
689
690
691
692
693
We maintain path names in Unix form ('/'-separated) right until 
the last moment.  On Windows we dos-ify them just before passing them
to the Windows command.

The alternative, of using '/' consistently on Unix and '\' on Windows,
proved quite awkward.  There were a lot more calls to dosifyPath,
and even on Windows we might invoke a unix-like utility (eg 'sh'), which
interpreted a command line 'foo\baz' as 'foobaz'.
694
695
696
697
698

\begin{code}
-----------------------------------------------------------------------------
-- Convert filepath into MSDOS form.

699
dosifyPaths :: [String] -> [String]
700
-- dosifyPaths does two things
701
702
703
-- a) change '/' to '\'
-- b) remove initial '/cygdrive/'

704
705
706
unDosifyPath :: String -> String
-- Just change '\' to '/'

707
708
709
710
711
712
713
pgmPath :: String		-- Directory string in Unix format
	-> String		-- Program name with no directory separators
				--	(e.g. copy /y)
	-> String		-- Program invocation string in native format



714
#if defined(mingw32_TARGET_OS)
715
716

--------------------- Windows version ------------------
717
718
dosifyPaths xs = map dosifyPath xs

rrt's avatar
rrt committed
719
720
unDosifyPath xs = subst '\\' '/' xs

721
722
pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm

rrt's avatar
rrt committed
723
724
725
726
727
-- HACK!
dosifyPath "\"/DLL\"" = "\"/DLL\""
dosifyPath "\"/QUIET\"" = "\"/QUIET\""
dosifyPath l@('"':'/':'O':'U':'T':_) = l
-- end of HACK!
728
729
730
731
732
733
734
735
736
737
738
739
dosifyPath stuff
  = subst '/' '\\' real_stuff
 where
   -- fully convince myself that /cygdrive/ prefixes cannot
   -- really appear here.
  cygdrive_prefix = "/cygdrive/"

  real_stuff
    | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
    | otherwise = stuff
   
#else
740
741

--------------------- Unix version ---------------------
sof's avatar
sof committed
742
743
744
745
dosifyPaths  ps  = ps
unDosifyPath xs  = xs
pgmPath dir pgm  = dir ++ '/' : pgm
dosifyPath stuff = stuff
746
--------------------------------------------------------
747
748
#endif

749
750
751
752
subst a b ls = map (\ x -> if x == a then b else x) ls
\end{code}


753
-----------------------------------------------------------------------------
754
   Path name construction
755

756
\begin{code}
757
758
759
slash		 :: String -> String -> String
absPath, relPath :: [String] -> String

760
761
isSlash '/'   = True
isSlash other = False
762
763
764
765
766
767

relPath [] = ""
relPath xs = foldr1 slash xs

absPath xs = "" `slash` relPath xs

768
slash s1 s2 = s1 ++ ('/' : s2)
769
770
\end{code}

771

772
773
774
775
776
777
778
%************************************************************************
%*									*
\subsection{Support code}
%*									*
%************************************************************************

\begin{code}
779
-----------------------------------------------------------------------------
rrt's avatar
rrt committed
780
-- Define	getExecDir     :: IO (Maybe String)
781

rrt's avatar
rrt committed
782
#if defined(mingw32_TARGET_OS)
rrt's avatar
rrt committed
783
getExecDir :: IO (Maybe String)
sof's avatar
sof committed
784
getExecDir = do let len = 2048 -- plenty, PATH_MAX is 512 under Win32.
sof's avatar
sof committed
785
786
787
788
789
		buf <- mallocArray (fromIntegral len)
		ret <- getModuleFileName nullAddr buf len
		if ret == 0 then return Nothing
		            else do s <- peekCString buf
				    destructArray (fromIntegral len) buf
rrt's avatar
rrt committed
790
				    return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))
sof's avatar
sof committed
791

sof's avatar
sof committed
792
793

foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int32 -> IO Int32
rrt's avatar
rrt committed
794
#else
rrt's avatar
rrt committed
795
getExecDir :: IO (Maybe String) = do return Nothing
rrt's avatar
rrt committed
796
#endif
rrt's avatar
rrt committed
797
798
799

#ifdef mingw32_TARGET_OS
foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
800
801
802
803
#else
getProcessID :: IO Int
getProcessID = Posix.getProcessID
#endif
rrt's avatar
rrt committed
804
805
806
807

rawSystem :: String -> IO ExitCode
rawSystem "" = ioException (IOError Nothing InvalidArgument "rawSystem" "null command" Nothing)
rawSystem cmd =
rrt's avatar
rrt committed
808
  withCString cmd $ \s -> do
rrt's avatar
rrt committed
809
810
811
812
813
    status <- throwErrnoIfMinus1 "rawSystem" (primRawSystem s)
    case status of
        0  -> return ExitSuccess
        n  -> return (ExitFailure n)

rrt's avatar
rrt committed
814
foreign import ccall "rawSystemCmd" unsafe primRawSystem :: CString -> IO Int
rrt's avatar
rrt committed
815

816
\end{code}