1 -----------------------------------------------------------------------------
2 -- $Id: SysTools.lhs,v 1.48 2001/08/13 15:49:38 simonmar Exp $
4 -- (c) The University of Glasgow 2001
6 -- Access to system tools: gcc, cp, rm etc
8 -----------------------------------------------------------------------------
14 setPgm, -- String -> IO ()
15 -- Command-line override
18 getTopDir, -- IO String -- The value of $libdir
19 getPackageConfigPath, -- IO String -- Where package.conf is
21 -- Interface to system tools
22 runUnlit, runCpp, runCc, -- [Option] -> IO ()
23 runMangle, runSplit, -- [Option] -> IO ()
24 runAs, runLink, -- [Option] -> IO ()
27 touch, -- String -> String -> IO ()
28 copy, -- String -> String -> String -> IO ()
29 unDosifyPath, -- String -> String
31 -- Temporary-file management
34 cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
38 getProcessID, -- IO Int
39 system, -- String -> IO ExitCode
42 showGhcUsage, -- IO () Shows usage message and exits
43 getSysMan, -- IO String Parallel system only
52 import Panic ( progName, GhcException(..) )
53 import Util ( global )
54 import CmdLineOpts ( dynFlag, verbosity )
56 import Exception ( throwDyn, catchAllIO )
58 import Directory ( doesFileExist, removeFile )
59 import IOExts ( IORef, readIORef, writeIORef )
60 import Monad ( when, unless )
61 import System ( ExitCode(..), exitWith, getEnv, system )
66 #include "../includes/config.h"
68 #ifndef mingw32_TARGET_OS
69 import qualified Posix
71 import List ( isPrefixOf )
73 import SystemExts ( rawSystem )
76 #include "HsVersions.h"
81 The configuration story
82 ~~~~~~~~~~~~~~~~~~~~~~~
84 GHC needs various support files (library packages, RTS etc), plus
85 various auxiliary programs (cp, gcc, etc). It finds these in one
88 * When running as an *installed program*, GHC finds most of this support
89 stuff in the installed library tree. The path to this tree is passed
90 to GHC via the -B flag, and given to initSysTools .
92 * When running *in-place* in a build tree, GHC finds most of this support
93 stuff in the build tree. The path to the build tree is, again passed
96 GHC tells which of the two is the case by seeing whether package.conf
97 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
100 SysTools.initSysProgs figures out exactly where all the auxiliary programs
101 are, and initialises mutable variables to make it easy to call them.
102 To to this, it makes use of definitions in Config.hs, which is a Haskell
103 file containing variables whose value is figured out by the build system.
105 Config.hs contains two sorts of things
107 cGCC, The *names* of the programs
110 etc They do *not* include paths
113 cUNLIT_DIR The *path* to the directory containing unlit, split etc
114 cSPLIT_DIR *relative* to the root of the build tree,
115 for use when running *in-place* in a build tree (only)
119 ---------------------------------------------
120 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
122 Another hair-brained scheme for simplifying the current tool location
123 nightmare in GHC: Simon originally suggested using another
124 configuration file along the lines of GCC's specs file - which is fine
125 except that it means adding code to read yet another configuration
126 file. What I didn't notice is that the current package.conf is
127 general enough to do this:
130 {name = "tools", import_dirs = [], source_dirs = [],
131 library_dirs = [], hs_libraries = [], extra_libraries = [],
132 include_dirs = [], c_includes = [], package_deps = [],
133 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${libdir}/bin/unlit", ... etc.],
134 extra_cc_opts = [], extra_ld_opts = []}
136 Which would have the advantage that we get to collect together in one
137 place the path-specific package stuff with the path-specific tool
140 ---------------------------------------------
143 %************************************************************************
145 \subsection{Global variables to contain system programs}
147 %************************************************************************
149 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
150 (See remarks under pathnames below)
153 GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit
154 GLOBAL_VAR(v_Pgm_P, error "pgm_P", String) -- cpp
155 GLOBAL_VAR(v_Pgm_c, error "pgm_c", String) -- gcc
156 GLOBAL_VAR(v_Pgm_m, error "pgm_m", String) -- asm code mangler
157 GLOBAL_VAR(v_Pgm_s, error "pgm_s", String) -- asm code splitter
158 GLOBAL_VAR(v_Pgm_a, error "pgm_a", String) -- as
159 GLOBAL_VAR(v_Pgm_l, error "pgm_l", String) -- ld
160 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String) -- mkdll
162 GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
163 GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
165 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
166 GLOBAL_VAR(v_Path_usage, error "ghc_usage.txt", String)
168 GLOBAL_VAR(v_TopDir, error "TopDir", String) -- -B<dir>
170 -- Parallel system only
171 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
173 -- ways to get at some of these variables from outside this module
174 getPackageConfigPath = readIORef v_Path_package_config
175 getTopDir = readIORef v_TopDir
179 %************************************************************************
181 \subsection{Initialisation}
183 %************************************************************************
186 initSysTools :: [String] -- Command-line arguments starting "-B"
188 -> IO () -- Set all the mutable variables above, holding
189 -- (a) the system programs
190 -- (b) the package-config file
191 -- (c) the GHC usage message
194 initSysTools minusB_args
195 = do { (am_installed, top_dir) <- findTopDir minusB_args
196 ; writeIORef v_TopDir top_dir
198 -- for "installed" this is the root of GHC's support files
199 -- for "in-place" it is the root of the build tree
200 -- NB: top_dir is assumed to be in standard Unix format '/' separated
202 ; let installed, installed_bin :: FilePath -> FilePath
203 installed_bin pgm = pgmPath (top_dir `slash` "extra-bin") pgm
204 installed file = pgmPath top_dir file
205 inplace dir pgm = pgmPath (top_dir `slash` dir) pgm
208 | am_installed = installed "package.conf"
209 | otherwise = inplace cGHC_DRIVER_DIR "package.conf.inplace"
212 | am_installed = installed "ghc-usage.txt"
213 | otherwise = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
215 -- For all systems, unlit, split, mangle are GHC utilities
216 -- architecture-specific stuff is done when building Config.hs
218 | am_installed = installed_bin cGHC_UNLIT
219 | otherwise = inplace cGHC_UNLIT_DIR cGHC_UNLIT
221 -- split and mangle are Perl scripts
223 | am_installed = installed_bin cGHC_SPLIT
224 | otherwise = inplace cGHC_SPLIT_DIR cGHC_SPLIT
227 | am_installed = installed_bin cGHC_MANGLER
228 | otherwise = inplace cGHC_MANGLER_DIR cGHC_MANGLER
230 #ifndef mingw32_TARGET_OS
231 -- check whether TMPDIR is set in the environment
232 ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
238 -- Check that the package config exists
239 ; config_exists <- doesFileExist pkgconfig_path
240 ; when (not config_exists) $
241 throwDyn (InstallationError
242 ("Can't find package.conf as " ++ pkgconfig_path))
244 #if defined(mingw32_TARGET_OS)
245 -- WINDOWS-SPECIFIC STUFF
246 -- On Windows, gcc and friends are distributed with GHC,
247 -- so when "installed" we look in TopDir/bin
248 -- When "in-place" we look wherever the build-time configure
250 -- When "install" we tell gcc where its specs file + exes are (-B)
251 -- and also some places to pick up include files. We need
252 -- to be careful to put all necessary exes in the -B place
253 -- (as, ld, cc1, etc) since if they don't get found there, gcc
254 -- then tries to run unadorned "as", "ld", etc, and will
255 -- pick up whatever happens to be lying around in the path,
256 -- possibly including those from a cygwin install on the target,
257 -- which is exactly what we're trying to avoid.
258 ; let gcc_path | am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
260 -- The trailing "/" is absolutely essential; gcc seems
261 -- to construct file names simply by concatenating to this
262 -- -B path with no extra slash
263 -- We use "/" rather than "\\" because otherwise "\\\" is mangled
264 -- later on; although gcc_path is in NATIVE format, gcc can cope
265 -- (see comments with declarations of global variables)
267 -- The quotes round the -B argument are in case TopDir has spaces in it
269 perl_path | am_installed = installed_bin cGHC_PERL
270 | otherwise = cGHC_PERL
272 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
273 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY
274 | otherwise = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
276 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
277 -- a call to Perl to get the invocation of split and mangle
278 ; let split_path = perl_path ++ " \"" ++ split_script ++ "\""
279 mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
281 ; let mkdll_path = cMKDLL
283 -- UNIX-SPECIFIC STUFF
284 -- On Unix, the "standard" tools are assumed to be
285 -- in the same place whether we are running "in-place" or "installed"
286 -- That place is wherever the build-time configure script found them.
287 ; let gcc_path = cGCC
288 touch_path = cGHC_TOUCHY
289 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
291 -- On Unix, scripts are invoked using the '#!' method. Binary
292 -- installations of GHC on Unix place the correct line on the front
293 -- of the script at installation time, so we don't want to wire-in
294 -- our knowledge of $(PERL) on the host system here.
295 ; let split_path = split_script
296 mangle_path = mangle_script
299 -- cpp is derived from gcc on all platforms
300 ; let cpp_path = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
302 -- For all systems, copy and remove are provided by the host
303 -- system; architecture-specific stuff is done when building Config.hs
304 ; let cp_path = cGHC_CP
306 -- Other things being equal, as and ld are simply gcc
307 ; let as_path = gcc_path
311 -- Initialise the global vars
312 ; writeIORef v_Path_package_config pkgconfig_path
313 ; writeIORef v_Path_usage ghc_usage_msg_path
315 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
316 -- Hans: this isn't right in general, but you can
317 -- elaborate it in the same way as the others
319 ; writeIORef v_Pgm_L unlit_path
320 ; writeIORef v_Pgm_P cpp_path
321 ; writeIORef v_Pgm_c gcc_path
322 ; writeIORef v_Pgm_m mangle_path
323 ; writeIORef v_Pgm_s split_path
324 ; writeIORef v_Pgm_a as_path
325 ; writeIORef v_Pgm_l ld_path
326 ; writeIORef v_Pgm_MkDLL mkdll_path
327 ; writeIORef v_Pgm_T touch_path
328 ; writeIORef v_Pgm_CP cp_path
334 setPgm is called when a command-line option like
336 is used to override a particular program with a new onw
339 setPgm :: String -> IO ()
340 -- The string is the flag, minus the '-pgm' prefix
341 -- So the first character says which program to override
343 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
344 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
345 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
346 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
347 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
348 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
349 setPgm pgm = unknownFlagErr ("-pgm" ++ pgm)
355 -- for "installed" this is the root of GHC's support files
356 -- for "in-place" it is the root of the build tree
359 -- 1. Set proto_top_dir
360 -- a) look for (the last) -B flag, and use it
361 -- b) if there are no -B flags, get the directory
362 -- where GHC is running (only on Windows)
364 -- 2. If package.conf exists in proto_top_dir, we are running
365 -- installed; and TopDir = proto_top_dir
367 -- 3. Otherwise we are running in-place, so
368 -- proto_top_dir will be /...stuff.../ghc/compiler
369 -- Set TopDir to /...stuff..., which is the root of the build tree
371 -- This is very gruesome indeed
373 findTopDir :: [String]
374 -> IO (Bool, -- True <=> am installed, False <=> in-place
375 String) -- TopDir (in Unix format '/' separated)
378 = do { top_dir <- get_proto
379 -- Discover whether we're running in a build tree or in an installation,
380 -- by looking for the package configuration file.
381 ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
383 ; return (am_installed, top_dir)
386 -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
387 get_proto | not (null minusbs)
388 = return (unDosifyPath (drop 2 (last minusbs))) -- 2 for "-B"
390 = do { maybe_exec_dir <- getExecDir -- Get directory of executable
391 ; case maybe_exec_dir of -- (only works on Windows;
392 -- returns Nothing on Unix)
393 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
394 Just dir -> return dir
399 %************************************************************************
401 \subsection{Command-line options}
403 %************************************************************************
405 When invoking external tools as part of the compilation pipeline, we
406 pass these a sequence of options on the command-line. Rather than
407 just using a list of Strings, we use a type that allows us to distinguish
408 between filepaths and 'other stuff'. [The reason being, of course, that
409 this type gives us a handle on transforming filenames, and filenames only,
410 to whatever format they're expected to be on a particular platform.]
418 showOptions :: [Option] -> String
419 showOptions ls = unwords (map (quote.showOpt) ls)
421 showOpt (FileOption f) = dosifyPath f
422 showOpt (Option s) = s
424 #if defined(mingw32_TARGET_OS)
426 quote s = "\"" ++ s ++ "\""
434 %************************************************************************
436 \subsection{Running an external program}
438 %************************************************************************
442 runUnlit :: [Option] -> IO ()
443 runUnlit args = do p <- readIORef v_Pgm_L
444 runSomething "Literate pre-processor" p args
446 runCpp :: [Option] -> IO ()
447 runCpp args = do p <- readIORef v_Pgm_P
448 runSomething "C pre-processor" p args
450 runCc :: [Option] -> IO ()
451 runCc args = do p <- readIORef v_Pgm_c
452 runSomething "C Compiler" p args
454 runMangle :: [Option] -> IO ()
455 runMangle args = do p <- readIORef v_Pgm_m
456 runSomething "Mangler" p args
458 runSplit :: [Option] -> IO ()
459 runSplit args = do p <- readIORef v_Pgm_s
460 runSomething "Splitter" p args
462 runAs :: [Option] -> IO ()
463 runAs args = do p <- readIORef v_Pgm_a
464 runSomething "Assembler" p args
466 runLink :: [Option] -> IO ()
467 runLink args = do p <- readIORef v_Pgm_l
468 runSomething "Linker" p args
470 runMkDLL :: [Option] -> IO ()
471 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
472 runSomething "Make DLL" p args
474 touch :: String -> String -> IO ()
475 touch purpose arg = do p <- readIORef v_Pgm_T
476 runSomething purpose p [FileOption arg]
478 copy :: String -> String -> String -> IO ()
479 copy purpose from to = do
480 verb <- dynFlag verbosity
481 when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
483 h <- openFile to WriteMode
484 ls <- readFile from -- inefficient, but it'll do for now.
485 -- ToDo: speed up via slurping.
491 getSysMan :: IO String -- How to invoke the system manager
492 -- (parallel system only)
493 getSysMan = readIORef v_Pgm_sysman
496 %************************************************************************
498 \subsection{GHC Usage message}
500 %************************************************************************
502 Show the usage message and exit
505 showGhcUsage = do { usage_path <- readIORef v_Path_usage
506 ; usage <- readFile usage_path
508 ; exitWith ExitSuccess }
511 dump ('$':'$':s) = hPutStr stderr progName >> dump s
512 dump (c:s) = hPutChar stderr c >> dump s
516 %************************************************************************
518 \subsection{Managing temporary files
520 %************************************************************************
523 GLOBAL_VAR(v_FilesToClean, [], [String] )
524 GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
525 -- v_TmpDir has no closing '/'
529 setTmpDir dir = writeIORef v_TmpDir dir
531 cleanTempFiles :: Int -> IO ()
532 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
533 removeTmpFiles verb fs
535 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
536 cleanTempFilesExcept verb dont_delete
537 = do fs <- readIORef v_FilesToClean
538 let leftovers = filter (`notElem` dont_delete) fs
539 removeTmpFiles verb leftovers
540 writeIORef v_FilesToClean dont_delete
543 -- find a temporary name that doesn't already exist.
544 newTempName :: Suffix -> IO FilePath
546 = do x <- getProcessID
547 tmp_dir <- readIORef v_TmpDir
548 findTempName tmp_dir x
550 findTempName tmp_dir x
551 = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
552 b <- doesFileExist filename
553 if b then findTempName tmp_dir (x+1)
554 else do add v_FilesToClean filename -- clean it up later
557 addFilesToClean :: [FilePath] -> IO ()
558 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
559 addFilesToClean files = mapM_ (add v_FilesToClean) files
561 removeTmpFiles :: Int -> [FilePath] -> IO ()
562 removeTmpFiles verb fs
563 = traceCmd "Deleting temp files"
564 ("Deleting: " ++ unwords fs)
567 rm f = removeFile f `catchAllIO`
570 hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
576 %************************************************************************
578 \subsection{Running a program}
580 %************************************************************************
583 GLOBAL_VAR(v_Dry_run, False, Bool)
586 setDryRun = writeIORef v_Dry_run True
588 -----------------------------------------------------------------------------
589 -- Running an external program
591 runSomething :: String -- For -v message
592 -> String -- Command name (possibly a full path)
593 -- assumed already dos-ified
594 -> [Option] -- Arguments
595 -- runSomething will dos-ify them
598 runSomething phase_name pgm args
599 = traceCmd phase_name cmd_line $
601 #ifndef mingw32_TARGET_OS
602 exit_code <- system cmd_line
604 exit_code <- rawSystem cmd_line
606 ; if exit_code /= ExitSuccess
607 then throwDyn (PhaseFailed phase_name exit_code)
611 cmd_line = pgm ++ ' ':showOptions args -- unwords (pgm : dosifyPaths (map quote args))
612 -- The pgm is already in native format (appropriate dir separators)
613 #if defined(mingw32_TARGET_OS)
615 quote s = "\"" ++ s ++ "\""
620 traceCmd :: String -> String -> IO () -> IO ()
621 -- a) trace the command (at two levels of verbosity)
622 -- b) don't do it at all if dry-run is set
623 traceCmd phase_name cmd_line action
624 = do { verb <- dynFlag verbosity
625 ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
626 ; when (verb >= 3) $ hPutStrLn stderr cmd_line
630 ; n <- readIORef v_Dry_run
634 ; action `catchAllIO` handle_exn verb
637 handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
638 ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
639 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
643 %************************************************************************
645 \subsection{Path names}
647 %************************************************************************
649 We maintain path names in Unix form ('/'-separated) right until
650 the last moment. On Windows we dos-ify them just before passing them
651 to the Windows command.
653 The alternative, of using '/' consistently on Unix and '\' on Windows,
654 proved quite awkward. There were a lot more calls to dosifyPath,
655 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
656 interpreted a command line 'foo\baz' as 'foobaz'.
659 -----------------------------------------------------------------------------
660 -- Convert filepath into MSDOS form.
662 dosifyPaths :: [String] -> [String]
663 -- dosifyPaths does two things
664 -- a) change '/' to '\'
665 -- b) remove initial '/cygdrive/'
667 unDosifyPath :: String -> String
668 -- Just change '\' to '/'
670 pgmPath :: String -- Directory string in Unix format
671 -> String -- Program name with no directory separators
673 -> String -- Program invocation string in native format
677 #if defined(mingw32_TARGET_OS)
679 --------------------- Windows version ------------------
680 dosifyPaths xs = map dosifyPath xs
682 unDosifyPath xs = subst '\\' '/' xs
684 pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm
687 = subst '/' '\\' real_stuff
689 -- fully convince myself that /cygdrive/ prefixes cannot
690 -- really appear here.
691 cygdrive_prefix = "/cygdrive/"
694 | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
699 --------------------- Unix version ---------------------
702 pgmPath dir pgm = dir ++ '/' : pgm
703 dosifyPath stuff = stuff
704 --------------------------------------------------------
707 subst a b ls = map (\ x -> if x == a then b else x) ls
711 -----------------------------------------------------------------------------
712 Path name construction
715 slash :: String -> String -> String
716 absPath, relPath :: [String] -> String
719 isSlash other = False
722 relPath xs = foldr1 slash xs
724 absPath xs = "" `slash` relPath xs
726 slash s1 s2 = s1 ++ ('/' : s2)
730 %************************************************************************
732 \subsection{Support code}
734 %************************************************************************
737 -----------------------------------------------------------------------------
738 -- Define getExecDir :: IO (Maybe String)
740 #if defined(mingw32_TARGET_OS)
741 getExecDir :: IO (Maybe String)
742 getExecDir = do let len = 2048 -- plenty, PATH_MAX is 512 under Win32.
743 buf <- mallocArray (fromIntegral len)
744 ret <- getModuleFileName nullAddr buf len
745 if ret == 0 then return Nothing
746 else do s <- peekCString buf
747 destructArray (fromIntegral len) buf
748 return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))
751 foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int32 -> IO Int32
753 getExecDir :: IO (Maybe String) = do return Nothing
756 #ifdef mingw32_TARGET_OS
757 foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
759 getProcessID :: IO Int
760 getProcessID = Posix.getProcessID