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 # if __GLASGOW_HASKELL__ >= 503
95 import PrelIOBase -- this can be removed when SystemExts is used
97 import SystemExts ( rawSystem )
99 import CError ( throwErrnoIfMinus1 ) -- as can this
100 import System ( system )
104 #include "HsVersions.h"
106 -- Make catch work on older GHCs
107 #if __GLASGOW_HASKELL__ > 408
108 myCatch = Exception.catch
116 The configuration story
117 ~~~~~~~~~~~~~~~~~~~~~~~
119 GHC needs various support files (library packages, RTS etc), plus
120 various auxiliary programs (cp, gcc, etc). It finds these in one
123 * When running as an *installed program*, GHC finds most of this support
124 stuff in the installed library tree. The path to this tree is passed
125 to GHC via the -B flag, and given to initSysTools .
127 * When running *in-place* in a build tree, GHC finds most of this support
128 stuff in the build tree. The path to the build tree is, again passed
131 GHC tells which of the two is the case by seeing whether package.conf
132 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
135 SysTools.initSysProgs figures out exactly where all the auxiliary programs
136 are, and initialises mutable variables to make it easy to call them.
137 To to this, it makes use of definitions in Config.hs, which is a Haskell
138 file containing variables whose value is figured out by the build system.
140 Config.hs contains two sorts of things
142 cGCC, The *names* of the programs
145 etc They do *not* include paths
148 cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
149 cSPLIT_DIR_REL *relative* to the root of the build tree,
150 for use when running *in-place* in a build tree (only)
154 ---------------------------------------------
155 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
157 Another hair-brained scheme for simplifying the current tool location
158 nightmare in GHC: Simon originally suggested using another
159 configuration file along the lines of GCC's specs file - which is fine
160 except that it means adding code to read yet another configuration
161 file. What I didn't notice is that the current package.conf is
162 general enough to do this:
165 {name = "tools", import_dirs = [], source_dirs = [],
166 library_dirs = [], hs_libraries = [], extra_libraries = [],
167 include_dirs = [], c_includes = [], package_deps = [],
168 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${libdir}/bin/unlit", ... etc.],
169 extra_cc_opts = [], extra_ld_opts = []}
171 Which would have the advantage that we get to collect together in one
172 place the path-specific package stuff with the path-specific tool
175 ---------------------------------------------
178 %************************************************************************
180 \subsection{Global variables to contain system programs}
182 %************************************************************************
184 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
185 (See remarks under pathnames below)
188 GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit
189 GLOBAL_VAR(v_Pgm_P, error "pgm_P", String) -- cpp
190 GLOBAL_VAR(v_Pgm_F, error "pgm_F", String) -- pp
191 GLOBAL_VAR(v_Pgm_c, error "pgm_c", String) -- gcc
192 GLOBAL_VAR(v_Pgm_m, error "pgm_m", String) -- asm code mangler
193 GLOBAL_VAR(v_Pgm_s, error "pgm_s", String) -- asm code splitter
194 GLOBAL_VAR(v_Pgm_a, error "pgm_a", String) -- as
196 GLOBAL_VAR(v_Pgm_I, error "pgm_I", String) -- ilx2il
197 GLOBAL_VAR(v_Pgm_i, error "pgm_i", String) -- ilasm
199 GLOBAL_VAR(v_Pgm_l, error "pgm_l", String) -- ld
200 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String) -- mkdll
202 GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
203 GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
205 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
206 GLOBAL_VAR(v_Path_usage, error "ghc_usage.txt", String)
208 GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
210 -- Parallel system only
211 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
213 -- ways to get at some of these variables from outside this module
214 getPackageConfigPath = readIORef v_Path_package_config
215 getTopDir = readIORef v_TopDir
219 %************************************************************************
221 \subsection{Initialisation}
223 %************************************************************************
226 initSysTools :: [String] -- Command-line arguments starting "-B"
228 -> IO () -- Set all the mutable variables above, holding
229 -- (a) the system programs
230 -- (b) the package-config file
231 -- (c) the GHC usage message
234 initSysTools minusB_args
235 = do { (am_installed, top_dir) <- findTopDir minusB_args
236 ; writeIORef v_TopDir top_dir
238 -- for "installed" this is the root of GHC's support files
239 -- for "in-place" it is the root of the build tree
240 -- NB: top_dir is assumed to be in standard Unix format '/' separated
242 ; let installed, installed_bin :: FilePath -> FilePath
243 installed_bin pgm = pgmPath top_dir pgm
244 installed file = pgmPath top_dir file
245 inplace dir pgm = pgmPath (top_dir `slash`
246 cPROJECT_DIR `slash` dir) pgm
249 | am_installed = installed "package.conf"
250 | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
253 | am_installed = installed "ghc-usage.txt"
254 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
256 -- For all systems, unlit, split, mangle are GHC utilities
257 -- architecture-specific stuff is done when building Config.hs
259 | am_installed = installed_bin cGHC_UNLIT_PGM
260 | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
262 -- split and mangle are Perl scripts
264 | am_installed = installed_bin cGHC_SPLIT_PGM
265 | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
268 | am_installed = installed_bin cGHC_MANGLER_PGM
269 | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
271 #ifndef mingw32_TARGET_OS
272 -- check whether TMPDIR is set in the environment
273 ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
278 -- On Win32, consult GetTempPath() for a temp dir.
279 -- => it first tries TMP, TEMP, then finally the
280 -- Windows directory(!). The directory is in short-path
281 -- form and *does* have a trailing backslash.
283 let len = (2048::Int)
284 buf <- mallocArray len
285 ret <- getTempPath len buf
288 -- failed, consult TEMP.
289 destructArray len buf
293 destructArray len buf
296 -- strip the trailing backslash (awful, but
297 -- we only do this once).
307 -- Check that the package config exists
308 ; config_exists <- doesFileExist pkgconfig_path
309 ; when (not config_exists) $
310 throwDyn (InstallationError
311 ("Can't find package.conf as " ++ pkgconfig_path))
313 #if defined(mingw32_TARGET_OS)
314 -- WINDOWS-SPECIFIC STUFF
315 -- On Windows, gcc and friends are distributed with GHC,
316 -- so when "installed" we look in TopDir/bin
317 -- When "in-place" we look wherever the build-time configure
319 -- When "install" we tell gcc where its specs file + exes are (-B)
320 -- and also some places to pick up include files. We need
321 -- to be careful to put all necessary exes in the -B place
322 -- (as, ld, cc1, etc) since if they don't get found there, gcc
323 -- then tries to run unadorned "as", "ld", etc, and will
324 -- pick up whatever happens to be lying around in the path,
325 -- possibly including those from a cygwin install on the target,
326 -- which is exactly what we're trying to avoid.
327 ; let gcc_path | am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
329 -- The trailing "/" is absolutely essential; gcc seems
330 -- to construct file names simply by concatenating to this
331 -- -B path with no extra slash
332 -- We use "/" rather than "\\" because otherwise "\\\" is mangled
333 -- later on; although gcc_path is in NATIVE format, gcc can cope
334 -- (see comments with declarations of global variables)
336 -- The quotes round the -B argument are in case TopDir has spaces in it
338 perl_path | am_installed = installed_bin cGHC_PERL
339 | otherwise = cGHC_PERL
341 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
342 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM
343 | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
345 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
346 -- a call to Perl to get the invocation of split and mangle
347 ; let split_path = perl_path ++ " \"" ++ split_script ++ "\""
348 mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
350 ; let mkdll_path = cMKDLL
352 -- UNIX-SPECIFIC STUFF
353 -- On Unix, the "standard" tools are assumed to be
354 -- in the same place whether we are running "in-place" or "installed"
355 -- That place is wherever the build-time configure script found them.
356 ; let gcc_path = cGCC
358 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
360 -- On Unix, scripts are invoked using the '#!' method. Binary
361 -- installations of GHC on Unix place the correct line on the front
362 -- of the script at installation time, so we don't want to wire-in
363 -- our knowledge of $(PERL) on the host system here.
364 ; let split_path = split_script
365 mangle_path = mangle_script
368 -- cpp is derived from gcc on all platforms
369 ; let cpp_path = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
371 -- For all systems, copy and remove are provided by the host
372 -- system; architecture-specific stuff is done when building Config.hs
373 ; let cp_path = cGHC_CP
375 -- Other things being equal, as and ld are simply gcc
376 ; let as_path = gcc_path
380 -- ilx2il and ilasm are specified in Config.hs
381 ; let ilx2il_path = cILX2IL
385 -- Initialise the global vars
386 ; writeIORef v_Path_package_config pkgconfig_path
387 ; writeIORef v_Path_usage ghc_usage_msg_path
389 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
390 -- Hans: this isn't right in general, but you can
391 -- elaborate it in the same way as the others
393 ; writeIORef v_Pgm_L unlit_path
394 ; writeIORef v_Pgm_P cpp_path
395 ; writeIORef v_Pgm_F ""
396 ; writeIORef v_Pgm_c gcc_path
397 ; writeIORef v_Pgm_m mangle_path
398 ; writeIORef v_Pgm_s split_path
399 ; writeIORef v_Pgm_a as_path
401 ; writeIORef v_Pgm_I ilx2il_path
402 ; writeIORef v_Pgm_i ilasm_path
404 ; writeIORef v_Pgm_l ld_path
405 ; writeIORef v_Pgm_MkDLL mkdll_path
406 ; writeIORef v_Pgm_T touch_path
407 ; writeIORef v_Pgm_CP cp_path
412 #if defined(mingw32_TARGET_OS)
413 foreign import stdcall "GetTempPathA" unsafe getTempPath :: Int -> CString -> IO Int32
417 setPgm is called when a command-line option like
419 is used to override a particular program with a new one
422 setPgm :: String -> IO ()
423 -- The string is the flag, minus the '-pgm' prefix
424 -- So the first character says which program to override
426 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
427 setPgm ('F' : pgm) = writeIORef v_Pgm_F pgm
428 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
429 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
430 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
431 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
432 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
434 setPgm ('I' : pgm) = writeIORef v_Pgm_I pgm
435 setPgm ('i' : pgm) = writeIORef v_Pgm_i pgm
437 setPgm pgm = unknownFlagErr ("-pgm" ++ pgm)
443 -- for "installed" this is the root of GHC's support files
444 -- for "in-place" it is the root of the build tree
447 -- 1. Set proto_top_dir
448 -- a) look for (the last) -B flag, and use it
449 -- b) if there are no -B flags, get the directory
450 -- where GHC is running (only on Windows)
452 -- 2. If package.conf exists in proto_top_dir, we are running
453 -- installed; and TopDir = proto_top_dir
455 -- 3. Otherwise we are running in-place, so
456 -- proto_top_dir will be /...stuff.../ghc/compiler
457 -- Set TopDir to /...stuff..., which is the root of the build tree
459 -- This is very gruesome indeed
461 findTopDir :: [String]
462 -> IO (Bool, -- True <=> am installed, False <=> in-place
463 String) -- TopDir (in Unix format '/' separated)
466 = do { top_dir <- get_proto
467 -- Discover whether we're running in a build tree or in an installation,
468 -- by looking for the package configuration file.
469 ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
471 ; return (am_installed, top_dir)
474 -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
475 get_proto | not (null minusbs)
476 = return (unDosifyPath (drop 2 (last minusbs))) -- 2 for "-B"
478 = do { maybe_exec_dir <- getExecDir -- Get directory of executable
479 ; case maybe_exec_dir of -- (only works on Windows;
480 -- returns Nothing on Unix)
481 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
482 Just dir -> return dir
487 %************************************************************************
489 \subsection{Command-line options}
491 %************************************************************************
493 When invoking external tools as part of the compilation pipeline, we
494 pass these a sequence of options on the command-line. Rather than
495 just using a list of Strings, we use a type that allows us to distinguish
496 between filepaths and 'other stuff'. [The reason being, of course, that
497 this type gives us a handle on transforming filenames, and filenames only,
498 to whatever format they're expected to be on a particular platform.]
502 = FileOption -- an entry that _contains_ filename(s) / filepaths.
503 String -- a non-filepath prefix that shouldn't be transformed (e.g., "/out="
504 String -- the filepath/filename portion
507 showOptions :: [Option] -> String
508 showOptions ls = unwords (map (quote.showOpt) ls)
510 showOpt (FileOption pre f) = pre ++ dosifyPath f
511 showOpt (Option s) = s
513 #if defined(mingw32_TARGET_OS)
515 quote s = "\"" ++ s ++ "\""
523 %************************************************************************
525 \subsection{Running an external program}
527 %************************************************************************
531 runUnlit :: [Option] -> IO ()
532 runUnlit args = do p <- readIORef v_Pgm_L
533 runSomething "Literate pre-processor" p args
535 runCpp :: [Option] -> IO ()
536 runCpp args = do p <- readIORef v_Pgm_P
537 runSomething "C pre-processor" p args
539 runPp :: [Option] -> IO ()
540 runPp args = do p <- readIORef v_Pgm_F
541 runSomething "Haskell pre-processor" p args
543 runCc :: [Option] -> IO ()
544 runCc args = do p <- readIORef v_Pgm_c
545 runSomething "C Compiler" p args
547 runMangle :: [Option] -> IO ()
548 runMangle args = do p <- readIORef v_Pgm_m
549 runSomething "Mangler" p args
551 runSplit :: [Option] -> IO ()
552 runSplit args = do p <- readIORef v_Pgm_s
553 runSomething "Splitter" p args
555 runAs :: [Option] -> IO ()
556 runAs args = do p <- readIORef v_Pgm_a
557 runSomething "Assembler" p args
559 runLink :: [Option] -> IO ()
560 runLink args = do p <- readIORef v_Pgm_l
561 runSomething "Linker" p args
564 runIlx2il :: [Option] -> IO ()
565 runIlx2il args = do p <- readIORef v_Pgm_I
566 runSomething "Ilx2Il" p args
568 runIlasm :: [Option] -> IO ()
569 runIlasm args = do p <- readIORef v_Pgm_i
570 runSomething "Ilasm" p args
573 runMkDLL :: [Option] -> IO ()
574 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
575 runSomething "Make DLL" p args
577 touch :: String -> String -> IO ()
578 touch purpose arg = do p <- readIORef v_Pgm_T
579 runSomething purpose p [FileOption "" arg]
581 copy :: String -> String -> String -> IO ()
582 copy purpose from to = do
583 verb <- dynFlag verbosity
584 when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
586 h <- openFile to WriteMode
587 ls <- readFile from -- inefficient, but it'll do for now.
588 -- ToDo: speed up via slurping.
594 getSysMan :: IO String -- How to invoke the system manager
595 -- (parallel system only)
596 getSysMan = readIORef v_Pgm_sysman
599 %************************************************************************
601 \subsection{GHC Usage message}
603 %************************************************************************
605 Show the usage message and exit
608 showGhcUsage = do { usage_path <- readIORef v_Path_usage
609 ; usage <- readFile usage_path
611 ; exitWith ExitSuccess }
614 dump ('$':'$':s) = hPutStr stderr progName >> dump s
615 dump (c:s) = hPutChar stderr c >> dump s
619 %************************************************************************
621 \subsection{Managing temporary files
623 %************************************************************************
626 GLOBAL_VAR(v_FilesToClean, [], [String] )
627 GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
628 -- v_TmpDir has no closing '/'
632 setTmpDir dir = writeIORef v_TmpDir dir
634 cleanTempFiles :: Int -> IO ()
635 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
636 removeTmpFiles verb fs
638 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
639 cleanTempFilesExcept verb dont_delete
640 = do fs <- readIORef v_FilesToClean
641 let leftovers = filter (`notElem` dont_delete) fs
642 removeTmpFiles verb leftovers
643 writeIORef v_FilesToClean dont_delete
646 -- find a temporary name that doesn't already exist.
647 newTempName :: Suffix -> IO FilePath
649 = do x <- getProcessID
650 tmp_dir <- readIORef v_TmpDir
651 findTempName tmp_dir x
653 findTempName tmp_dir x
654 = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
655 b <- doesFileExist filename
656 if b then findTempName tmp_dir (x+1)
657 else do add v_FilesToClean filename -- clean it up later
660 addFilesToClean :: [FilePath] -> IO ()
661 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
662 addFilesToClean files = mapM_ (add v_FilesToClean) files
664 removeTmpFiles :: Int -> [FilePath] -> IO ()
665 removeTmpFiles verb fs
666 = traceCmd "Deleting temp files"
667 ("Deleting: " ++ unwords fs)
670 rm f = removeFile f `myCatch`
673 hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
679 %************************************************************************
681 \subsection{Running a program}
683 %************************************************************************
686 GLOBAL_VAR(v_Dry_run, False, Bool)
689 setDryRun = writeIORef v_Dry_run True
691 -----------------------------------------------------------------------------
692 -- Running an external program
694 runSomething :: String -- For -v message
695 -> String -- Command name (possibly a full path)
696 -- assumed already dos-ified
697 -> [Option] -- Arguments
698 -- runSomething will dos-ify them
701 runSomething phase_name pgm args
702 = traceCmd phase_name cmd_line $
704 #ifndef mingw32_TARGET_OS
705 exit_code <- system cmd_line
707 exit_code <- rawSystem cmd_line
709 ; if exit_code /= ExitSuccess
710 then throwDyn (PhaseFailed phase_name exit_code)
714 cmd_line = pgm ++ ' ':showOptions args -- unwords (pgm : dosifyPaths (map quote args))
715 -- The pgm is already in native format (appropriate dir separators)
716 #if defined(mingw32_TARGET_OS)
718 quote s = "\"" ++ s ++ "\""
723 traceCmd :: String -> String -> IO () -> IO ()
724 -- a) trace the command (at two levels of verbosity)
725 -- b) don't do it at all if dry-run is set
726 traceCmd phase_name cmd_line action
727 = do { verb <- dynFlag verbosity
728 ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
729 ; when (verb >= 3) $ hPutStrLn stderr cmd_line
733 ; n <- readIORef v_Dry_run
737 ; action `myCatch` handle_exn verb
740 handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
741 ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
742 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
746 %************************************************************************
748 \subsection{Path names}
750 %************************************************************************
752 We maintain path names in Unix form ('/'-separated) right until
753 the last moment. On Windows we dos-ify them just before passing them
754 to the Windows command.
756 The alternative, of using '/' consistently on Unix and '\' on Windows,
757 proved quite awkward. There were a lot more calls to dosifyPath,
758 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
759 interpreted a command line 'foo\baz' as 'foobaz'.
762 -----------------------------------------------------------------------------
763 -- Convert filepath into MSDOS form.
765 dosifyPaths :: [String] -> [String]
766 -- dosifyPaths does two things
767 -- a) change '/' to '\'
768 -- b) remove initial '/cygdrive/'
770 unDosifyPath :: String -> String
771 -- Just change '\' to '/'
773 pgmPath :: String -- Directory string in Unix format
774 -> String -- Program name with no directory separators
776 -> String -- Program invocation string in native format
780 #if defined(mingw32_TARGET_OS)
782 --------------------- Windows version ------------------
783 dosifyPaths xs = map dosifyPath xs
785 unDosifyPath xs = subst '\\' '/' xs
787 pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm
790 = subst '/' '\\' real_stuff
792 -- fully convince myself that /cygdrive/ prefixes cannot
793 -- really appear here.
794 cygdrive_prefix = "/cygdrive/"
797 | cygdrive_prefix `isPrefixOf` stuff = dropList cygdrive_prefix stuff
802 --------------------- Unix version ---------------------
805 pgmPath dir pgm = dir ++ '/' : pgm
806 dosifyPath stuff = stuff
807 --------------------------------------------------------
810 subst a b ls = map (\ x -> if x == a then b else x) ls
814 -----------------------------------------------------------------------------
815 Path name construction
818 slash :: String -> String -> String
819 absPath, relPath :: [String] -> String
822 relPath xs = foldr1 slash xs
824 absPath xs = "" `slash` relPath xs
826 slash s1 s2 = s1 ++ ('/' : s2)
830 %************************************************************************
832 \subsection{Support code}
834 %************************************************************************
837 -----------------------------------------------------------------------------
838 -- Define getExecDir :: IO (Maybe String)
840 #if defined(mingw32_TARGET_OS)
841 getExecDir :: IO (Maybe String)
842 getExecDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
843 buf <- mallocArray len
844 ret <- getModuleFileName nullAddr buf len
845 if ret == 0 then destructArray len buf >> return Nothing
846 else do s <- peekCString buf
847 destructArray len buf
848 return (Just (reverse (dropList "/bin/ghc.exe" (reverse (unDosifyPath s)))))
851 foreign import stdcall "GetModuleFileNameA" unsafe getModuleFileName :: Addr -> CString -> Int -> IO Int32
853 getExecDir :: IO (Maybe String) = do return Nothing
856 #ifdef mingw32_TARGET_OS
857 foreign import "_getpid" unsafe getProcessID :: IO Int -- relies on Int == Int32 on Windows
859 getProcessID :: IO Int
860 getProcessID = Posix.getProcessID
863 #if defined(mingw32_TARGET_OS) && (__GLASGOW_HASKELL__ <= 408)
864 rawSystem :: String -> IO ExitCode
865 rawSystem "" = ioException (IOError Nothing InvalidArgument "rawSystem" "null command" Nothing)
867 withCString cmd $ \s -> do
868 status <- throwErrnoIfMinus1 "rawSystem" (primRawSystem s)
870 0 -> return ExitSuccess
871 n -> return (ExitFailure n)
873 foreign import ccall "rawSystemCmd" unsafe primRawSystem :: CString -> IO Int