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 #if __GLASGOW_HASKELL__ > 408
75 import qualified EXCEPTION as Exception ( catch )
77 import EXCEPTION ( catchAllIO )
80 import DATA_IOREF ( IORef, readIORef, writeIORef )
83 import Monad ( when, unless )
84 import System ( ExitCode(..), exitWith, getEnv, system )
86 import Directory ( doesFileExist, removeFile )
88 #include "../includes/config.h"
90 -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
91 -- lines on mingw32, so we disallow it now.
92 #if defined(mingw32_HOST_OS) && (__GLASGOW_HASKELL__ <= 408)
93 #error GHC <= 4.08 is not supported for bootstrapping GHC on i386-unknown-mingw32
96 #ifndef mingw32_HOST_OS
97 import qualified Posix
99 import List ( isPrefixOf )
100 import Util ( dropList )
103 import Foreign.C.String
106 #ifdef mingw32_HOST_OS
107 #if __GLASGOW_HASKELL__ > 504
108 import System.Cmd ( rawSystem )
110 import SystemExts ( rawSystem )
113 import System ( system )
116 -- Make catch work on older GHCs
117 #if __GLASGOW_HASKELL__ > 408
118 myCatch = Exception.catch
126 The configuration story
127 ~~~~~~~~~~~~~~~~~~~~~~~
129 GHC needs various support files (library packages, RTS etc), plus
130 various auxiliary programs (cp, gcc, etc). It finds these in one
133 * When running as an *installed program*, GHC finds most of this support
134 stuff in the installed library tree. The path to this tree is passed
135 to GHC via the -B flag, and given to initSysTools .
137 * When running *in-place* in a build tree, GHC finds most of this support
138 stuff in the build tree. The path to the build tree is, again passed
141 GHC tells which of the two is the case by seeing whether package.conf
142 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
145 SysTools.initSysProgs figures out exactly where all the auxiliary programs
146 are, and initialises mutable variables to make it easy to call them.
147 To to this, it makes use of definitions in Config.hs, which is a Haskell
148 file containing variables whose value is figured out by the build system.
150 Config.hs contains two sorts of things
152 cGCC, The *names* of the programs
155 etc They do *not* include paths
158 cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
159 cSPLIT_DIR_REL *relative* to the root of the build tree,
160 for use when running *in-place* in a build tree (only)
164 ---------------------------------------------
165 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
167 Another hair-brained scheme for simplifying the current tool location
168 nightmare in GHC: Simon originally suggested using another
169 configuration file along the lines of GCC's specs file - which is fine
170 except that it means adding code to read yet another configuration
171 file. What I didn't notice is that the current package.conf is
172 general enough to do this:
175 {name = "tools", import_dirs = [], source_dirs = [],
176 library_dirs = [], hs_libraries = [], extra_libraries = [],
177 include_dirs = [], c_includes = [], package_deps = [],
178 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${libdir}/bin/unlit", ... etc.],
179 extra_cc_opts = [], extra_ld_opts = []}
181 Which would have the advantage that we get to collect together in one
182 place the path-specific package stuff with the path-specific tool
185 ---------------------------------------------
188 %************************************************************************
190 \subsection{Global variables to contain system programs}
192 %************************************************************************
194 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
195 (See remarks under pathnames below)
198 GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit
199 GLOBAL_VAR(v_Pgm_P, error "pgm_P", String) -- cpp
200 GLOBAL_VAR(v_Pgm_F, error "pgm_F", String) -- pp
201 GLOBAL_VAR(v_Pgm_c, error "pgm_c", String) -- gcc
202 GLOBAL_VAR(v_Pgm_m, error "pgm_m", String) -- asm code mangler
203 GLOBAL_VAR(v_Pgm_s, error "pgm_s", String) -- asm code splitter
204 GLOBAL_VAR(v_Pgm_a, error "pgm_a", String) -- as
206 GLOBAL_VAR(v_Pgm_I, error "pgm_I", String) -- ilx2il
207 GLOBAL_VAR(v_Pgm_i, error "pgm_i", String) -- ilasm
209 GLOBAL_VAR(v_Pgm_l, error "pgm_l", String) -- ld
210 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String) -- mkdll
212 GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
213 GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
215 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
216 GLOBAL_VAR(v_Path_usage, error "ghc_usage.txt", String)
218 GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
220 -- Parallel system only
221 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
223 -- ways to get at some of these variables from outside this module
224 getPackageConfigPath = readIORef v_Path_package_config
225 getTopDir = readIORef v_TopDir
229 %************************************************************************
231 \subsection{Initialisation}
233 %************************************************************************
236 initSysTools :: [String] -- Command-line arguments starting "-B"
238 -> IO () -- Set all the mutable variables above, holding
239 -- (a) the system programs
240 -- (b) the package-config file
241 -- (c) the GHC usage message
244 initSysTools minusB_args
245 = do { (am_installed, top_dir) <- findTopDir minusB_args
246 ; writeIORef v_TopDir top_dir
248 -- for "installed" this is the root of GHC's support files
249 -- for "in-place" it is the root of the build tree
250 -- NB: top_dir is assumed to be in standard Unix format '/' separated
252 ; let installed, installed_bin :: FilePath -> FilePath
253 installed_bin pgm = pgmPath top_dir pgm
254 installed file = pgmPath top_dir file
255 inplace dir pgm = pgmPath (top_dir `slash`
256 cPROJECT_DIR `slash` dir) pgm
259 | am_installed = installed "package.conf"
260 | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
263 | am_installed = installed "ghc-usage.txt"
264 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
266 -- For all systems, unlit, split, mangle are GHC utilities
267 -- architecture-specific stuff is done when building Config.hs
269 | am_installed = installed_bin cGHC_UNLIT_PGM
270 | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
272 -- split and mangle are Perl scripts
274 | am_installed = installed_bin cGHC_SPLIT_PGM
275 | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
278 | am_installed = installed_bin cGHC_MANGLER_PGM
279 | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
281 #ifndef mingw32_HOST_OS
282 -- check whether TMPDIR is set in the environment
283 ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
288 -- On Win32, consult GetTempPath() for a temp dir.
289 -- => it first tries TMP, TEMP, then finally the
290 -- Windows directory(!). The directory is in short-path
291 -- form and *does* have a trailing backslash.
293 let len = (2048::Int)
294 buf <- mallocArray len
295 ret <- getTempPath len buf
298 -- failed, consult TEMP.
306 -- strip the trailing backslash (awful, but
307 -- we only do this once).
317 -- Check that the package config exists
318 ; config_exists <- doesFileExist pkgconfig_path
319 ; when (not config_exists) $
320 throwDyn (InstallationError
321 ("Can't find package.conf as " ++ pkgconfig_path))
323 #if defined(mingw32_HOST_OS)
324 -- WINDOWS-SPECIFIC STUFF
325 -- On Windows, gcc and friends are distributed with GHC,
326 -- so when "installed" we look in TopDir/bin
327 -- When "in-place" we look wherever the build-time configure
329 -- When "install" we tell gcc where its specs file + exes are (-B)
330 -- and also some places to pick up include files. We need
331 -- to be careful to put all necessary exes in the -B place
332 -- (as, ld, cc1, etc) since if they don't get found there, gcc
333 -- then tries to run unadorned "as", "ld", etc, and will
334 -- pick up whatever happens to be lying around in the path,
335 -- possibly including those from a cygwin install on the target,
336 -- which is exactly what we're trying to avoid.
337 ; let gcc_path | am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
339 -- The trailing "/" is absolutely essential; gcc seems
340 -- to construct file names simply by concatenating to this
341 -- -B path with no extra slash
342 -- We use "/" rather than "\\" because otherwise "\\\" is mangled
343 -- later on; although gcc_path is in NATIVE format, gcc can cope
344 -- (see comments with declarations of global variables)
346 -- The quotes round the -B argument are in case TopDir has spaces in it
348 perl_path | am_installed = installed_bin cGHC_PERL
349 | otherwise = cGHC_PERL
351 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
352 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM
353 | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
355 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
356 -- a call to Perl to get the invocation of split and mangle
357 ; let split_path = perl_path ++ " \"" ++ split_script ++ "\""
358 mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
361 | am_installed = pgmPath (installed "gcc-lib/") cMKDLL ++
362 " --dlltool-name " ++ pgmPath (installed "gcc-lib/") "dlltool" ++
363 " --driver-name " ++ gcc_path
366 -- UNIX-SPECIFIC STUFF
367 -- On Unix, the "standard" tools are assumed to be
368 -- in the same place whether we are running "in-place" or "installed"
369 -- That place is wherever the build-time configure script found them.
370 ; let gcc_path = cGCC
372 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
374 -- On Unix, scripts are invoked using the '#!' method. Binary
375 -- installations of GHC on Unix place the correct line on the front
376 -- of the script at installation time, so we don't want to wire-in
377 -- our knowledge of $(PERL) on the host system here.
378 ; let split_path = split_script
379 mangle_path = mangle_script
382 -- cpp is derived from gcc on all platforms
383 ; let cpp_path = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
385 -- For all systems, copy and remove are provided by the host
386 -- system; architecture-specific stuff is done when building Config.hs
387 ; let cp_path = cGHC_CP
389 -- Other things being equal, as and ld are simply gcc
390 ; let as_path = gcc_path
394 -- ilx2il and ilasm are specified in Config.hs
395 ; let ilx2il_path = cILX2IL
399 -- Initialise the global vars
400 ; writeIORef v_Path_package_config pkgconfig_path
401 ; writeIORef v_Path_usage ghc_usage_msg_path
403 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
404 -- Hans: this isn't right in general, but you can
405 -- elaborate it in the same way as the others
407 ; writeIORef v_Pgm_L unlit_path
408 ; writeIORef v_Pgm_P cpp_path
409 ; writeIORef v_Pgm_F ""
410 ; writeIORef v_Pgm_c gcc_path
411 ; writeIORef v_Pgm_m mangle_path
412 ; writeIORef v_Pgm_s split_path
413 ; writeIORef v_Pgm_a as_path
415 ; writeIORef v_Pgm_I ilx2il_path
416 ; writeIORef v_Pgm_i ilasm_path
418 ; writeIORef v_Pgm_l ld_path
419 ; writeIORef v_Pgm_MkDLL mkdll_path
420 ; writeIORef v_Pgm_T touch_path
421 ; writeIORef v_Pgm_CP cp_path
426 #if defined(mingw32_HOST_OS)
427 foreign import stdcall "GetTempPathA" unsafe getTempPath :: Int -> CString -> IO Int32
431 The various setPgm functions are called when a command-line option
436 is used to override a particular program with a new one
439 setPgmP = writeIORef v_Pgm_P
440 setPgmF = writeIORef v_Pgm_F
441 setPgmc = writeIORef v_Pgm_c
442 setPgmm = writeIORef v_Pgm_m
443 setPgms = writeIORef v_Pgm_s
444 setPgma = writeIORef v_Pgm_a
445 setPgml = writeIORef v_Pgm_l
447 setPgmI = writeIORef v_Pgm_I
448 setPgmi = writeIORef v_Pgm_i
455 -- for "installed" this is the root of GHC's support files
456 -- for "in-place" it is the root of the build tree
459 -- 1. Set proto_top_dir
460 -- a) look for (the last) -B flag, and use it
461 -- b) if there are no -B flags, get the directory
462 -- where GHC is running (only on Windows)
464 -- 2. If package.conf exists in proto_top_dir, we are running
465 -- installed; and TopDir = proto_top_dir
467 -- 3. Otherwise we are running in-place, so
468 -- proto_top_dir will be /...stuff.../ghc/compiler
469 -- Set TopDir to /...stuff..., which is the root of the build tree
471 -- This is very gruesome indeed
473 findTopDir :: [String]
474 -> IO (Bool, -- True <=> am installed, False <=> in-place
475 String) -- TopDir (in Unix format '/' separated)
478 = do { top_dir <- get_proto
479 -- Discover whether we're running in a build tree or in an installation,
480 -- by looking for the package configuration file.
481 ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
483 ; return (am_installed, top_dir)
486 -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
487 get_proto | notNull minusbs
488 = return (unDosifyPath (drop 2 (last minusbs))) -- 2 for "-B"
490 = do { maybe_exec_dir <- getExecDir -- Get directory of executable
491 ; case maybe_exec_dir of -- (only works on Windows;
492 -- returns Nothing on Unix)
493 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
494 Just dir -> return dir
499 %************************************************************************
501 \subsection{Command-line options}
503 %************************************************************************
505 When invoking external tools as part of the compilation pipeline, we
506 pass these a sequence of options on the command-line. Rather than
507 just using a list of Strings, we use a type that allows us to distinguish
508 between filepaths and 'other stuff'. [The reason being, of course, that
509 this type gives us a handle on transforming filenames, and filenames only,
510 to whatever format they're expected to be on a particular platform.]
514 = FileOption -- an entry that _contains_ filename(s) / filepaths.
515 String -- a non-filepath prefix that shouldn't be transformed (e.g., "/out="
516 String -- the filepath/filename portion
519 showOptions :: [Option] -> String
520 showOptions ls = unwords (map (quote.showOpt) ls)
522 showOpt (FileOption pre f) = pre ++ dosifyPath f
523 showOpt (Option s) = s
528 %************************************************************************
530 \subsection{Running an external program}
532 %************************************************************************
536 runUnlit :: [Option] -> IO ()
537 runUnlit args = do p <- readIORef v_Pgm_L
538 runSomething "Literate pre-processor" p args
540 runCpp :: [Option] -> IO ()
541 runCpp args = do p <- readIORef v_Pgm_P
542 runSomething "C pre-processor" p args
544 runPp :: [Option] -> IO ()
545 runPp args = do p <- readIORef v_Pgm_F
546 runSomething "Haskell pre-processor" p args
548 runCc :: [Option] -> IO ()
549 runCc args = do p <- readIORef v_Pgm_c
550 runSomething "C Compiler" p args
552 runMangle :: [Option] -> IO ()
553 runMangle args = do p <- readIORef v_Pgm_m
554 runSomething "Mangler" p args
556 runSplit :: [Option] -> IO ()
557 runSplit args = do p <- readIORef v_Pgm_s
558 runSomething "Splitter" p args
560 runAs :: [Option] -> IO ()
561 runAs args = do p <- readIORef v_Pgm_a
562 runSomething "Assembler" p args
564 runLink :: [Option] -> IO ()
565 runLink args = do p <- readIORef v_Pgm_l
566 runSomething "Linker" p args
569 runIlx2il :: [Option] -> IO ()
570 runIlx2il args = do p <- readIORef v_Pgm_I
571 runSomething "Ilx2Il" p args
573 runIlasm :: [Option] -> IO ()
574 runIlasm args = do p <- readIORef v_Pgm_i
575 runSomething "Ilasm" p args
578 runMkDLL :: [Option] -> IO ()
579 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
580 runSomething "Make DLL" p args
582 touch :: String -> String -> IO ()
583 touch purpose arg = do p <- readIORef v_Pgm_T
584 runSomething purpose p [FileOption "" arg]
586 copy :: String -> String -> String -> IO ()
587 copy purpose from to = do
588 verb <- dynFlag verbosity
589 when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
591 h <- openFile to WriteMode
592 ls <- readFile from -- inefficient, but it'll do for now.
593 -- ToDo: speed up via slurping.
599 getSysMan :: IO String -- How to invoke the system manager
600 -- (parallel system only)
601 getSysMan = readIORef v_Pgm_sysman
604 %************************************************************************
606 \subsection{GHC Usage message}
608 %************************************************************************
610 Show the usage message and exit
613 showGhcUsage = do { usage_path <- readIORef v_Path_usage
614 ; usage <- readFile usage_path
616 ; exitWith ExitSuccess }
619 dump ('$':'$':s) = hPutStr stderr progName >> dump s
620 dump (c:s) = hPutChar stderr c >> dump s
624 %************************************************************************
626 \subsection{Managing temporary files
628 %************************************************************************
631 GLOBAL_VAR(v_FilesToClean, [], [String] )
632 GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
633 -- v_TmpDir has no closing '/'
637 setTmpDir dir = writeIORef v_TmpDir dir
639 cleanTempFiles :: Int -> IO ()
640 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
641 removeTmpFiles verb fs
643 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
644 cleanTempFilesExcept verb dont_delete
645 = do fs <- readIORef v_FilesToClean
646 let leftovers = filter (`notElem` dont_delete) fs
647 removeTmpFiles verb leftovers
648 writeIORef v_FilesToClean dont_delete
651 -- find a temporary name that doesn't already exist.
652 newTempName :: Suffix -> IO FilePath
654 = do x <- getProcessID
655 tmp_dir <- readIORef v_TmpDir
656 findTempName tmp_dir x
658 findTempName tmp_dir x
659 = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
660 b <- doesFileExist filename
661 if b then findTempName tmp_dir (x+1)
662 else do add v_FilesToClean filename -- clean it up later
665 addFilesToClean :: [FilePath] -> IO ()
666 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
667 addFilesToClean files = mapM_ (add v_FilesToClean) files
669 removeTmpFiles :: Int -> [FilePath] -> IO ()
670 removeTmpFiles verb fs
671 = traceCmd "Deleting temp files"
672 ("Deleting: " ++ unwords fs)
675 rm f = removeFile f `myCatch`
678 hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
684 %************************************************************************
686 \subsection{Running a program}
688 %************************************************************************
691 GLOBAL_VAR(v_Dry_run, False, Bool)
694 setDryRun = writeIORef v_Dry_run True
696 -----------------------------------------------------------------------------
697 -- Running an external program
699 runSomething :: String -- For -v message
700 -> String -- Command name (possibly a full path)
701 -- assumed already dos-ified
702 -> [Option] -- Arguments
703 -- runSomething will dos-ify them
706 runSomething phase_name pgm args
707 = traceCmd phase_name cmd_line $
709 #ifndef mingw32_HOST_OS
710 exit_code <- system cmd_line
712 exit_code <- rawSystem cmd_line
714 ; if exit_code /= ExitSuccess
715 then throwDyn (PhaseFailed phase_name exit_code)
719 -- The pgm is already in native format (appropriate dir separators)
720 cmd_line = pgm ++ ' ':showOptions args
721 -- unwords (pgm : dosifyPaths (map quote args))
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_HOST_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_HOST_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 nullPtr buf len
845 if ret == 0 then free buf >> return Nothing
846 else do s <- peekCString buf
848 return (Just (reverse (dropList "/bin/ghc.exe" (reverse (unDosifyPath s)))))
851 foreign import stdcall "GetModuleFileNameA" unsafe
852 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
854 getExecDir :: IO (Maybe String) = do return Nothing
857 #ifdef mingw32_HOST_OS
858 foreign import "_getpid" unsafe getProcessID :: IO Int -- relies on Int == Int32 on Windows
860 getProcessID :: IO Int
861 getProcessID = Posix.getProcessID
864 quote :: String -> String
865 #if defined(mingw32_HOST_OS)
867 quote s = "\"" ++ s ++ "\""