SysTools.lhs 22 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
-----------------------------------------------------------------------------
-- Access to system tools: gcc, cp, rm etc
--
-- (c) The University of Glasgow 2000
--
-----------------------------------------------------------------------------

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

	packageConfigPath,	-- IO String	
				-- Where package.conf is

	-- Interface to system tools
	runUnlit, runCpp, runCc, -- [String] -> IO ()
	runMangle, runSplit,	 -- [String] -> IO ()
	runAs, runLink,		 -- [String] -> IO ()
	runMkDLL,

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

	-- System interface
	getProcessID,		-- IO Int
37
	system, 		-- String -> IO Int
38
39
40

	-- Misc
	showGhcUsage,		-- IO ()	Shows usage message and exits
sof's avatar
sof committed
41
	getSysMan		-- IO String	Parallel system only
42
43
44
45
46

 ) where

import DriverUtil
import Config
47
import Outputable
48
49
50
51
import Panic		( progName, GhcException(..) )
import Util		( global )
import CmdLineOpts	( dynFlag, verbosity )

52
import Exception	( throwDyn, catchAllIO )
rrt's avatar
rrt committed
53
import IO
54
55
56
import Directory	( doesFileExist, removeFile )
import IOExts		( IORef, readIORef, writeIORef )
import Monad		( when, unless )
sof's avatar
sof committed
57
import System		( system, ExitCode(..), exitWith, getEnv )
sof's avatar
sof committed
58
59
60
import CString
import Int
import Addr
rrt's avatar
rrt committed
61
    
62
#include "../includes/config.h"
63
64
65

#if !defined(mingw32_TARGET_OS)
import qualified Posix
rrt's avatar
rrt committed
66
#else
sof's avatar
sof committed
67
68
import List		( isPrefixOf )
import MarshalArray
sof's avatar
sof committed
69
#endif
70

71
72
73
74
75
76
77
78
79
80
81
82
83
84
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
#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)
		


114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
---------------------------------------------
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
---------------------------------------------


138
139
140
141
142
143
%************************************************************************
%*									*
\subsection{Global variables to contain system programs}
%*									*
%************************************************************************

144
All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
145
146
(See remarks under pathnames below)

147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
\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
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)

-- Parallel system only
GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String)	-- system manager
\end{code}


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

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

177
178
179
180
181
	     -> IO String	-- Set all the mutable variables above, holding 
				--	(a) the system programs
				--	(b) the package-config file
				--	(c) the GHC usage message
				-- Return TopDir
182
183


184
185
186
187
188
initSysTools minusB_args
  = do  { (am_installed, top_dir) <- getTopDir minusB_args
		-- top_dir
		-- 	for "installed" this is the root of GHC's support files
		--	for "in-place" it is the root of the build tree
189
		-- NB: top_dir is assumed to be in standard Unix format '/' separated
190

191
	; let installed, installed_bin :: FilePath -> FilePath
rrt's avatar
rrt committed
192
              installed_bin pgm   =  pgmPath (top_dir `slash` "extra-bin") pgm
193
194
	      installed     file  =  pgmPath top_dir file
	      inplace dir   pgm   =  pgmPath (top_dir `slash` dir) pgm
195

196
197
198
	; let pkgconfig_path
		| am_installed = installed "package.conf"
		| otherwise    = inplace cGHC_DRIVER_DIR "package.conf.inplace"
199

200
201
202
	      ghc_usage_msg_path
		| am_installed = installed "ghc-usage.txt"
		| otherwise    = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
203

204
205
206
207
208
		-- 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
209
210

		-- split and mangle are Perl scripts
211
212
213
	      split_script
		| am_installed = installed_bin cGHC_SPLIT
		| otherwise    = inplace cGHC_SPLIT_DIR cGHC_SPLIT
214

215
216
217
218
	      mangle_script
		| am_installed = installed_bin cGHC_MANGLER
		| otherwise    = inplace cGHC_MANGLER_DIR cGHC_MANGLER

219
220
221
222
223
224
225
226
#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

227
228
229
230
	-- Check that the package config exists
	; config_exists <- doesFileExist pkgconfig_path
	; when (not config_exists) $
	     throwDyn (InstallationError 
rrt's avatar
rrt committed
231
		         ("Can't find package.conf as " ++ pkgconfig_path))
232

233
234
235
236
237
238
#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
239
240
241
242
243
244
245
246
	-- 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.
247
	; let gcc_path 	| am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib\\\"")
248
		       	| otherwise    = cGCC
249
250
251
252
253
254
255
256
		-- The trailing "\\" is absolutely essential; gcc seems
		-- to construct file names simply by concatenating to this
		-- -B path with no extra slash.
		-- We use "\\" rather than "/" because gcc_path is in NATIVE format
		--	(see comments with declarations of global variables)
		--
		-- The quotes round the -B argument are in case TopDir has spaces in it

257
	      perl_path | am_installed = installed_bin cGHC_PERL
258
259
260
		        | otherwise    = cGHC_PERL

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

264
265
266
267
268
	-- 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
	; let split_path  = perl_path ++ " " ++ split_script
	      mangle_path = perl_path ++ " " ++ mangle_script

269
270
271
272
273
274
	; 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.
275
	; let   gcc_path   = cGCC
276
		touch_path = cGHC_TOUCHY
rrt's avatar
rrt committed
277
		mkdll_path = panic "Can't build DLLs on a non-Win32 system"
278

279
280
281
282
	-- 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.
283
284
285
	; let split_path  = split_script
	      mangle_path = mangle_script
#endif
286

287
288
289
	-- cpp is derived from gcc on all platforms
        ; let cpp_path  = gcc_path ++ " -E " ++ cRAWCPP_FLAGS

rrt's avatar
rrt committed
290
	-- For all systems, copy and remove are provided by the host
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
	-- 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

				       
	-- 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
	; writeIORef v_Pgm_l   	 	   ld_path
	; writeIORef v_Pgm_MkDLL 	   mkdll_path
	; writeIORef v_Pgm_T   	 	   touch_path
	; writeIORef v_Pgm_CP  	 	   cp_path

318
	; return top_dir
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
	}
\end{code}

setPgm is called when a command-line option like
	-pgmLld
is used to override a particular program with a new onw

\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
setPgm pgm	   = unknownFlagErr ("-pgm" ++ pgm)
\end{code}


341
342
343
344
345
346
347
348
349
\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
350
--	   where GHC is running (only on Windows)
351
352
353
354
355
356
357
358
359
360
361
362
--
-- 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

getTopDir :: [String]
	  -> IO (Bool, 		-- True <=> am installed, False <=> in-place
363
	         String)	-- TopDir (in Unix format '/' separated)
364
365

getTopDir minusbs
rrt's avatar
rrt committed
366
367
  = do { top_dir <- get_proto
        -- Discover whether we're running in a build tree or in an installation,
368
	-- by looking for the package configuration file.
rrt's avatar
rrt committed
369
       ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
370

rrt's avatar
rrt committed
371
       ; return (am_installed, top_dir)
372
373
       }
  where
rrt's avatar
rrt committed
374
    -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
rrt's avatar
rrt committed
375
376
    get_proto | not (null minusbs)
	      = return (unDosifyPath (drop 2 (last minusbs)))	-- 2 for "-B"
377
	      | otherwise	   
378
	      = do { maybe_exec_dir <- getExecDir -- Get directory of executable
379
380
381
		   ; 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
382
			Just dir -> return dir
383
		   }
384
385
386
\end{code}


387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
%************************************************************************
%*									*
\subsection{Running an external program}
n%*									*
%************************************************************************


\begin{code}
runUnlit :: [String] -> IO ()
runUnlit args = do p <- readIORef v_Pgm_L
		   runSomething "Literate pre-processor" p args

runCpp :: [String] -> IO ()
runCpp args =   do p <- readIORef v_Pgm_P
		   runSomething "C pre-processor" p args

runCc :: [String] -> IO ()
runCc args =   do p <- readIORef v_Pgm_c
	          runSomething "C Compiler" p args

runMangle :: [String] -> IO ()
runMangle args = do p <- readIORef v_Pgm_m
		    runSomething "Mangler" p args

runSplit :: [String] -> IO ()
runSplit args = do p <- readIORef v_Pgm_s
		   runSomething "Splitter" p args

runAs :: [String] -> IO ()
runAs args = do p <- readIORef v_Pgm_a
		runSomething "Assembler" p args

runLink :: [String] -> IO ()
runLink args = do p <- readIORef v_Pgm_l
	          runSomething "Linker" p args

runMkDLL :: [String] -> IO ()
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
			runSomething purpose p [arg]

copy :: String -> String -> String -> IO ()
432
433
434
435
436
437
438
439
440
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
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
\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
461
		  ; exitWith ExitSuccess }
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
  where
     dump ""	      = return ()
     dump ('$':'$':s) = hPutStr stderr progName >> dump s
     dump (c:s)	      = hPutChar stderr c >> dump s

packageConfigPath = readIORef v_Path_package_config
\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
519
	     ("Deleting: " ++ unwords fs)
520
521
	     (mapM_ rm fs)
  where
522
523
524
525
526
    rm f = removeFile f `catchAllIO` 
		(\_ignored -> 
		    when (verb >= 2) $
		      hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
		)
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549

\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
	     -> [String]	-- Arguments
550
				--	runSomething will dos-ify them
551
552
553
554
	     -> IO ()

runSomething phase_name pgm args
 = traceCmd phase_name cmd_line $
555
   do   { exit_code <- system cmd_line
556
557
558
559
560
	; if exit_code /= ExitSuccess
	  then throwDyn (PhaseFailed phase_name exit_code)
  	  else return ()
	}
  where
rrt's avatar
rrt committed
561
    cmd_line = unwords (pgm : dosifyPaths (map quote args))
rrt's avatar
rrt committed
562
	-- The pgm is already in native format (appropriate dir separators)
sof's avatar
sof committed
563
#if defined(mingw32_TARGET_OS)
rrt's avatar
rrt committed
564
565
    quote "" = ""
    quote s  = "\"" ++ s ++ "\""
sof's avatar
sof committed
566
567
568
#else
    quote = id
#endif
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

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}


%************************************************************************
%*									*
595
\subsection{Path names}
596
597
598
%*									*
%************************************************************************

599
600
601
602
603
604
605
606
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'.
607
608
609
610
611

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

612
dosifyPaths :: [String] -> [String]
613
-- dosifyPaths does two things
614
615
616
-- a) change '/' to '\'
-- b) remove initial '/cygdrive/'

617
618
619
unDosifyPath :: String -> String
-- Just change '\' to '/'

620
621
622
623
624
625
626
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



627
#if defined(mingw32_TARGET_OS)
628
629

--------------------- Windows version ------------------
630
631
dosifyPaths xs = map dosifyPath xs

rrt's avatar
rrt committed
632
633
unDosifyPath xs = subst '\\' '/' xs

634
635
pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm

636
637
638
639
640
641
642
643
644
645
646
647
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
648
649

--------------------- Unix version ---------------------
sof's avatar
sof committed
650
dosifyPaths  ps = ps
rrt's avatar
rrt committed
651
unDosifyPath xs = xs
652
pgmPath dir pgm = dir ++ '/' : pgm
653
--------------------------------------------------------
654
655
#endif

656
657
658
659
subst a b ls = map (\ x -> if x == a then b else x) ls
\end{code}


660
-----------------------------------------------------------------------------
661
   Path name construction
662

663
\begin{code}
664
665
666
slash		 :: String -> String -> String
absPath, relPath :: [String] -> String

667
668
isSlash '/'   = True
isSlash other = False
669
670
671
672
673
674

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

absPath xs = "" `slash` relPath xs

675
slash s1 s2 = s1 ++ ('/' : s2)
676
677
\end{code}

678

679
680
681
682
683
684
685
%************************************************************************
%*									*
\subsection{Support code}
%*									*
%************************************************************************

\begin{code}
686
-----------------------------------------------------------------------------
rrt's avatar
rrt committed
687
-- Define	getExecDir     :: IO (Maybe String)
688

rrt's avatar
rrt committed
689
#if defined(mingw32_TARGET_OS)
rrt's avatar
rrt committed
690
getExecDir :: IO (Maybe String)
sof's avatar
sof committed
691
getExecDir = do let len = 2048 -- plenty, PATH_MAX is 512 under Win32.
sof's avatar
sof committed
692
693
694
695
696
		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
697
				    return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))
sof's avatar
sof committed
698

sof's avatar
sof committed
699
700

foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int32 -> IO Int32
rrt's avatar
rrt committed
701
#else
rrt's avatar
rrt committed
702
getExecDir :: IO (Maybe String) = do return Nothing
rrt's avatar
rrt committed
703
#endif
rrt's avatar
rrt committed
704
705
706

#ifdef mingw32_TARGET_OS
foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
707
708
709
710
711
#else
getProcessID :: IO Int
getProcessID = Posix.getProcessID
#endif
\end{code}