SysTools.lhs 20.4 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
27
28
29
30
31
32
33
34
35
-----------------------------------------------------------------------------
-- 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 ()
	
	-- Temporary-file management
	setTmpDir,
	newTempName,
	cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
	addFilesToClean,

	-- System interface
	getProcessID,		-- IO Int
36
	system, 		-- String -> IO Int
37
38
39
40
41
42
43
44
45
46

	-- Misc
	showGhcUsage,		-- IO ()	Shows usage message and exits
	getSysMan,		-- IO String	Parallel system only

	runSomething	-- ToDo: make private
 ) 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 )
53
import IO		( hPutStr, hPutChar, hPutStrLn, hFlush, stderr )
54
55
56
import Directory	( doesFileExist, removeFile )
import IOExts		( IORef, readIORef, writeIORef )
import Monad		( when, unless )
rrt's avatar
rrt committed
57
58
59
60
61
62
63
64
import System		( system, ExitCode(..), exitWith )
import CString

#if __GLASGOW_HASKELL__ < 500
import Addr
import Storable
import Int
#endif
65
66

#include "../includes/config.h"
67
68
69

#if !defined(mingw32_TARGET_OS)
import qualified Posix
rrt's avatar
rrt committed
70
#else
71
72
import Addr             ( nullAddr )
import List		( isPrefixOf )
73
74
#endif

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
114
115
116
117
118
119
120
121
122
123
124
125
#include "HsVersions.h"

{-# DEPRECATED runSomething "runSomething should be private to SysTools" #-}

\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)
		


%************************************************************************
%*									*
\subsection{Global variables to contain system programs}
%*									*
%************************************************************************

126
All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
127
128
(See remarks under pathnames below)

129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
\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}
157
initSysTools :: [String]	-- Command-line arguments starting "-B"
158

159
160
161
162
163
	     -> 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
164
165


166
167
168
169
170
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
171
		-- NB: top_dir is assumed to be in standard Unix format '/' separated
172

173
174
175
	; let installed_bin pgm   =  pgmPath (top_dir `slash` "bin") pgm
	      installed     file  =  pgmPath top_dir file
	      inplace dir   pgm   =  pgmPath (top_dir `slash` dir) pgm
176

177
178
179
	; let pkgconfig_path
		| am_installed = installed "package.conf"
		| otherwise    = inplace cGHC_DRIVER_DIR "package.conf.inplace"
180

181
182
183
	      ghc_usage_msg_path
		| am_installed = installed "ghc-usage.txt"
		| otherwise    = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
184

185
186
187
188
189
		-- 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
190
191

		-- split and mangle are Perl scripts
192
193
194
	      split_script
		| am_installed = installed_bin cGHC_SPLIT
		| otherwise    = inplace cGHC_SPLIT_DIR cGHC_SPLIT
195

196
197
198
199
200
201
202
203
204
	      mangle_script
		| am_installed = installed_bin cGHC_MANGLER
		| otherwise    = inplace cGHC_MANGLER_DIR cGHC_MANGLER

	-- Check that the package config exists
	; config_exists <- doesFileExist pkgconfig_path
	; when (not config_exists) $
	     throwDyn (InstallationError 
		         ("Can't find package.conf in " ++ pkgconfig_path))
205

206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
#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
	; let cpp_path 	| am_installed = installed cRAWCPP
		       	| otherwise    = cRAWCPP
	      gcc_path 	| am_installed = installed cGCC
		       	| otherwise    = cGCC
	      perl_path | am_installed = installed cGHC_PERL
		        | otherwise    = cGHC_PERL

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

223
224
225
226
227
	-- 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

228
229
230
231
232
233
234
235
236
	; 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.
	; let	cpp_path   = cRAWCPP
		gcc_path   = cGCC
		touch_path = cGHC_TOUCHY
rrt's avatar
rrt committed
237
		mkdll_path = panic "Can't build DLLs on a non-Win32 system"
238

239
240
241
242
	-- 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.
243
244
	; let split_path  = split_script
	      mangle_path = mangle_script
245

246
#endif
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275

	-- For all systems, copy and remove are provided by the host 
	-- 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

276
	; return top_dir
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
	}
\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}


299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
\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 
--	   where GHC is running
--
-- 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
321
	         String)	-- TopDir (in Unix format '/' separated)
322
323

getTopDir minusbs
324
325
  = do { top_dir1 <- get_proto
       ; let top_dir2 = unDosifyPath top_dir1	-- Convert to standard internal form
326
327
328

	-- Discover whether we're running in a build tree or in an installation,
	-- by looking for the package configuration file.
329
       ; am_installed <- doesFileExist (top_dir2 `slash` "package.conf")
330
331

       ; if am_installed then
332
	    return (True, top_dir2)
333
	 else
334
	    return (False, remove_suffix top_dir2)
335
336
337
       }
  where
    get_proto | not (null minusbs) 
338
	      = return (drop 2 (last minusbs))	-- 2 for "-B"
339
	      | otherwise	   
340
	      = do { maybe_exec_dir <- getExecDir -- Get directory of executable
341
342
343
		   ; case maybe_exec_dir of	  -- (only works on Windows; 
						  --  returns Nothing on Unix)
			Nothing  -> throwDyn (InstallationError "missing -B<dir> option")
344
345
			Just dir -> return dir
		   }
346
347
348
349

    remove_suffix dir	-- "/...stuff.../ghc/compiler" --> "/...stuff..."
	= ASSERT2( not (null p1) && 
		   not (null p2) && 
350
		   dir == top_dir ++ "/ghc/compiler",
351
352
353
354
355
356
357
358
359
		   text dir )
	  top_dir
	where
	 p1      = dropWhile (not . isSlash) (reverse dir)
	 p2      = dropWhile (not . isSlash) (tail p1)	-- head is '/'
	 top_dir = reverse (tail p2)			-- head is '/'
\end{code}


360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
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
%************************************************************************
%*									*
\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 ()
copy purpose from to = do p <- readIORef v_Pgm_CP
		          runSomething purpose p [from,to]
\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
427
		  ; exitWith ExitSuccess }
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
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
  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
485
	     ("Deleting: " ++ unwords fs)
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
	     (mapM_ rm fs)
  where
    rm f = removeFile f `catchAllIO`
		(\exn -> hPutStrLn stderr ("Warning: deleting non-existent " ++ f) >>
		         return ())

\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
514
				--	runSomething will dos-ify them
515
516
517
518
	     -> IO ()

runSomething phase_name pgm args
 = traceCmd phase_name cmd_line $
519
   do   { exit_code <- system cmd_line
520
521
522
523
524
	; if exit_code /= ExitSuccess
	  then throwDyn (PhaseFailed phase_name exit_code)
  	  else return ()
	}
  where
525
526
    cmd_line = unwords (pgm : dosifyPaths args)
	-- The pgm is already in native format
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552

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}


%************************************************************************
%*									*
553
\subsection{Path names}
554
555
556
%*									*
%************************************************************************

557
558
559
560
561
562
563
564
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'.
565
566
567
568
569

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

570
dosifyPaths :: [String] -> [String]
571
-- dosifyPaths does two things
572
573
574
-- a) change '/' to '\'
-- b) remove initial '/cygdrive/'

575
576
577
unDosifyPath :: String -> String
-- Just change '\' to '/'

578
579
580
581
582
583
584
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



585
#if defined(mingw32_TARGET_OS)
586
587
588
589

--------------------- Windows version ------------------
unDosifyPath xs = xs

590
591
dosifyPaths xs = map dosifyPath xs

592
593
pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm

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

--------------------- Unix version ---------------------
sof's avatar
sof committed
608
dosifyPaths  ps = ps
609
unDosifyPath xs = subst '\\' '/' xs
610
pgmPath dir pgm = dir ++ '/' : pgm
611
--------------------------------------------------------
612
613
#endif

614
615
616
617
subst a b ls = map (\ x -> if x == a then b else x) ls
\end{code}


618
-----------------------------------------------------------------------------
619
   Path name construction
620

621
\begin{code}
622
623
624
slash		 :: String -> String -> String
absPath, relPath :: [String] -> String

625
626
isSlash '/'   = True
isSlash other = False
627
628
629
630
631
632

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

absPath xs = "" `slash` relPath xs

633
slash s1 s2 = s1 ++ ('/' : s2)
634
635
\end{code}

636

637
638
639
640
641
642
643
%************************************************************************
%*									*
\subsection{Support code}
%*									*
%************************************************************************

\begin{code}
644
645
-----------------------------------------------------------------------------
-- Define	myGetProcessId :: IO Int
646
--		getExecDir     :: IO (Maybe String)
647
648

#ifdef mingw32_TARGET_OS
rrt's avatar
rrt committed
649
foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
650

rrt's avatar
rrt committed
651
#if __GLASGOW_HASKELL__ >= 500
652
foreign import stdcall "GetCurrentDirectoryA" getCurrentDirectory :: Int32 -> CString -> IO Int32
rrt's avatar
rrt committed
653
getExecDir :: IO (Maybe String)
654
getExecDir = do len <- getCurrentDirectory 0 nullAddr
rrt's avatar
rrt committed
655
656
657
658
659
660
		buf <- mallocArray (fromIntegral len)
		ret <- getCurrentDirectory len buf
		if ret == 0 then return Nothing
		            else do s <- peekCString buf
				    destructArray (fromIntegral len) buf
				    return (Just s)
rrt's avatar
rrt committed
661
662
663
664
665
666
667
668
669
670
671
#else
foreign import stdcall "GetCurrentDirectoryA" getCurrentDirectory :: Int32 -> Addr -> IO Int32
getExecDir :: IO (Maybe String)
getExecDir = do len <- getCurrentDirectory 0 nullAddr
		buf <- malloc (fromIntegral len)
		ret <- getCurrentDirectory len buf
		if ret == 0 then return Nothing
		            else do s <- unpackCStringIO buf
				    free buf
				    return (Just s)
#endif
672
673
674
#else
getProcessID :: IO Int
getProcessID = Posix.getProcessID
rrt's avatar
rrt committed
675
getExecDir :: IO (Maybe String) = do return Nothing
676
677
#endif
\end{code}