1 -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 2001
5 -- Access to system tools: gcc, cp, rm etc
7 -----------------------------------------------------------------------------
13 setPgm, -- String -> IO ()
14 -- Command-line override
17 getTopDir, -- IO String -- The value of $libdir
18 getPackageConfigPath, -- IO String -- Where package.conf is
20 -- Interface to system tools
21 runUnlit, runCpp, runCc, -- [Option] -> IO ()
22 runPp, -- [Option] -> IO ()
23 runMangle, runSplit, -- [Option] -> IO ()
24 runAs, runLink, -- [Option] -> IO ()
27 runIlx2il, runIlasm, -- [String] -> IO ()
31 touch, -- String -> String -> IO ()
32 copy, -- String -> String -> String -> IO ()
33 unDosifyPath, -- String -> String
35 -- Temporary-file management
38 cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
42 getProcessID, -- IO Int
43 system, -- String -> IO ExitCode
46 showGhcUsage, -- IO () Shows usage message and exits
47 getSysMan, -- IO String Parallel system only
56 import Panic ( progName, GhcException(..) )
57 import Util ( global, dropList )
58 import CmdLineOpts ( dynFlag, verbosity )
60 import Exception ( throwDyn )
61 #if __GLASGOW_HASKELL__ > 408
62 import qualified Exception ( catch )
64 import Exception ( catchAllIO )
67 import Directory ( doesFileExist, removeFile )
68 import IOExts ( IORef, readIORef, writeIORef )
69 import Monad ( when, unless )
70 import System ( ExitCode(..), exitWith, getEnv, system )
75 #include "../includes/config.h"
77 #ifndef mingw32_TARGET_OS
78 import qualified Posix
80 import List ( isPrefixOf )
84 -- This is a kludge for bootstrapping with 4.08.X. Given that
85 -- all distributed compilers >= 5.0 will be compiled with themselves.
86 -- I don't think this kludge is a problem. And we have to start
87 -- building with >= 5.0 on Win32 anyway.
88 #if __GLASGOW_HASKELL__ > 408
89 -- use the line below when we can be sure of compiling with GHC >=
90 -- 5.02, and remove the implementation of rawSystem at the end of this
92 import PrelIOBase -- this can be removed when SystemExts is used
93 import CError ( throwErrnoIfMinus1 ) -- as can this
94 -- import SystemExts ( rawSystem )
96 import System ( system )
100 #include "HsVersions.h"
102 -- Make catch work on older GHCs
103 #if __GLASGOW_HASKELL__ > 408
104 myCatch = Exception.catch
112 The configuration story
113 ~~~~~~~~~~~~~~~~~~~~~~~
115 GHC needs various support files (library packages, RTS etc), plus
116 various auxiliary programs (cp, gcc, etc). It finds these in one
119 * When running as an *installed program*, GHC finds most of this support
120 stuff in the installed library tree. The path to this tree is passed
121 to GHC via the -B flag, and given to initSysTools .
123 * When running *in-place* in a build tree, GHC finds most of this support
124 stuff in the build tree. The path to the build tree is, again passed
127 GHC tells which of the two is the case by seeing whether package.conf
128 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
131 SysTools.initSysProgs figures out exactly where all the auxiliary programs
132 are, and initialises mutable variables to make it easy to call them.
133 To to this, it makes use of definitions in Config.hs, which is a Haskell
134 file containing variables whose value is figured out by the build system.
136 Config.hs contains two sorts of things
138 cGCC, The *names* of the programs
141 etc They do *not* include paths
144 cUNLIT_DIR The *path* to the directory containing unlit, split etc
145 cSPLIT_DIR *relative* to the root of the build tree,
146 for use when running *in-place* in a build tree (only)
150 ---------------------------------------------
151 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
153 Another hair-brained scheme for simplifying the current tool location
154 nightmare in GHC: Simon originally suggested using another
155 configuration file along the lines of GCC's specs file - which is fine
156 except that it means adding code to read yet another configuration
157 file. What I didn't notice is that the current package.conf is
158 general enough to do this:
161 {name = "tools", import_dirs = [], source_dirs = [],
162 library_dirs = [], hs_libraries = [], extra_libraries = [],
163 include_dirs = [], c_includes = [], package_deps = [],
164 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${libdir}/bin/unlit", ... etc.],
165 extra_cc_opts = [], extra_ld_opts = []}
167 Which would have the advantage that we get to collect together in one
168 place the path-specific package stuff with the path-specific tool
171 ---------------------------------------------
174 %************************************************************************
176 \subsection{Global variables to contain system programs}
178 %************************************************************************
180 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
181 (See remarks under pathnames below)
184 GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit
185 GLOBAL_VAR(v_Pgm_P, error "pgm_P", String) -- cpp
186 GLOBAL_VAR(v_Pgm_F, error "pgm_F", String) -- pp
187 GLOBAL_VAR(v_Pgm_c, error "pgm_c", String) -- gcc
188 GLOBAL_VAR(v_Pgm_m, error "pgm_m", String) -- asm code mangler
189 GLOBAL_VAR(v_Pgm_s, error "pgm_s", String) -- asm code splitter
190 GLOBAL_VAR(v_Pgm_a, error "pgm_a", String) -- as
192 GLOBAL_VAR(v_Pgm_I, error "pgm_I", String) -- ilx2il
193 GLOBAL_VAR(v_Pgm_i, error "pgm_i", String) -- ilasm
195 GLOBAL_VAR(v_Pgm_l, error "pgm_l", String) -- ld
196 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String) -- mkdll
198 GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
199 GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
201 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
202 GLOBAL_VAR(v_Path_usage, error "ghc_usage.txt", String)
204 GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
206 -- Parallel system only
207 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
209 -- ways to get at some of these variables from outside this module
210 getPackageConfigPath = readIORef v_Path_package_config
211 getTopDir = readIORef v_TopDir
215 %************************************************************************
217 \subsection{Initialisation}
219 %************************************************************************
222 initSysTools :: [String] -- Command-line arguments starting "-B"
224 -> IO () -- Set all the mutable variables above, holding
225 -- (a) the system programs
226 -- (b) the package-config file
227 -- (c) the GHC usage message
230 initSysTools minusB_args
231 = do { (am_installed, top_dir) <- findTopDir minusB_args
232 ; writeIORef v_TopDir top_dir
234 -- for "installed" this is the root of GHC's support files
235 -- for "in-place" it is the root of the build tree
236 -- NB: top_dir is assumed to be in standard Unix format '/' separated
238 ; let installed, installed_bin :: FilePath -> FilePath
239 installed_bin pgm = pgmPath top_dir pgm
240 installed file = pgmPath top_dir file
241 inplace dir pgm = pgmPath (top_dir `slash` dir) pgm
244 | am_installed = installed "package.conf"
245 | otherwise = inplace cGHC_DRIVER_DIR "package.conf.inplace"
248 | am_installed = installed "ghc-usage.txt"
249 | otherwise = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
251 -- For all systems, unlit, split, mangle are GHC utilities
252 -- architecture-specific stuff is done when building Config.hs
254 | am_installed = installed_bin cGHC_UNLIT
255 | otherwise = inplace cGHC_UNLIT_DIR cGHC_UNLIT
257 -- split and mangle are Perl scripts
259 | am_installed = installed_bin cGHC_SPLIT
260 | otherwise = inplace cGHC_SPLIT_DIR cGHC_SPLIT
263 | am_installed = installed_bin cGHC_MANGLER
264 | otherwise = inplace cGHC_MANGLER_DIR cGHC_MANGLER
266 #ifndef mingw32_TARGET_OS
267 -- check whether TMPDIR is set in the environment
268 ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
273 -- On Win32, consult GetTempPath() for a temp dir.
274 -- => it first tries TMP, TEMP, then finally the
275 -- Windows directory(!). The directory is in short-path
276 -- form and *does* have a trailing backslash.
278 let len = (2048::Int)
279 buf <- mallocArray len
280 ret <- getTempPath len buf
283 -- failed, consult TEMP.
284 destructArray len buf
288 destructArray len buf
291 -- strip the trailing backslash (awful, but
292 -- we only do this once).
302 -- Check that the package config exists
303 ; config_exists <- doesFileExist pkgconfig_path
304 ; when (not config_exists) $
305 throwDyn (InstallationError
306 ("Can't find package.conf as " ++ pkgconfig_path))
308 #if defined(mingw32_TARGET_OS)
309 -- WINDOWS-SPECIFIC STUFF
310 -- On Windows, gcc and friends are distributed with GHC,
311 -- so when "installed" we look in TopDir/bin
312 -- When "in-place" we look wherever the build-time configure
314 -- When "install" we tell gcc where its specs file + exes are (-B)
315 -- and also some places to pick up include files. We need
316 -- to be careful to put all necessary exes in the -B place
317 -- (as, ld, cc1, etc) since if they don't get found there, gcc
318 -- then tries to run unadorned "as", "ld", etc, and will
319 -- pick up whatever happens to be lying around in the path,
320 -- possibly including those from a cygwin install on the target,
321 -- which is exactly what we're trying to avoid.
322 ; let gcc_path | am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
324 -- The trailing "/" is absolutely essential; gcc seems
325 -- to construct file names simply by concatenating to this
326 -- -B path with no extra slash
327 -- We use "/" rather than "\\" because otherwise "\\\" is mangled
328 -- later on; although gcc_path is in NATIVE format, gcc can cope
329 -- (see comments with declarations of global variables)
331 -- The quotes round the -B argument are in case TopDir has spaces in it
333 perl_path | am_installed = installed_bin cGHC_PERL
334 | otherwise = cGHC_PERL
336 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
337 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY
338 | otherwise = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
340 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
341 -- a call to Perl to get the invocation of split and mangle
342 ; let split_path = perl_path ++ " \"" ++ split_script ++ "\""
343 mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
345 ; let mkdll_path = cMKDLL
347 -- UNIX-SPECIFIC STUFF
348 -- On Unix, the "standard" tools are assumed to be
349 -- in the same place whether we are running "in-place" or "installed"
350 -- That place is wherever the build-time configure script found them.
351 ; let gcc_path = cGCC
352 touch_path = cGHC_TOUCHY
353 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
355 -- On Unix, scripts are invoked using the '#!' method. Binary
356 -- installations of GHC on Unix place the correct line on the front
357 -- of the script at installation time, so we don't want to wire-in
358 -- our knowledge of $(PERL) on the host system here.
359 ; let split_path = split_script
360 mangle_path = mangle_script
363 -- cpp is derived from gcc on all platforms
364 ; let cpp_path = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
366 -- For all systems, copy and remove are provided by the host
367 -- system; architecture-specific stuff is done when building Config.hs
368 ; let cp_path = cGHC_CP
370 -- Other things being equal, as and ld are simply gcc
371 ; let as_path = gcc_path
375 -- ilx2il and ilasm are specified in Config.hs
376 ; let ilx2il_path = cILX2IL
380 -- Initialise the global vars
381 ; writeIORef v_Path_package_config pkgconfig_path
382 ; writeIORef v_Path_usage ghc_usage_msg_path
384 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
385 -- Hans: this isn't right in general, but you can
386 -- elaborate it in the same way as the others
388 ; writeIORef v_Pgm_L unlit_path
389 ; writeIORef v_Pgm_P cpp_path
390 ; writeIORef v_Pgm_F ""
391 ; writeIORef v_Pgm_c gcc_path
392 ; writeIORef v_Pgm_m mangle_path
393 ; writeIORef v_Pgm_s split_path
394 ; writeIORef v_Pgm_a as_path
396 ; writeIORef v_Pgm_I ilx2il_path
397 ; writeIORef v_Pgm_i ilasm_path
399 ; writeIORef v_Pgm_l ld_path
400 ; writeIORef v_Pgm_MkDLL mkdll_path
401 ; writeIORef v_Pgm_T touch_path
402 ; writeIORef v_Pgm_CP cp_path
407 #if defined(mingw32_TARGET_OS)
408 foreign import stdcall "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
412 setPgm is called when a command-line option like
414 is used to override a particular program with a new one
417 setPgm :: String -> IO ()
418 -- The string is the flag, minus the '-pgm' prefix
419 -- So the first character says which program to override
421 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
422 setPgm ('F' : pgm) = writeIORef v_Pgm_F pgm
423 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
424 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
425 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
426 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
427 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
429 setPgm ('I' : pgm) = writeIORef v_Pgm_I pgm
430 setPgm ('i' : pgm) = writeIORef v_Pgm_i pgm
432 setPgm pgm = unknownFlagErr ("-pgm" ++ pgm)
438 -- for "installed" this is the root of GHC's support files
439 -- for "in-place" it is the root of the build tree
442 -- 1. Set proto_top_dir
443 -- a) look for (the last) -B flag, and use it
444 -- b) if there are no -B flags, get the directory
445 -- where GHC is running (only on Windows)
447 -- 2. If package.conf exists in proto_top_dir, we are running
448 -- installed; and TopDir = proto_top_dir
450 -- 3. Otherwise we are running in-place, so
451 -- proto_top_dir will be /...stuff.../ghc/compiler
452 -- Set TopDir to /...stuff..., which is the root of the build tree
454 -- This is very gruesome indeed
456 findTopDir :: [String]
457 -> IO (Bool, -- True <=> am installed, False <=> in-place
458 String) -- TopDir (in Unix format '/' separated)
461 = do { top_dir <- get_proto
462 -- Discover whether we're running in a build tree or in an installation,
463 -- by looking for the package configuration file.
464 ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
466 ; return (am_installed, top_dir)
469 -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
470 get_proto | not (null minusbs)
471 = return (unDosifyPath (drop 2 (last minusbs))) -- 2 for "-B"
473 = do { maybe_exec_dir <- getExecDir -- Get directory of executable
474 ; case maybe_exec_dir of -- (only works on Windows;
475 -- returns Nothing on Unix)
476 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
477 Just dir -> return dir
482 %************************************************************************
484 \subsection{Command-line options}
486 %************************************************************************
488 When invoking external tools as part of the compilation pipeline, we
489 pass these a sequence of options on the command-line. Rather than
490 just using a list of Strings, we use a type that allows us to distinguish
491 between filepaths and 'other stuff'. [The reason being, of course, that
492 this type gives us a handle on transforming filenames, and filenames only,
493 to whatever format they're expected to be on a particular platform.]
497 = FileOption -- an entry that _contains_ filename(s) / filepaths.
498 String -- a non-filepath prefix that shouldn't be transformed (e.g., "/out="
499 String -- the filepath/filename portion
502 showOptions :: [Option] -> String
503 showOptions ls = unwords (map (quote.showOpt) ls)
505 showOpt (FileOption pre f) = pre ++ dosifyPath f
506 showOpt (Option s) = s
508 #if defined(mingw32_TARGET_OS)
510 quote s = "\"" ++ s ++ "\""
518 %************************************************************************
520 \subsection{Running an external program}
522 %************************************************************************
526 runUnlit :: [Option] -> IO ()
527 runUnlit args = do p <- readIORef v_Pgm_L
528 runSomething "Literate pre-processor" p args
530 runCpp :: [Option] -> IO ()
531 runCpp args = do p <- readIORef v_Pgm_P
532 runSomething "C pre-processor" p args
534 runPp :: [Option] -> IO ()
535 runPp args = do p <- readIORef v_Pgm_F
536 runSomething "Haskell pre-processor" p args
538 runCc :: [Option] -> IO ()
539 runCc args = do p <- readIORef v_Pgm_c
540 runSomething "C Compiler" p args
542 runMangle :: [Option] -> IO ()
543 runMangle args = do p <- readIORef v_Pgm_m
544 runSomething "Mangler" p args
546 runSplit :: [Option] -> IO ()
547 runSplit args = do p <- readIORef v_Pgm_s
548 runSomething "Splitter" p args
550 runAs :: [Option] -> IO ()
551 runAs args = do p <- readIORef v_Pgm_a
552 runSomething "Assembler" p args
554 runLink :: [Option] -> IO ()
555 runLink args = do p <- readIORef v_Pgm_l
556 runSomething "Linker" p args
559 runIlx2il :: [Option] -> IO ()
560 runIlx2il args = do p <- readIORef v_Pgm_I
561 runSomething "Ilx2Il" p args
563 runIlasm :: [Option] -> IO ()
564 runIlasm args = do p <- readIORef v_Pgm_i
565 runSomething "Ilasm" p args
568 runMkDLL :: [Option] -> IO ()
569 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
570 runSomething "Make DLL" p args
572 touch :: String -> String -> IO ()
573 touch purpose arg = do p <- readIORef v_Pgm_T
574 runSomething purpose p [FileOption "" arg]
576 copy :: String -> String -> String -> IO ()
577 copy purpose from to = do
578 verb <- dynFlag verbosity
579 when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
581 h <- openFile to WriteMode
582 ls <- readFile from -- inefficient, but it'll do for now.
583 -- ToDo: speed up via slurping.
589 getSysMan :: IO String -- How to invoke the system manager
590 -- (parallel system only)
591 getSysMan = readIORef v_Pgm_sysman
594 %************************************************************************
596 \subsection{GHC Usage message}
598 %************************************************************************
600 Show the usage message and exit
603 showGhcUsage = do { usage_path <- readIORef v_Path_usage
604 ; usage <- readFile usage_path
606 ; exitWith ExitSuccess }
609 dump ('$':'$':s) = hPutStr stderr progName >> dump s
610 dump (c:s) = hPutChar stderr c >> dump s
614 %************************************************************************
616 \subsection{Managing temporary files
618 %************************************************************************
621 GLOBAL_VAR(v_FilesToClean, [], [String] )
622 GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
623 -- v_TmpDir has no closing '/'
627 setTmpDir dir = writeIORef v_TmpDir dir
629 cleanTempFiles :: Int -> IO ()
630 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
631 removeTmpFiles verb fs
633 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
634 cleanTempFilesExcept verb dont_delete
635 = do fs <- readIORef v_FilesToClean
636 let leftovers = filter (`notElem` dont_delete) fs
637 removeTmpFiles verb leftovers
638 writeIORef v_FilesToClean dont_delete
641 -- find a temporary name that doesn't already exist.
642 newTempName :: Suffix -> IO FilePath
644 = do x <- getProcessID
645 tmp_dir <- readIORef v_TmpDir
646 findTempName tmp_dir x
648 findTempName tmp_dir x
649 = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
650 b <- doesFileExist filename
651 if b then findTempName tmp_dir (x+1)
652 else do add v_FilesToClean filename -- clean it up later
655 addFilesToClean :: [FilePath] -> IO ()
656 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
657 addFilesToClean files = mapM_ (add v_FilesToClean) files
659 removeTmpFiles :: Int -> [FilePath] -> IO ()
660 removeTmpFiles verb fs
661 = traceCmd "Deleting temp files"
662 ("Deleting: " ++ unwords fs)
665 rm f = removeFile f `myCatch`
668 hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
674 %************************************************************************
676 \subsection{Running a program}
678 %************************************************************************
681 GLOBAL_VAR(v_Dry_run, False, Bool)
684 setDryRun = writeIORef v_Dry_run True
686 -----------------------------------------------------------------------------
687 -- Running an external program
689 runSomething :: String -- For -v message
690 -> String -- Command name (possibly a full path)
691 -- assumed already dos-ified
692 -> [Option] -- Arguments
693 -- runSomething will dos-ify them
696 runSomething phase_name pgm args
697 = traceCmd phase_name cmd_line $
699 #ifndef mingw32_TARGET_OS
700 exit_code <- system cmd_line
702 exit_code <- rawSystem cmd_line
704 ; if exit_code /= ExitSuccess
705 then throwDyn (PhaseFailed phase_name exit_code)
709 cmd_line = pgm ++ ' ':showOptions args -- unwords (pgm : dosifyPaths (map quote args))
710 -- The pgm is already in native format (appropriate dir separators)
711 #if defined(mingw32_TARGET_OS)
713 quote s = "\"" ++ s ++ "\""
718 traceCmd :: String -> String -> IO () -> IO ()
719 -- a) trace the command (at two levels of verbosity)
720 -- b) don't do it at all if dry-run is set
721 traceCmd phase_name cmd_line action
722 = do { verb <- dynFlag verbosity
723 ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
724 ; when (verb >= 3) $ hPutStrLn stderr cmd_line
728 ; n <- readIORef v_Dry_run
732 ; action `myCatch` handle_exn verb
735 handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
736 ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
737 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
741 %************************************************************************
743 \subsection{Path names}
745 %************************************************************************
747 We maintain path names in Unix form ('/'-separated) right until
748 the last moment. On Windows we dos-ify them just before passing them
749 to the Windows command.
751 The alternative, of using '/' consistently on Unix and '\' on Windows,
752 proved quite awkward. There were a lot more calls to dosifyPath,
753 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
754 interpreted a command line 'foo\baz' as 'foobaz'.
757 -----------------------------------------------------------------------------
758 -- Convert filepath into MSDOS form.
760 dosifyPaths :: [String] -> [String]
761 -- dosifyPaths does two things
762 -- a) change '/' to '\'
763 -- b) remove initial '/cygdrive/'
765 unDosifyPath :: String -> String
766 -- Just change '\' to '/'
768 pgmPath :: String -- Directory string in Unix format
769 -> String -- Program name with no directory separators
771 -> String -- Program invocation string in native format
775 #if defined(mingw32_TARGET_OS)
777 --------------------- Windows version ------------------
778 dosifyPaths xs = map dosifyPath xs
780 unDosifyPath xs = subst '\\' '/' xs
782 pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm
785 = subst '/' '\\' real_stuff
787 -- fully convince myself that /cygdrive/ prefixes cannot
788 -- really appear here.
789 cygdrive_prefix = "/cygdrive/"
792 | cygdrive_prefix `isPrefixOf` stuff = dropList cygdrive_prefix stuff
797 --------------------- Unix version ---------------------
800 pgmPath dir pgm = dir ++ '/' : pgm
801 dosifyPath stuff = stuff
802 --------------------------------------------------------
805 subst a b ls = map (\ x -> if x == a then b else x) ls
809 -----------------------------------------------------------------------------
810 Path name construction
813 slash :: String -> String -> String
814 absPath, relPath :: [String] -> String
817 relPath xs = foldr1 slash xs
819 absPath xs = "" `slash` relPath xs
821 slash s1 s2 = s1 ++ ('/' : s2)
825 %************************************************************************
827 \subsection{Support code}
829 %************************************************************************
832 -----------------------------------------------------------------------------
833 -- Define getExecDir :: IO (Maybe String)
835 #if defined(mingw32_TARGET_OS)
836 getExecDir :: IO (Maybe String)
837 getExecDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
838 buf <- mallocArray len
839 ret <- getModuleFileName nullAddr buf len
840 if ret == 0 then destructArray len buf >> return Nothing
841 else do s <- peekCString buf
842 destructArray len buf
843 return (Just (reverse (dropList "/bin/ghc.exe" (reverse (unDosifyPath s)))))
846 foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int -> IO Int32
848 getExecDir :: IO (Maybe String) = do return Nothing
851 #ifdef mingw32_TARGET_OS
852 foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
854 getProcessID :: IO Int
855 getProcessID = Posix.getProcessID
858 rawSystem :: String -> IO ExitCode
859 #if __GLASGOW_HASKELL__ > 408
860 rawSystem "" = ioException (IOError Nothing InvalidArgument "rawSystem" "null command" Nothing)
862 withCString cmd $ \s -> do
863 status <- throwErrnoIfMinus1 "rawSystem" (primRawSystem s)
865 0 -> return ExitSuccess
866 n -> return (ExitFailure n)
868 foreign import ccall "rawSystemCmd" unsafe primRawSystem :: CString -> IO Int
870 rawSystem = System.system