1 -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 2001
5 -- Access to system tools: gcc, cp, rm etc
7 -----------------------------------------------------------------------------
14 setPgmP, -- String -> IO ()
25 -- Command-line override
28 getTopDir, -- IO String -- The value of $libdir
29 getPackageConfigPath, -- IO String -- Where package.conf is
31 -- Interface to system tools
32 runUnlit, runCpp, runCc, -- [Option] -> IO ()
33 runPp, -- [Option] -> IO ()
34 runMangle, runSplit, -- [Option] -> IO ()
35 runAs, runLink, -- [Option] -> IO ()
38 runIlx2il, runIlasm, -- [String] -> IO ()
42 touch, -- String -> String -> IO ()
43 copy, -- String -> String -> String -> IO ()
44 unDosifyPath, -- String -> String
46 -- Temporary-file management
49 cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
53 getProcessID, -- IO Int
54 system, -- String -> IO ExitCode
57 showGhcUsage, -- IO () Shows usage message and exits
58 getSysMan, -- IO String Parallel system only
64 #include "HsVersions.h"
69 import Panic ( progName, GhcException(..) )
70 import Util ( global, notNull )
71 import CmdLineOpts ( dynFlag, verbosity )
73 import EXCEPTION ( throwDyn )
74 import DATA_IOREF ( IORef, readIORef, writeIORef )
77 import Monad ( when, unless )
78 import System ( ExitCode(..), exitWith, getEnv, system )
79 import IO ( try, catch,
80 openFile, hPutChar, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
82 import Directory ( doesFileExist, removeFile )
84 #include "../includes/config.h"
86 -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
87 -- lines on mingw32, so we disallow it now.
88 #if defined(mingw32_HOST_OS) && (__GLASGOW_HASKELL__ <= 408)
89 #error GHC <= 4.08 is not supported for bootstrapping GHC on i386-unknown-mingw32
92 #ifndef mingw32_HOST_OS
93 #if __GLASGOW_HASKELL__ > 504
94 import qualified GHC.Posix
96 import qualified Posix
98 #else /* Must be Win32 */
99 import List ( isPrefixOf )
100 import Util ( dropList )
102 import CString ( CString, peekCString )
105 #ifdef mingw32_HOST_OS
106 #if __GLASGOW_HASKELL__ > 504
107 import System.Cmd ( rawSystem )
110 -- For Win32 and GHC <= 504
111 -- rawSystem is defined in this module
112 -- We just need an import
113 #if __GLASGOW_HASKELL__ < 503
114 import PrelIOBase( ioException, IOException(..), IOErrorType(InvalidArgument) )
116 import GHC.IOBase( ioException, IOException(..), IOErrorType(InvalidArgument) )
118 import CError ( throwErrnoIfMinus1 )
119 import CString ( withCString )
122 #else /* Not Win32 */
124 import System ( system )
129 The configuration story
130 ~~~~~~~~~~~~~~~~~~~~~~~
132 GHC needs various support files (library packages, RTS etc), plus
133 various auxiliary programs (cp, gcc, etc). It finds these in one
136 * When running as an *installed program*, GHC finds most of this support
137 stuff in the installed library tree. The path to this tree is passed
138 to GHC via the -B flag, and given to initSysTools .
140 * When running *in-place* in a build tree, GHC finds most of this support
141 stuff in the build tree. The path to the build tree is, again passed
144 GHC tells which of the two is the case by seeing whether package.conf
145 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
148 SysTools.initSysProgs figures out exactly where all the auxiliary programs
149 are, and initialises mutable variables to make it easy to call them.
150 To to this, it makes use of definitions in Config.hs, which is a Haskell
151 file containing variables whose value is figured out by the build system.
153 Config.hs contains two sorts of things
155 cGCC, The *names* of the programs
158 etc They do *not* include paths
161 cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
162 cSPLIT_DIR_REL *relative* to the root of the build tree,
163 for use when running *in-place* in a build tree (only)
167 ---------------------------------------------
168 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
170 Another hair-brained scheme for simplifying the current tool location
171 nightmare in GHC: Simon originally suggested using another
172 configuration file along the lines of GCC's specs file - which is fine
173 except that it means adding code to read yet another configuration
174 file. What I didn't notice is that the current package.conf is
175 general enough to do this:
178 {name = "tools", import_dirs = [], source_dirs = [],
179 library_dirs = [], hs_libraries = [], extra_libraries = [],
180 include_dirs = [], c_includes = [], package_deps = [],
181 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${libdir}/bin/unlit", ... etc.],
182 extra_cc_opts = [], extra_ld_opts = []}
184 Which would have the advantage that we get to collect together in one
185 place the path-specific package stuff with the path-specific tool
188 ---------------------------------------------
191 %************************************************************************
193 \subsection{Global variables to contain system programs}
195 %************************************************************************
197 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
198 (See remarks under pathnames below)
201 GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit
202 GLOBAL_VAR(v_Pgm_P, error "pgm_P", String) -- cpp
203 GLOBAL_VAR(v_Pgm_F, error "pgm_F", String) -- pp
204 GLOBAL_VAR(v_Pgm_c, error "pgm_c", String) -- gcc
205 GLOBAL_VAR(v_Pgm_m, error "pgm_m", String) -- asm code mangler
206 GLOBAL_VAR(v_Pgm_s, error "pgm_s", String) -- asm code splitter
207 GLOBAL_VAR(v_Pgm_a, error "pgm_a", String) -- as
209 GLOBAL_VAR(v_Pgm_I, error "pgm_I", String) -- ilx2il
210 GLOBAL_VAR(v_Pgm_i, error "pgm_i", String) -- ilasm
212 GLOBAL_VAR(v_Pgm_l, error "pgm_l", String) -- ld
213 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String) -- mkdll
215 GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
216 GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
218 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
219 GLOBAL_VAR(v_Path_usage, error "ghc_usage.txt", String)
221 GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
223 -- Parallel system only
224 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
226 -- ways to get at some of these variables from outside this module
227 getPackageConfigPath = readIORef v_Path_package_config
228 getTopDir = readIORef v_TopDir
232 %************************************************************************
234 \subsection{Initialisation}
236 %************************************************************************
239 initSysTools :: [String] -- Command-line arguments starting "-B"
241 -> IO () -- Set all the mutable variables above, holding
242 -- (a) the system programs
243 -- (b) the package-config file
244 -- (c) the GHC usage message
247 initSysTools minusB_args
248 = do { (am_installed, top_dir) <- findTopDir minusB_args
249 ; writeIORef v_TopDir top_dir
251 -- for "installed" this is the root of GHC's support files
252 -- for "in-place" it is the root of the build tree
253 -- NB: top_dir is assumed to be in standard Unix format '/' separated
255 ; let installed, installed_bin :: FilePath -> FilePath
256 installed_bin pgm = pgmPath top_dir pgm
257 installed file = pgmPath top_dir file
258 inplace dir pgm = pgmPath (top_dir `slash`
259 cPROJECT_DIR `slash` dir) pgm
262 | am_installed = installed "package.conf"
263 | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
266 | am_installed = installed "ghc-usage.txt"
267 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
269 -- For all systems, unlit, split, mangle are GHC utilities
270 -- architecture-specific stuff is done when building Config.hs
272 | am_installed = installed_bin cGHC_UNLIT_PGM
273 | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
275 -- split and mangle are Perl scripts
277 | am_installed = installed_bin cGHC_SPLIT_PGM
278 | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
281 | am_installed = installed_bin cGHC_MANGLER_PGM
282 | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
284 #ifndef mingw32_HOST_OS
285 -- check whether TMPDIR is set in the environment
286 ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
291 -- On Win32, consult GetTempPath() for a temp dir.
292 -- => it first tries TMP, TEMP, then finally the
293 -- Windows directory(!). The directory is in short-path
294 -- form and *does* have a trailing backslash.
296 let len = (2048::Int)
297 buf <- mallocArray len
298 ret <- getTempPath len buf
301 -- failed, consult TEMP.
309 -- strip the trailing backslash (awful, but
310 -- we only do this once).
320 -- Check that the package config exists
321 ; config_exists <- doesFileExist pkgconfig_path
322 ; when (not config_exists) $
323 throwDyn (InstallationError
324 ("Can't find package.conf as " ++ pkgconfig_path))
326 #if defined(mingw32_HOST_OS)
327 -- WINDOWS-SPECIFIC STUFF
328 -- On Windows, gcc and friends are distributed with GHC,
329 -- so when "installed" we look in TopDir/bin
330 -- When "in-place" we look wherever the build-time configure
332 -- When "install" we tell gcc where its specs file + exes are (-B)
333 -- and also some places to pick up include files. We need
334 -- to be careful to put all necessary exes in the -B place
335 -- (as, ld, cc1, etc) since if they don't get found there, gcc
336 -- then tries to run unadorned "as", "ld", etc, and will
337 -- pick up whatever happens to be lying around in the path,
338 -- possibly including those from a cygwin install on the target,
339 -- which is exactly what we're trying to avoid.
340 ; let gcc_path | am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
342 -- The trailing "/" is absolutely essential; gcc seems
343 -- to construct file names simply by concatenating to this
344 -- -B path with no extra slash
345 -- We use "/" rather than "\\" because otherwise "\\\" is mangled
346 -- later on; although gcc_path is in NATIVE format, gcc can cope
347 -- (see comments with declarations of global variables)
349 -- The quotes round the -B argument are in case TopDir has spaces in it
351 perl_path | am_installed = installed_bin cGHC_PERL
352 | otherwise = cGHC_PERL
354 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
355 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM
356 | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
358 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
359 -- a call to Perl to get the invocation of split and mangle
360 ; let split_path = perl_path ++ " \"" ++ split_script ++ "\""
361 mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
364 | am_installed = pgmPath (installed "gcc-lib/") cMKDLL ++
365 " --dlltool-name " ++ pgmPath (installed "gcc-lib/") "dlltool" ++
366 " --driver-name " ++ gcc_path
369 -- UNIX-SPECIFIC STUFF
370 -- On Unix, the "standard" tools are assumed to be
371 -- in the same place whether we are running "in-place" or "installed"
372 -- That place is wherever the build-time configure script found them.
373 ; let gcc_path = cGCC
375 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
377 -- On Unix, scripts are invoked using the '#!' method. Binary
378 -- installations of GHC on Unix place the correct line on the front
379 -- of the script at installation time, so we don't want to wire-in
380 -- our knowledge of $(PERL) on the host system here.
381 ; let split_path = split_script
382 mangle_path = mangle_script
385 -- cpp is derived from gcc on all platforms
386 ; let cpp_path = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
388 -- For all systems, copy and remove are provided by the host
389 -- system; architecture-specific stuff is done when building Config.hs
390 ; let cp_path = cGHC_CP
392 -- Other things being equal, as and ld are simply gcc
393 ; let as_path = gcc_path
397 -- ilx2il and ilasm are specified in Config.hs
398 ; let ilx2il_path = cILX2IL
402 -- Initialise the global vars
403 ; writeIORef v_Path_package_config pkgconfig_path
404 ; writeIORef v_Path_usage ghc_usage_msg_path
406 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
407 -- Hans: this isn't right in general, but you can
408 -- elaborate it in the same way as the others
410 ; writeIORef v_Pgm_L unlit_path
411 ; writeIORef v_Pgm_P cpp_path
412 ; writeIORef v_Pgm_F ""
413 ; writeIORef v_Pgm_c gcc_path
414 ; writeIORef v_Pgm_m mangle_path
415 ; writeIORef v_Pgm_s split_path
416 ; writeIORef v_Pgm_a as_path
418 ; writeIORef v_Pgm_I ilx2il_path
419 ; writeIORef v_Pgm_i ilasm_path
421 ; writeIORef v_Pgm_l ld_path
422 ; writeIORef v_Pgm_MkDLL mkdll_path
423 ; writeIORef v_Pgm_T touch_path
424 ; writeIORef v_Pgm_CP cp_path
429 #if defined(mingw32_HOST_OS)
430 foreign import stdcall "GetTempPathA" unsafe getTempPath :: Int -> CString -> IO Int32
434 The various setPgm functions are called when a command-line option
439 is used to override a particular program with a new one
442 setPgmP = writeIORef v_Pgm_P
443 setPgmF = writeIORef v_Pgm_F
444 setPgmc = writeIORef v_Pgm_c
445 setPgmm = writeIORef v_Pgm_m
446 setPgms = writeIORef v_Pgm_s
447 setPgma = writeIORef v_Pgm_a
448 setPgml = writeIORef v_Pgm_l
450 setPgmI = writeIORef v_Pgm_I
451 setPgmi = writeIORef v_Pgm_i
458 -- for "installed" this is the root of GHC's support files
459 -- for "in-place" it is the root of the build tree
462 -- 1. Set proto_top_dir
463 -- a) look for (the last) -B flag, and use it
464 -- b) if there are no -B flags, get the directory
465 -- where GHC is running (only on Windows)
467 -- 2. If package.conf exists in proto_top_dir, we are running
468 -- installed; and TopDir = proto_top_dir
470 -- 3. Otherwise we are running in-place, so
471 -- proto_top_dir will be /...stuff.../ghc/compiler
472 -- Set TopDir to /...stuff..., which is the root of the build tree
474 -- This is very gruesome indeed
476 findTopDir :: [String]
477 -> IO (Bool, -- True <=> am installed, False <=> in-place
478 String) -- TopDir (in Unix format '/' separated)
481 = do { top_dir <- get_proto
482 -- Discover whether we're running in a build tree or in an installation,
483 -- by looking for the package configuration file.
484 ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
486 ; return (am_installed, top_dir)
489 -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
490 get_proto | notNull minusbs
491 = return (unDosifyPath (drop 2 (last minusbs))) -- 2 for "-B"
493 = do { maybe_exec_dir <- getExecDir -- Get directory of executable
494 ; case maybe_exec_dir of -- (only works on Windows;
495 -- returns Nothing on Unix)
496 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
497 Just dir -> return dir
502 %************************************************************************
504 \subsection{Command-line options}
506 %************************************************************************
508 When invoking external tools as part of the compilation pipeline, we
509 pass these a sequence of options on the command-line. Rather than
510 just using a list of Strings, we use a type that allows us to distinguish
511 between filepaths and 'other stuff'. [The reason being, of course, that
512 this type gives us a handle on transforming filenames, and filenames only,
513 to whatever format they're expected to be on a particular platform.]
517 = FileOption -- an entry that _contains_ filename(s) / filepaths.
518 String -- a non-filepath prefix that shouldn't be transformed (e.g., "/out="
519 String -- the filepath/filename portion
522 showOptions :: [Option] -> String
523 showOptions ls = unwords (map (quote.showOpt) ls)
525 showOpt (FileOption pre f) = pre ++ dosifyPath f
526 showOpt (Option s) = s
531 %************************************************************************
533 \subsection{Running an external program}
535 %************************************************************************
539 runUnlit :: [Option] -> IO ()
540 runUnlit args = do p <- readIORef v_Pgm_L
541 runSomething "Literate pre-processor" p args
543 runCpp :: [Option] -> IO ()
544 runCpp args = do p <- readIORef v_Pgm_P
545 runSomething "C pre-processor" p args
547 runPp :: [Option] -> IO ()
548 runPp args = do p <- readIORef v_Pgm_F
549 runSomething "Haskell pre-processor" p args
551 runCc :: [Option] -> IO ()
552 runCc args = do p <- readIORef v_Pgm_c
553 runSomething "C Compiler" p args
555 runMangle :: [Option] -> IO ()
556 runMangle args = do p <- readIORef v_Pgm_m
557 runSomething "Mangler" p args
559 runSplit :: [Option] -> IO ()
560 runSplit args = do p <- readIORef v_Pgm_s
561 runSomething "Splitter" p args
563 runAs :: [Option] -> IO ()
564 runAs args = do p <- readIORef v_Pgm_a
565 runSomething "Assembler" p args
567 runLink :: [Option] -> IO ()
568 runLink args = do p <- readIORef v_Pgm_l
569 runSomething "Linker" p args
572 runIlx2il :: [Option] -> IO ()
573 runIlx2il args = do p <- readIORef v_Pgm_I
574 runSomething "Ilx2Il" p args
576 runIlasm :: [Option] -> IO ()
577 runIlasm args = do p <- readIORef v_Pgm_i
578 runSomething "Ilasm" p args
581 runMkDLL :: [Option] -> IO ()
582 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
583 runSomething "Make DLL" p args
585 touch :: String -> String -> IO ()
586 touch purpose arg = do p <- readIORef v_Pgm_T
587 runSomething purpose p [FileOption "" arg]
589 copy :: String -> String -> String -> IO ()
590 copy purpose from to = do
591 verb <- dynFlag verbosity
592 when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
594 h <- openFile to WriteMode
595 ls <- readFile from -- inefficient, but it'll do for now.
596 -- ToDo: speed up via slurping.
602 getSysMan :: IO String -- How to invoke the system manager
603 -- (parallel system only)
604 getSysMan = readIORef v_Pgm_sysman
607 %************************************************************************
609 \subsection{GHC Usage message}
611 %************************************************************************
613 Show the usage message and exit
616 showGhcUsage = do { usage_path <- readIORef v_Path_usage
617 ; usage <- readFile usage_path
619 ; exitWith ExitSuccess }
622 dump ('$':'$':s) = hPutStr stderr progName >> dump s
623 dump (c:s) = hPutChar stderr c >> dump s
627 %************************************************************************
629 \subsection{Managing temporary files
631 %************************************************************************
634 GLOBAL_VAR(v_FilesToClean, [], [String] )
635 GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
636 -- v_TmpDir has no closing '/'
640 setTmpDir dir = writeIORef v_TmpDir dir
642 cleanTempFiles :: Int -> IO ()
643 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
644 removeTmpFiles verb fs
646 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
647 cleanTempFilesExcept verb dont_delete
648 = do fs <- readIORef v_FilesToClean
649 let leftovers = filter (`notElem` dont_delete) fs
650 removeTmpFiles verb leftovers
651 writeIORef v_FilesToClean dont_delete
654 -- find a temporary name that doesn't already exist.
655 newTempName :: Suffix -> IO FilePath
657 = do x <- getProcessID
658 tmp_dir <- readIORef v_TmpDir
659 findTempName tmp_dir x
661 findTempName tmp_dir x
662 = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
663 b <- doesFileExist filename
664 if b then findTempName tmp_dir (x+1)
665 else do add v_FilesToClean filename -- clean it up later
668 addFilesToClean :: [FilePath] -> IO ()
669 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
670 addFilesToClean files = mapM_ (add v_FilesToClean) files
672 removeTmpFiles :: Int -> [FilePath] -> IO ()
673 removeTmpFiles verb fs
674 = traceCmd "Deleting temp files"
675 ("Deleting: " ++ unwords fs)
678 rm f = removeFile f `IO.catch`
681 hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
687 %************************************************************************
689 \subsection{Running a program}
691 %************************************************************************
694 GLOBAL_VAR(v_Dry_run, False, Bool)
697 setDryRun = writeIORef v_Dry_run True
699 -----------------------------------------------------------------------------
700 -- Running an external program
702 runSomething :: String -- For -v message
703 -> String -- Command name (possibly a full path)
704 -- assumed already dos-ified
705 -> [Option] -- Arguments
706 -- runSomething will dos-ify them
709 runSomething phase_name pgm args
710 = traceCmd phase_name cmd_line $
712 #ifndef mingw32_HOST_OS
713 exit_code <- system cmd_line
715 exit_code <- rawSystem cmd_line
717 ; if exit_code /= ExitSuccess
718 then throwDyn (PhaseFailed phase_name exit_code)
722 -- The pgm is already in native format (appropriate dir separators)
723 cmd_line = pgm ++ ' ':showOptions args
724 -- unwords (pgm : dosifyPaths (map quote args))
726 traceCmd :: String -> String -> IO () -> IO ()
727 -- a) trace the command (at two levels of verbosity)
728 -- b) don't do it at all if dry-run is set
729 traceCmd phase_name cmd_line action
730 = do { verb <- dynFlag verbosity
731 ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
732 ; when (verb >= 3) $ hPutStrLn stderr cmd_line
736 ; n <- readIORef v_Dry_run
740 ; action `IO.catch` handle_exn verb
743 handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
744 ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
745 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
749 %************************************************************************
751 \subsection{Path names}
753 %************************************************************************
755 We maintain path names in Unix form ('/'-separated) right until
756 the last moment. On Windows we dos-ify them just before passing them
757 to the Windows command.
759 The alternative, of using '/' consistently on Unix and '\' on Windows,
760 proved quite awkward. There were a lot more calls to dosifyPath,
761 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
762 interpreted a command line 'foo\baz' as 'foobaz'.
765 -----------------------------------------------------------------------------
766 -- Convert filepath into MSDOS form.
768 dosifyPaths :: [String] -> [String]
769 -- dosifyPaths does two things
770 -- a) change '/' to '\'
771 -- b) remove initial '/cygdrive/'
773 unDosifyPath :: String -> String
774 -- Just change '\' to '/'
776 pgmPath :: String -- Directory string in Unix format
777 -> String -- Program name with no directory separators
779 -> String -- Program invocation string in native format
783 #if defined(mingw32_HOST_OS)
785 --------------------- Windows version ------------------
786 dosifyPaths xs = map dosifyPath xs
788 unDosifyPath xs = subst '\\' '/' xs
790 pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm
793 = subst '/' '\\' real_stuff
795 -- fully convince myself that /cygdrive/ prefixes cannot
796 -- really appear here.
797 cygdrive_prefix = "/cygdrive/"
800 | cygdrive_prefix `isPrefixOf` stuff = dropList cygdrive_prefix stuff
805 --------------------- Unix version ---------------------
808 pgmPath dir pgm = dir ++ '/' : pgm
809 dosifyPath stuff = stuff
810 --------------------------------------------------------
813 subst a b ls = map (\ x -> if x == a then b else x) ls
817 -----------------------------------------------------------------------------
818 Path name construction
821 slash :: String -> String -> String
822 absPath, relPath :: [String] -> String
825 relPath xs = foldr1 slash xs
827 absPath xs = "" `slash` relPath xs
829 slash s1 s2 = s1 ++ ('/' : s2)
833 %************************************************************************
835 \subsection{Support code}
837 %************************************************************************
840 -----------------------------------------------------------------------------
841 -- Define getExecDir :: IO (Maybe String)
843 #if defined(mingw32_HOST_OS)
844 getExecDir :: IO (Maybe String)
845 getExecDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
846 buf <- mallocArray len
847 ret <- getModuleFileName nullPtr buf len
848 if ret == 0 then free buf >> return Nothing
849 else do s <- peekCString buf
851 return (Just (reverse (dropList "/bin/ghc.exe" (reverse (unDosifyPath s)))))
854 foreign import stdcall "GetModuleFileNameA" unsafe
855 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
857 getExecDir :: IO (Maybe String) = do return Nothing
860 #ifdef mingw32_HOST_OS
861 foreign import "_getpid" unsafe getProcessID :: IO Int -- relies on Int == Int32 on Windows
862 #elif __GLASGOW_HASKELL__ > 504
863 getProcessID :: IO Int
864 getProcessID = GHC.Posix.c_getpid >>= return . fromIntegral
866 getProcessID :: IO Int
867 getProcessID = Posix.getProcessID
870 quote :: String -> String
871 #if defined(mingw32_HOST_OS)
873 quote s = "\"" ++ s ++ "\""
880 This next blob is in System.Cmd after 5.04, but until then it needs
881 to be here (for Win32 only).
884 #if defined(mingw32_HOST_OS)
885 #if __GLASGOW_HASKELL__ <= 504
887 rawSystem :: String -> IO ExitCode
888 rawSystem "" = ioException (IOError Nothing InvalidArgument "rawSystem" "null command" Nothing)
890 withCString cmd $ \s -> do
891 status <- throwErrnoIfMinus1 "rawSystem" (primRawSystem s)
893 0 -> return ExitSuccess
894 n -> return (ExitFailure n)
896 foreign import ccall "rawSystemCmd" unsafe primRawSystem :: CString -> IO Int