1 -----------------------------------------------------------------------------
3 -- (c) The University of Glasgow 2001-2003
5 -- Access to system tools: gcc, cp, rm etc
7 -----------------------------------------------------------------------------
14 setPgmL, -- String -> IO ()
27 -- Command-line override
30 getTopDir, -- IO String -- The value of $topdir
31 getPackageConfigPath, -- IO String -- Where package.conf is
32 getUsageMsgPaths, -- IO (String,String)
34 -- Interface to system tools
35 runUnlit, runCpp, runCc, -- [Option] -> IO ()
36 runPp, -- [Option] -> IO ()
37 runMangle, runSplit, -- [Option] -> IO ()
38 runAs, runLink, -- [Option] -> IO ()
41 runIlx2il, runIlasm, -- [String] -> IO ()
45 touch, -- String -> String -> IO ()
46 copy, -- String -> String -> String -> IO ()
47 normalisePath, -- FilePath -> FilePath
49 -- Temporary-file management
52 cleanTempFiles, cleanTempFilesExcept,
56 system, -- String -> IO ExitCode
59 getSysMan, -- IO String Parallel system only
65 #include "HsVersions.h"
68 import DriverPhases ( isHaskellUserSrcFilename )
71 import Panic ( GhcException(..) )
72 import Util ( global, notNull )
73 import CmdLineOpts ( DynFlags(..) )
75 import EXCEPTION ( throwDyn )
76 import DATA_IOREF ( IORef, readIORef, writeIORef )
79 import Monad ( when, unless )
80 import System ( ExitCode(..), getEnv, system )
81 import IO ( try, catch,
82 openFile, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
84 import Directory ( doesFileExist, removeFile )
85 import List ( partition )
87 -- GHC <= 4.08 didn't have rawSystem, and runs into problems with long command
88 -- lines on mingw32, so we disallow it now.
89 #if __GLASGOW_HASKELL__ < 500
90 #error GHC >= 5.00 is required for bootstrapping GHC
93 #ifndef mingw32_HOST_OS
94 #if __GLASGOW_HASKELL__ > 504
95 import qualified System.Posix.Internals
97 import qualified Posix
99 #else /* Must be Win32 */
100 import List ( isPrefixOf )
101 import Util ( dropList )
103 import CString ( CString, peekCString )
106 #if __GLASGOW_HASKELL__ < 603
107 -- rawSystem comes from libghccompat.a in stage1
108 import Compat.RawSystem ( rawSystem )
110 import System.Cmd ( rawSystem )
115 The configuration story
116 ~~~~~~~~~~~~~~~~~~~~~~~
118 GHC needs various support files (library packages, RTS etc), plus
119 various auxiliary programs (cp, gcc, etc). It finds these in one
122 * When running as an *installed program*, GHC finds most of this support
123 stuff in the installed library tree. The path to this tree is passed
124 to GHC via the -B flag, and given to initSysTools .
126 * When running *in-place* in a build tree, GHC finds most of this support
127 stuff in the build tree. The path to the build tree is, again passed
130 GHC tells which of the two is the case by seeing whether package.conf
131 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
134 SysTools.initSysProgs figures out exactly where all the auxiliary programs
135 are, and initialises mutable variables to make it easy to call them.
136 To to this, it makes use of definitions in Config.hs, which is a Haskell
137 file containing variables whose value is figured out by the build system.
139 Config.hs contains two sorts of things
141 cGCC, The *names* of the programs
144 etc They do *not* include paths
147 cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc
148 cSPLIT_DIR_REL *relative* to the root of the build tree,
149 for use when running *in-place* in a build tree (only)
153 ---------------------------------------------
154 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
156 Another hair-brained scheme for simplifying the current tool location
157 nightmare in GHC: Simon originally suggested using another
158 configuration file along the lines of GCC's specs file - which is fine
159 except that it means adding code to read yet another configuration
160 file. What I didn't notice is that the current package.conf is
161 general enough to do this:
164 {name = "tools", import_dirs = [], source_dirs = [],
165 library_dirs = [], hs_libraries = [], extra_libraries = [],
166 include_dirs = [], c_includes = [], package_deps = [],
167 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
168 extra_cc_opts = [], extra_ld_opts = []}
170 Which would have the advantage that we get to collect together in one
171 place the path-specific package stuff with the path-specific tool
174 ---------------------------------------------
177 %************************************************************************
179 \subsection{Global variables to contain system programs}
181 %************************************************************************
183 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
184 (See remarks under pathnames below)
187 GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit
188 GLOBAL_VAR(v_Pgm_P, error "pgm_P", (String,[Option])) -- cpp
189 GLOBAL_VAR(v_Pgm_F, error "pgm_F", String) -- pp
190 GLOBAL_VAR(v_Pgm_c, error "pgm_c", (String,[Option])) -- gcc
191 GLOBAL_VAR(v_Pgm_m, error "pgm_m", (String,[Option])) -- asm code mangler
192 GLOBAL_VAR(v_Pgm_s, error "pgm_s", (String,[Option])) -- asm code splitter
193 GLOBAL_VAR(v_Pgm_a, error "pgm_a", (String,[Option])) -- as
195 GLOBAL_VAR(v_Pgm_I, error "pgm_I", String) -- ilx2il
196 GLOBAL_VAR(v_Pgm_i, error "pgm_i", String) -- ilasm
198 GLOBAL_VAR(v_Pgm_l, error "pgm_l", (String,[Option])) -- ld
199 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", (String,[Option])) -- mkdll
201 GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
202 GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
204 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
205 GLOBAL_VAR(v_Path_usages, error "ghc_usage.txt", (String,String))
207 GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
209 -- Parallel system only
210 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
212 -- ways to get at some of these variables from outside this module
213 getPackageConfigPath = readIORef v_Path_package_config
214 getTopDir = readIORef v_TopDir
218 %************************************************************************
220 \subsection{Initialisation}
222 %************************************************************************
225 initSysTools :: [String] -- Command-line arguments starting "-B"
227 -> IO () -- Set all the mutable variables above, holding
228 -- (a) the system programs
229 -- (b) the package-config file
230 -- (c) the GHC usage message
233 initSysTools minusB_args
234 = do { (am_installed, top_dir) <- findTopDir minusB_args
235 ; writeIORef v_TopDir top_dir
237 -- for "installed" this is the root of GHC's support files
238 -- for "in-place" it is the root of the build tree
239 -- NB: top_dir is assumed to be in standard Unix format '/' separated
241 ; let installed, installed_bin :: FilePath -> FilePath
242 installed_bin pgm = pgmPath top_dir pgm
243 installed file = pgmPath top_dir file
244 inplace dir pgm = pgmPath (top_dir `slash`
245 cPROJECT_DIR `slash` dir) pgm
248 | am_installed = installed "package.conf"
249 | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace"
252 | am_installed = installed "ghc-usage.txt"
253 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt"
256 | am_installed = installed "ghci-usage.txt"
257 | otherwise = inplace cGHC_DRIVER_DIR_REL "ghci-usage.txt"
259 -- For all systems, unlit, split, mangle are GHC utilities
260 -- architecture-specific stuff is done when building Config.hs
262 | am_installed = installed_bin cGHC_UNLIT_PGM
263 | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM
265 -- split and mangle are Perl scripts
267 | am_installed = installed_bin cGHC_SPLIT_PGM
268 | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM
271 | am_installed = installed_bin cGHC_MANGLER_PGM
272 | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM
274 #ifndef mingw32_HOST_OS
275 -- check whether TMPDIR is set in the environment
276 ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
281 -- On Win32, consult GetTempPath() for a temp dir.
282 -- => it first tries TMP, TEMP, then finally the
283 -- Windows directory(!). The directory is in short-path
286 let len = (2048::Int)
287 buf <- mallocArray len
288 ret <- getTempPath len buf
291 -- failed, consult TMPDIR.
301 -- Check that the package config exists
302 ; config_exists <- doesFileExist pkgconfig_path
303 ; when (not config_exists) $
304 throwDyn (InstallationError
305 ("Can't find package.conf as " ++ pkgconfig_path))
307 #if defined(mingw32_HOST_OS)
308 -- WINDOWS-SPECIFIC STUFF
309 -- On Windows, gcc and friends are distributed with GHC,
310 -- so when "installed" we look in TopDir/bin
311 -- When "in-place" we look wherever the build-time configure
313 -- When "install" we tell gcc where its specs file + exes are (-B)
314 -- and also some places to pick up include files. We need
315 -- to be careful to put all necessary exes in the -B place
316 -- (as, ld, cc1, etc) since if they don't get found there, gcc
317 -- then tries to run unadorned "as", "ld", etc, and will
318 -- pick up whatever happens to be lying around in the path,
319 -- possibly including those from a cygwin install on the target,
320 -- which is exactly what we're trying to avoid.
321 ; let gcc_b_arg = Option ("-B" ++ installed "gcc-lib/")
323 | am_installed = (installed_bin "gcc", [gcc_b_arg])
324 | otherwise = (cGCC, [])
325 -- The trailing "/" is absolutely essential; gcc seems
326 -- to construct file names simply by concatenating to
327 -- this -B path with no extra slash We use "/" rather
328 -- than "\\" because otherwise "\\\" is mangled
329 -- later on; although gcc_args are in NATIVE format,
331 -- (see comments with declarations of global variables)
333 -- The quotes round the -B argument are in case TopDir
336 perl_path | am_installed = installed_bin cGHC_PERL
337 | otherwise = cGHC_PERL
339 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
340 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM
341 | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM
343 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
344 -- a call to Perl to get the invocation of split and mangle
345 ; let (split_prog, split_args) = (perl_path, [Option split_script])
346 (mangle_prog, mangle_args) = (perl_path, [Option mangle_script])
348 ; let (mkdll_prog, mkdll_args)
350 (pgmPath (installed "gcc-lib/") cMKDLL,
351 [ Option "--dlltool-name",
352 Option (pgmPath (installed "gcc-lib/") "dlltool"),
353 Option "--driver-name",
354 Option gcc_prog, gcc_b_arg ])
355 | otherwise = (cMKDLL, [])
357 -- UNIX-SPECIFIC STUFF
358 -- On Unix, the "standard" tools are assumed to be
359 -- in the same place whether we are running "in-place" or "installed"
360 -- That place is wherever the build-time configure script found them.
361 ; let gcc_prog = cGCC
364 mkdll_prog = panic "Can't build DLLs on a non-Win32 system"
367 -- On Unix, scripts are invoked using the '#!' method. Binary
368 -- installations of GHC on Unix place the correct line on the front
369 -- of the script at installation time, so we don't want to wire-in
370 -- our knowledge of $(PERL) on the host system here.
371 ; let (split_prog, split_args) = (split_script, [])
372 (mangle_prog, mangle_args) = (mangle_script, [])
375 -- cpp is derived from gcc on all platforms
376 -- HACK, see setPgmP below. We keep 'words' here to remember to fix
377 -- Config.hs one day.
378 ; let cpp_path = (gcc_prog, gcc_args ++
379 (Option "-E"):(map Option (words cRAWCPP_FLAGS)))
381 -- For all systems, copy and remove are provided by the host
382 -- system; architecture-specific stuff is done when building Config.hs
383 ; let cp_path = cGHC_CP
385 -- Other things being equal, as and ld are simply gcc
386 ; let (as_prog,as_args) = (gcc_prog,gcc_args)
387 (ld_prog,ld_args) = (gcc_prog,gcc_args)
390 -- ilx2il and ilasm are specified in Config.hs
391 ; let ilx2il_path = cILX2IL
395 -- Initialise the global vars
396 ; writeIORef v_Path_package_config pkgconfig_path
397 ; writeIORef v_Path_usages (ghc_usage_msg_path,
400 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
401 -- Hans: this isn't right in general, but you can
402 -- elaborate it in the same way as the others
404 ; writeIORef v_Pgm_L unlit_path
405 ; writeIORef v_Pgm_P cpp_path
406 ; writeIORef v_Pgm_F ""
407 ; writeIORef v_Pgm_c (gcc_prog,gcc_args)
408 ; writeIORef v_Pgm_m (mangle_prog,mangle_args)
409 ; writeIORef v_Pgm_s (split_prog,split_args)
410 ; writeIORef v_Pgm_a (as_prog,as_args)
412 ; writeIORef v_Pgm_I ilx2il_path
413 ; writeIORef v_Pgm_i ilasm_path
415 ; writeIORef v_Pgm_l (ld_prog,ld_args)
416 ; writeIORef v_Pgm_MkDLL (mkdll_prog,mkdll_args)
417 ; writeIORef v_Pgm_T touch_path
418 ; writeIORef v_Pgm_CP cp_path
423 #if defined(mingw32_HOST_OS)
424 foreign import stdcall unsafe "GetTempPathA" getTempPath :: Int -> CString -> IO Int32
428 The various setPgm functions are called when a command-line option
433 is used to override a particular program with a new one
436 setPgmL = writeIORef v_Pgm_L
437 -- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]
438 -- Config.hs should really use Option.
439 setPgmP arg = let (pgm:args) = words arg in writeIORef v_Pgm_P (pgm,map Option args)
440 setPgmF = writeIORef v_Pgm_F
441 setPgmc prog = writeIORef v_Pgm_c (prog,[])
442 setPgmm prog = writeIORef v_Pgm_m (prog,[])
443 setPgms prog = writeIORef v_Pgm_s (prog,[])
444 setPgma prog = writeIORef v_Pgm_a (prog,[])
445 setPgml prog = writeIORef v_Pgm_l (prog,[])
446 setPgmDLL prog = writeIORef v_Pgm_MkDLL (prog,[])
448 setPgmI = writeIORef v_Pgm_I
449 setPgmi = writeIORef v_Pgm_i
456 -- for "installed" this is the root of GHC's support files
457 -- for "in-place" it is the root of the build tree
460 -- 1. Set proto_top_dir
461 -- a) look for (the last) -B flag, and use it
462 -- b) if there are no -B flags, get the directory
463 -- where GHC is running (only on Windows)
465 -- 2. If package.conf exists in proto_top_dir, we are running
466 -- installed; and TopDir = proto_top_dir
468 -- 3. Otherwise we are running in-place, so
469 -- proto_top_dir will be /...stuff.../ghc/compiler
470 -- Set TopDir to /...stuff..., which is the root of the build tree
472 -- This is very gruesome indeed
474 findTopDir :: [String]
475 -> IO (Bool, -- True <=> am installed, False <=> in-place
476 String) -- TopDir (in Unix format '/' separated)
479 = do { top_dir <- get_proto
480 -- Discover whether we're running in a build tree or in an installation,
481 -- by looking for the package configuration file.
482 ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
484 ; return (am_installed, top_dir)
487 -- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
488 get_proto | notNull minusbs
489 = return (normalisePath (drop 2 (last minusbs))) -- 2 for "-B"
491 = do { maybe_exec_dir <- getBaseDir -- Get directory of executable
492 ; case maybe_exec_dir of -- (only works on Windows;
493 -- returns Nothing on Unix)
494 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
495 Just dir -> return dir
500 %************************************************************************
502 \subsection{Command-line options}
504 %************************************************************************
506 When invoking external tools as part of the compilation pipeline, we
507 pass these a sequence of options on the command-line. Rather than
508 just using a list of Strings, we use a type that allows us to distinguish
509 between filepaths and 'other stuff'. [The reason being, of course, that
510 this type gives us a handle on transforming filenames, and filenames only,
511 to whatever format they're expected to be on a particular platform.]
515 = FileOption -- an entry that _contains_ filename(s) / filepaths.
516 String -- a non-filepath prefix that shouldn't be transformed (e.g., "/out="
517 String -- the filepath/filename portion
520 showOpt (FileOption pre f) = pre ++ platformPath f
521 showOpt (Option "") = ""
522 showOpt (Option s) = s
527 %************************************************************************
529 \subsection{Running an external program}
531 %************************************************************************
535 runUnlit :: DynFlags -> [Option] -> IO ()
536 runUnlit dflags args = do
537 p <- readIORef v_Pgm_L
538 runSomething dflags "Literate pre-processor" p args
540 runCpp :: DynFlags -> [Option] -> IO ()
541 runCpp dflags args = do
542 (p,baseArgs) <- readIORef v_Pgm_P
543 runSomething dflags "C pre-processor" p (baseArgs ++ args)
545 runPp :: DynFlags -> [Option] -> IO ()
546 runPp dflags args = do
547 p <- readIORef v_Pgm_F
548 runSomething dflags "Haskell pre-processor" p args
550 runCc :: DynFlags -> [Option] -> IO ()
551 runCc dflags args = do
552 (p,args0) <- readIORef v_Pgm_c
553 runSomething dflags "C Compiler" p (args0++args)
555 runMangle :: DynFlags -> [Option] -> IO ()
556 runMangle dflags args = do
557 (p,args0) <- readIORef v_Pgm_m
558 runSomething dflags "Mangler" p (args0++args)
560 runSplit :: DynFlags -> [Option] -> IO ()
561 runSplit dflags args = do
562 (p,args0) <- readIORef v_Pgm_s
563 runSomething dflags "Splitter" p (args0++args)
565 runAs :: DynFlags -> [Option] -> IO ()
566 runAs dflags args = do
567 (p,args0) <- readIORef v_Pgm_a
568 runSomething dflags "Assembler" p (args0++args)
570 runLink :: DynFlags -> [Option] -> IO ()
571 runLink dflags args = do
572 (p,args0) <- readIORef v_Pgm_l
573 runSomething dflags "Linker" p (args0++args)
576 runIlx2il :: DynFlags -> [Option] -> IO ()
577 runIlx2il dflags args = do
578 p <- readIORef v_Pgm_I
579 runSomething dflags "Ilx2Il" p args
581 runIlasm :: DynFlags -> [Option] -> IO ()
582 runIlasm dflags args = do
583 p <- readIORef v_Pgm_i
584 runSomething dflags "Ilasm" p args
587 runMkDLL :: DynFlags -> [Option] -> IO ()
588 runMkDLL dflags args = do
589 (p,args0) <- readIORef v_Pgm_MkDLL
590 runSomething dflags "Make DLL" p (args0++args)
592 touch :: DynFlags -> String -> String -> IO ()
593 touch dflags purpose arg = do
594 p <- readIORef v_Pgm_T
595 runSomething dflags purpose p [FileOption "" arg]
597 copy :: DynFlags -> String -> String -> String -> IO ()
598 copy dflags purpose from to = do
599 when (verbosity dflags >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
601 h <- openFile to WriteMode
602 ls <- readFile from -- inefficient, but it'll do for now.
603 -- ToDo: speed up via slurping.
609 getSysMan :: IO String -- How to invoke the system manager
610 -- (parallel system only)
611 getSysMan = readIORef v_Pgm_sysman
615 getUsageMsgPaths :: IO (FilePath,FilePath)
616 -- the filenames of the usage messages (ghc, ghci)
617 getUsageMsgPaths = readIORef v_Path_usages
621 %************************************************************************
623 \subsection{Managing temporary files
625 %************************************************************************
628 GLOBAL_VAR(v_FilesToClean, [], [String] )
629 GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
630 -- v_TmpDir has no closing '/'
634 setTmpDir dir = writeIORef v_TmpDir (canonicalise dir)
636 #if !defined(mingw32_HOST_OS)
637 canonicalise p = normalisePath p
639 -- Canonicalisation of temp path under win32 is a bit more
640 -- involved: (a) strip trailing slash,
641 -- (b) normalise slashes
642 -- (c) just in case, if there is a prefix /cygdrive/x/, change to x:
644 canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path))
646 -- if we're operating under cygwin, and TMP/TEMP is of
647 -- the form "/cygdrive/drive/path", translate this to
648 -- "drive:/path" (as GHC isn't a cygwin app and doesn't
649 -- understand /cygdrive paths.)
651 | "/cygdrive/" `isPrefixOf` path =
652 case drop (length "/cygdrive/") path of
653 drive:xs@('/':_) -> drive:':':xs
657 -- strip the trailing backslash (awful, but we only do this once).
658 removeTrailingSlash path =
665 cleanTempFiles :: DynFlags -> IO ()
666 cleanTempFiles dflags
667 = do fs <- readIORef v_FilesToClean
668 removeTmpFiles dflags fs
669 writeIORef v_FilesToClean []
671 cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO ()
672 cleanTempFilesExcept dflags dont_delete
673 = do files <- readIORef v_FilesToClean
674 let (to_keep, to_delete) = partition (`elem` dont_delete) files
675 removeTmpFiles dflags to_delete
676 writeIORef v_FilesToClean to_keep
679 -- find a temporary name that doesn't already exist.
680 newTempName :: Suffix -> IO FilePath
682 = do x <- getProcessID
683 tmp_dir <- readIORef v_TmpDir
684 findTempName tmp_dir x
686 findTempName tmp_dir x
687 = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
688 b <- doesFileExist filename
689 if b then findTempName tmp_dir (x+1)
690 else do add v_FilesToClean filename -- clean it up later
693 addFilesToClean :: [FilePath] -> IO ()
694 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
695 addFilesToClean files = mapM_ (add v_FilesToClean) files
697 removeTmpFiles :: DynFlags -> [FilePath] -> IO ()
698 removeTmpFiles dflags fs
700 traceCmd dflags "Deleting temp files"
701 ("Deleting: " ++ unwords deletees)
704 verb = verbosity dflags
706 -- Flat out refuse to delete files that are likely to be source input
707 -- files (is there a worse bug than having a compiler delete your source
710 -- Deleting source files is a sign of a bug elsewhere, so prominently flag
713 | null non_deletees = act
715 hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
718 (non_deletees, deletees) = partition isHaskellUserSrcFilename fs
720 rm f = removeFile f `IO.catch`
723 hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
729 %************************************************************************
731 \subsection{Running a program}
733 %************************************************************************
736 GLOBAL_VAR(v_Dry_run, False, Bool)
739 setDryRun = writeIORef v_Dry_run True
741 -----------------------------------------------------------------------------
742 -- Running an external program
744 runSomething :: DynFlags
745 -> String -- For -v message
746 -> String -- Command name (possibly a full path)
747 -- assumed already dos-ified
748 -> [Option] -- Arguments
749 -- runSomething will dos-ify them
752 runSomething dflags phase_name pgm args = do
753 let real_args = filter notNull (map showOpt args)
754 traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
755 exit_code <- rawSystem pgm real_args
759 -- rawSystem returns (ExitFailure 127) if the exec failed for any
760 -- reason (eg. the program doesn't exist). This is the only clue
761 -- we have, but we need to report something to the user because in
762 -- the case of a missing program there will otherwise be no output
765 throwDyn (InstallationError ("could not execute: " ++ pgm))
766 ExitFailure _other ->
767 throwDyn (PhaseFailed phase_name exit_code)
769 traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
770 -- a) trace the command (at two levels of verbosity)
771 -- b) don't do it at all if dry-run is set
772 traceCmd dflags phase_name cmd_line action
773 = do { let verb = verbosity dflags
774 ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
775 ; when (verb >= 3) $ hPutStrLn stderr cmd_line
779 ; n <- readIORef v_Dry_run
783 ; action `IO.catch` handle_exn verb
786 handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
787 ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
788 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
792 %************************************************************************
794 \subsection{Path names}
796 %************************************************************************
798 We maintain path names in Unix form ('/'-separated) right until
799 the last moment. On Windows we dos-ify them just before passing them
800 to the Windows command.
802 The alternative, of using '/' consistently on Unix and '\' on Windows,
803 proved quite awkward. There were a lot more calls to platformPath,
804 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
805 interpreted a command line 'foo\baz' as 'foobaz'.
808 -----------------------------------------------------------------------------
809 -- Convert filepath into platform / MSDOS form.
811 normalisePath :: String -> String
812 -- Just changes '\' to '/'
814 pgmPath :: String -- Directory string in Unix format
815 -> String -- Program name with no directory separators
817 -> String -- Program invocation string in native format
821 #if defined(mingw32_HOST_OS)
822 --------------------- Windows version ------------------
823 normalisePath xs = subst '\\' '/' xs
824 platformPath p = subst '/' '\\' p
825 pgmPath dir pgm = platformPath dir ++ '\\' : pgm
827 subst a b ls = map (\ x -> if x == a then b else x) ls
829 --------------------- Non-Windows version --------------
830 normalisePath xs = xs
831 pgmPath dir pgm = dir ++ '/' : pgm
832 platformPath stuff = stuff
833 --------------------------------------------------------
839 -----------------------------------------------------------------------------
840 Path name construction
843 slash :: String -> String -> String
844 slash s1 s2 = s1 ++ ('/' : s2)
848 %************************************************************************
850 \subsection{Support code}
852 %************************************************************************
855 -----------------------------------------------------------------------------
856 -- Define getBaseDir :: IO (Maybe String)
858 #if defined(mingw32_HOST_OS)
859 getBaseDir :: IO (Maybe String)
860 -- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
861 -- return the path $(stuff). Note that we drop the "bin/" directory too.
862 getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
863 buf <- mallocArray len
864 ret <- getModuleFileName nullPtr buf len
865 if ret == 0 then free buf >> return Nothing
866 else do s <- peekCString buf
868 return (Just (rootDir s))
870 rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
872 foreign import stdcall unsafe "GetModuleFileNameA"
873 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
875 getBaseDir :: IO (Maybe String) = do return Nothing
878 #ifdef mingw32_HOST_OS
879 foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
880 #elif __GLASGOW_HASKELL__ > 504
881 getProcessID :: IO Int
882 getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
884 getProcessID :: IO Int
885 getProcessID = Posix.getProcessID