1 -----------------------------------------------------------------------------
2 -- Access to system tools: gcc, cp, rm etc
4 -- (c) The University of Glasgow 2000
6 -----------------------------------------------------------------------------
12 setPgm, -- String -> IO ()
13 -- Command-line override
16 packageConfigPath, -- IO String
17 -- Where package.conf is
19 -- Interface to system tools
20 runUnlit, runCpp, runCc, -- [Option] -> IO ()
21 runMangle, runSplit, -- [Option] -> IO ()
22 runAs, runLink, -- [Option] -> IO ()
25 touch, -- String -> String -> IO ()
26 copy, -- String -> String -> String -> IO ()
27 unDosifyPath, -- String -> String
29 -- Temporary-file management
32 cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
36 getProcessID, -- IO Int
37 system, -- String -> IO ExitCode
40 showGhcUsage, -- IO () Shows usage message and exits
41 getSysMan, -- IO String Parallel system only
50 import Panic ( progName, GhcException(..) )
51 import Util ( global )
52 import CmdLineOpts ( dynFlag, verbosity )
54 import Exception ( throwDyn, catchAllIO )
56 import Directory ( doesFileExist, removeFile )
57 import IOExts ( IORef, readIORef, writeIORef )
58 import Monad ( when, unless )
59 import System ( ExitCode(..), exitWith, getEnv, system )
64 #include "../includes/config.h"
66 #ifndef mingw32_TARGET_OS
67 import qualified Posix
69 import List ( isPrefixOf )
71 import SystemExts ( rawSystem )
74 #include "HsVersions.h"
79 The configuration story
80 ~~~~~~~~~~~~~~~~~~~~~~~
82 GHC needs various support files (library packages, RTS etc), plus
83 various auxiliary programs (cp, gcc, etc). It finds these in one
86 * When running as an *installed program*, GHC finds most of this support
87 stuff in the installed library tree. The path to this tree is passed
88 to GHC via the -B flag, and given to initSysTools .
90 * When running *in-place* in a build tree, GHC finds most of this support
91 stuff in the build tree. The path to the build tree is, again passed
94 GHC tells which of the two is the case by seeing whether package.conf
95 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
98 SysTools.initSysProgs figures out exactly where all the auxiliary programs
99 are, and initialises mutable variables to make it easy to call them.
100 To to this, it makes use of definitions in Config.hs, which is a Haskell
101 file containing variables whose value is figured out by the build system.
103 Config.hs contains two sorts of things
105 cGCC, The *names* of the programs
108 etc They do *not* include paths
111 cUNLIT_DIR The *path* to the directory containing unlit, split etc
112 cSPLIT_DIR *relative* to the root of the build tree,
113 for use when running *in-place* in a build tree (only)
117 ---------------------------------------------
118 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
120 Another hair-brained scheme for simplifying the current tool location
121 nightmare in GHC: Simon originally suggested using another
122 configuration file along the lines of GCC's specs file - which is fine
123 except that it means adding code to read yet another configuration
124 file. What I didn't notice is that the current package.conf is
125 general enough to do this:
128 {name = "tools", import_dirs = [], source_dirs = [],
129 library_dirs = [], hs_libraries = [], extra_libraries = [],
130 include_dirs = [], c_includes = [], package_deps = [],
131 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${libdir}/bin/unlit", ... etc.],
132 extra_cc_opts = [], extra_ld_opts = []}
134 Which would have the advantage that we get to collect together in one
135 place the path-specific package stuff with the path-specific tool
138 ---------------------------------------------
141 %************************************************************************
143 \subsection{Global variables to contain system programs}
145 %************************************************************************
147 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
148 (See remarks under pathnames below)
151 GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit
152 GLOBAL_VAR(v_Pgm_P, error "pgm_P", String) -- cpp
153 GLOBAL_VAR(v_Pgm_c, error "pgm_c", String) -- gcc
154 GLOBAL_VAR(v_Pgm_m, error "pgm_m", String) -- asm code mangler
155 GLOBAL_VAR(v_Pgm_s, error "pgm_s", String) -- asm code splitter
156 GLOBAL_VAR(v_Pgm_a, error "pgm_a", String) -- as
157 GLOBAL_VAR(v_Pgm_l, error "pgm_l", String) -- ld
158 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String) -- mkdll
160 GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
161 GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
163 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
164 GLOBAL_VAR(v_Path_usage, error "ghc_usage.txt", String)
166 -- Parallel system only
167 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
171 %************************************************************************
173 \subsection{Initialisation}
175 %************************************************************************
178 initSysTools :: [String] -- Command-line arguments starting "-B"
180 -> IO String -- Set all the mutable variables above, holding
181 -- (a) the system programs
182 -- (b) the package-config file
183 -- (c) the GHC usage message
187 initSysTools minusB_args
188 = do { (am_installed, top_dir) <- getTopDir minusB_args
190 -- for "installed" this is the root of GHC's support files
191 -- for "in-place" it is the root of the build tree
192 -- NB: top_dir is assumed to be in standard Unix format '/' separated
194 ; let installed, installed_bin :: FilePath -> FilePath
195 installed_bin pgm = pgmPath (top_dir `slash` "extra-bin") pgm
196 installed file = pgmPath top_dir file
197 inplace dir pgm = pgmPath (top_dir `slash` dir) pgm
200 | am_installed = installed "package.conf"
201 | otherwise = inplace cGHC_DRIVER_DIR "package.conf.inplace"
204 | am_installed = installed "ghc-usage.txt"
205 | otherwise = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
207 -- For all systems, unlit, split, mangle are GHC utilities
208 -- architecture-specific stuff is done when building Config.hs
210 | am_installed = installed_bin cGHC_UNLIT
211 | otherwise = inplace cGHC_UNLIT_DIR cGHC_UNLIT
213 -- split and mangle are Perl scripts
215 | am_installed = installed_bin cGHC_SPLIT
216 | otherwise = inplace cGHC_SPLIT_DIR cGHC_SPLIT
219 | am_installed = installed_bin cGHC_MANGLER
220 | otherwise = inplace cGHC_MANGLER_DIR cGHC_MANGLER
222 #ifndef mingw32_TARGET_OS
223 -- check whether TMPDIR is set in the environment
224 ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
230 -- Check that the package config exists
231 ; config_exists <- doesFileExist pkgconfig_path
232 ; when (not config_exists) $
233 throwDyn (InstallationError
234 ("Can't find package.conf as " ++ pkgconfig_path))
236 #if defined(mingw32_TARGET_OS)
237 -- WINDOWS-SPECIFIC STUFF
238 -- On Windows, gcc and friends are distributed with GHC,
239 -- so when "installed" we look in TopDir/bin
240 -- When "in-place" we look wherever the build-time configure
242 -- When "install" we tell gcc where its specs file + exes are (-B)
243 -- and also some places to pick up include files. We need
244 -- to be careful to put all necessary exes in the -B place
245 -- (as, ld, cc1, etc) since if they don't get found there, gcc
246 -- then tries to run unadorned "as", "ld", etc, and will
247 -- pick up whatever happens to be lying around in the path,
248 -- possibly including those from a cygwin install on the target,
249 -- which is exactly what we're trying to avoid.
250 ; let gcc_path | am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
252 -- The trailing "/" is absolutely essential; gcc seems
253 -- to construct file names simply by concatenating to this
254 -- -B path with no extra slash
255 -- We use "/" rather than "\\" because otherwise "\\\" is mangled
256 -- later on; although gcc_path is in NATIVE format, gcc can cope
257 -- (see comments with declarations of global variables)
259 -- The quotes round the -B argument are in case TopDir has spaces in it
261 perl_path | am_installed = installed_bin cGHC_PERL
262 | otherwise = cGHC_PERL
264 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
265 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY
266 | otherwise = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
268 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
269 -- a call to Perl to get the invocation of split and mangle
270 ; let split_path = perl_path ++ " \"" ++ split_script ++ "\""
271 mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
273 ; let mkdll_path = cMKDLL
275 -- UNIX-SPECIFIC STUFF
276 -- On Unix, the "standard" tools are assumed to be
277 -- in the same place whether we are running "in-place" or "installed"
278 -- That place is wherever the build-time configure script found them.
279 ; let gcc_path = cGCC
280 touch_path = cGHC_TOUCHY
281 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
283 -- On Unix, scripts are invoked using the '#!' method. Binary
284 -- installations of GHC on Unix place the correct line on the front
285 -- of the script at installation time, so we don't want to wire-in
286 -- our knowledge of $(PERL) on the host system here.
287 ; let split_path = split_script
288 mangle_path = mangle_script
291 -- cpp is derived from gcc on all platforms
292 ; let cpp_path = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
294 -- For all systems, copy and remove are provided by the host
295 -- system; architecture-specific stuff is done when building Config.hs
296 ; let cp_path = cGHC_CP
298 -- Other things being equal, as and ld are simply gcc
299 ; let as_path = gcc_path
303 -- Initialise the global vars
304 ; writeIORef v_Path_package_config pkgconfig_path
305 ; writeIORef v_Path_usage ghc_usage_msg_path
307 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
308 -- Hans: this isn't right in general, but you can
309 -- elaborate it in the same way as the others
311 ; writeIORef v_Pgm_L unlit_path
312 ; writeIORef v_Pgm_P cpp_path
313 ; writeIORef v_Pgm_c gcc_path
314 ; writeIORef v_Pgm_m mangle_path
315 ; writeIORef v_Pgm_s split_path
316 ; writeIORef v_Pgm_a as_path
317 ; writeIORef v_Pgm_l ld_path
318 ; writeIORef v_Pgm_MkDLL mkdll_path
319 ; writeIORef v_Pgm_T touch_path
320 ; writeIORef v_Pgm_CP cp_path
326 setPgm is called when a command-line option like
328 is used to override a particular program with a new onw
331 setPgm :: String -> IO ()
332 -- The string is the flag, minus the '-pgm' prefix
333 -- So the first character says which program to override
335 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
336 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
337 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
338 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
339 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
340 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
341 setPgm pgm = unknownFlagErr ("-pgm" ++ pgm)
347 -- for "installed" this is the root of GHC's support files
348 -- for "in-place" it is the root of the build tree
351 -- 1. Set proto_top_dir
352 -- a) look for (the last) -B flag, and use it
353 -- b) if there are no -B flags, get the directory
354 -- where GHC is running (only on Windows)
356 -- 2. If package.conf exists in proto_top_dir, we are running
357 -- installed; and TopDir = proto_top_dir
359 -- 3. Otherwise we are running in-place, so
360 -- proto_top_dir will be /...stuff.../ghc/compiler
361 -- Set TopDir to /...stuff..., which is the root of the build tree
363 -- This is very gruesome indeed
365 getTopDir :: [String]
366 -> IO (Bool, -- True <=> am installed, False <=> in-place
367 String) -- TopDir (in Unix format '/' separated)
370 = do { top_dir <- get_proto
371 -- Discover whether we're running in a build tree or in an installation,
372 -- by looking for the package configuration file.
373 ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
375 ; return (am_installed, top_dir)
378 -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
379 get_proto | not (null minusbs)
380 = return (unDosifyPath (drop 2 (last minusbs))) -- 2 for "-B"
382 = do { maybe_exec_dir <- getExecDir -- Get directory of executable
383 ; case maybe_exec_dir of -- (only works on Windows;
384 -- returns Nothing on Unix)
385 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
386 Just dir -> return dir
391 %************************************************************************
393 \subsection{Command-line options}
395 %************************************************************************
397 When invoking external tools as part of the compilation pipeline, we
398 pass these a sequence of options on the command-line. Rather than
399 just using a list of Strings, we use a type that allows us to distinguish
400 between filepaths and 'other stuff'. [The reason being, of course, that
401 this type gives us a handle on transforming filenames, and filenames only,
402 to whatever format they're expected to be on a particular platform.]
410 showOptions :: [Option] -> String
411 showOptions ls = unwords (map (quote.showOpt) ls)
413 showOpt (FileOption f) = dosifyPath f
414 showOpt (Option s) = s
416 #if defined(mingw32_TARGET_OS)
418 quote s = "\"" ++ s ++ "\""
426 %************************************************************************
428 \subsection{Running an external program}
430 %************************************************************************
434 runUnlit :: [Option] -> IO ()
435 runUnlit args = do p <- readIORef v_Pgm_L
436 runSomething "Literate pre-processor" p args
438 runCpp :: [Option] -> IO ()
439 runCpp args = do p <- readIORef v_Pgm_P
440 runSomething "C pre-processor" p args
442 runCc :: [Option] -> IO ()
443 runCc args = do p <- readIORef v_Pgm_c
444 runSomething "C Compiler" p args
446 runMangle :: [Option] -> IO ()
447 runMangle args = do p <- readIORef v_Pgm_m
448 runSomething "Mangler" p args
450 runSplit :: [Option] -> IO ()
451 runSplit args = do p <- readIORef v_Pgm_s
452 runSomething "Splitter" p args
454 runAs :: [Option] -> IO ()
455 runAs args = do p <- readIORef v_Pgm_a
456 runSomething "Assembler" p args
458 runLink :: [Option] -> IO ()
459 runLink args = do p <- readIORef v_Pgm_l
460 runSomething "Linker" p args
462 runMkDLL :: [Option] -> IO ()
463 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
464 runSomething "Make DLL" p args
466 touch :: String -> String -> IO ()
467 touch purpose arg = do p <- readIORef v_Pgm_T
468 runSomething purpose p [FileOption arg]
470 copy :: String -> String -> String -> IO ()
471 copy purpose from to = do
472 verb <- dynFlag verbosity
473 when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
475 h <- openFile to WriteMode
476 ls <- readFile from -- inefficient, but it'll do for now.
477 -- ToDo: speed up via slurping.
483 getSysMan :: IO String -- How to invoke the system manager
484 -- (parallel system only)
485 getSysMan = readIORef v_Pgm_sysman
488 %************************************************************************
490 \subsection{GHC Usage message}
492 %************************************************************************
494 Show the usage message and exit
497 showGhcUsage = do { usage_path <- readIORef v_Path_usage
498 ; usage <- readFile usage_path
500 ; exitWith ExitSuccess }
503 dump ('$':'$':s) = hPutStr stderr progName >> dump s
504 dump (c:s) = hPutChar stderr c >> dump s
506 packageConfigPath = readIORef v_Path_package_config
510 %************************************************************************
512 \subsection{Managing temporary files
514 %************************************************************************
517 GLOBAL_VAR(v_FilesToClean, [], [String] )
518 GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
519 -- v_TmpDir has no closing '/'
523 setTmpDir dir = writeIORef v_TmpDir dir
525 cleanTempFiles :: Int -> IO ()
526 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
527 removeTmpFiles verb fs
529 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
530 cleanTempFilesExcept verb dont_delete
531 = do fs <- readIORef v_FilesToClean
532 let leftovers = filter (`notElem` dont_delete) fs
533 removeTmpFiles verb leftovers
534 writeIORef v_FilesToClean dont_delete
537 -- find a temporary name that doesn't already exist.
538 newTempName :: Suffix -> IO FilePath
540 = do x <- getProcessID
541 tmp_dir <- readIORef v_TmpDir
542 findTempName tmp_dir x
544 findTempName tmp_dir x
545 = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
546 b <- doesFileExist filename
547 if b then findTempName tmp_dir (x+1)
548 else do add v_FilesToClean filename -- clean it up later
551 addFilesToClean :: [FilePath] -> IO ()
552 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
553 addFilesToClean files = mapM_ (add v_FilesToClean) files
555 removeTmpFiles :: Int -> [FilePath] -> IO ()
556 removeTmpFiles verb fs
557 = traceCmd "Deleting temp files"
558 ("Deleting: " ++ unwords fs)
561 rm f = removeFile f `catchAllIO`
564 hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
570 %************************************************************************
572 \subsection{Running a program}
574 %************************************************************************
577 GLOBAL_VAR(v_Dry_run, False, Bool)
580 setDryRun = writeIORef v_Dry_run True
582 -----------------------------------------------------------------------------
583 -- Running an external program
585 runSomething :: String -- For -v message
586 -> String -- Command name (possibly a full path)
587 -- assumed already dos-ified
588 -> [Option] -- Arguments
589 -- runSomething will dos-ify them
592 runSomething phase_name pgm args
593 = traceCmd phase_name cmd_line $
595 #ifndef mingw32_TARGET_OS
596 exit_code <- system cmd_line
598 exit_code <- rawSystem cmd_line
600 ; if exit_code /= ExitSuccess
601 then throwDyn (PhaseFailed phase_name exit_code)
605 cmd_line = pgm ++ ' ':showOptions args -- unwords (pgm : dosifyPaths (map quote args))
606 -- The pgm is already in native format (appropriate dir separators)
607 #if defined(mingw32_TARGET_OS)
609 quote s = "\"" ++ s ++ "\""
614 traceCmd :: String -> String -> IO () -> IO ()
615 -- a) trace the command (at two levels of verbosity)
616 -- b) don't do it at all if dry-run is set
617 traceCmd phase_name cmd_line action
618 = do { verb <- dynFlag verbosity
619 ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
620 ; when (verb >= 3) $ hPutStrLn stderr cmd_line
624 ; n <- readIORef v_Dry_run
628 ; action `catchAllIO` handle_exn verb
631 handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
632 ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
633 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
637 %************************************************************************
639 \subsection{Path names}
641 %************************************************************************
643 We maintain path names in Unix form ('/'-separated) right until
644 the last moment. On Windows we dos-ify them just before passing them
645 to the Windows command.
647 The alternative, of using '/' consistently on Unix and '\' on Windows,
648 proved quite awkward. There were a lot more calls to dosifyPath,
649 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
650 interpreted a command line 'foo\baz' as 'foobaz'.
653 -----------------------------------------------------------------------------
654 -- Convert filepath into MSDOS form.
656 dosifyPaths :: [String] -> [String]
657 -- dosifyPaths does two things
658 -- a) change '/' to '\'
659 -- b) remove initial '/cygdrive/'
661 unDosifyPath :: String -> String
662 -- Just change '\' to '/'
664 pgmPath :: String -- Directory string in Unix format
665 -> String -- Program name with no directory separators
667 -> String -- Program invocation string in native format
671 #if defined(mingw32_TARGET_OS)
673 --------------------- Windows version ------------------
674 dosifyPaths xs = map dosifyPath xs
676 unDosifyPath xs = subst '\\' '/' xs
678 pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm
681 = subst '/' '\\' real_stuff
683 -- fully convince myself that /cygdrive/ prefixes cannot
684 -- really appear here.
685 cygdrive_prefix = "/cygdrive/"
688 | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
693 --------------------- Unix version ---------------------
696 pgmPath dir pgm = dir ++ '/' : pgm
697 dosifyPath stuff = stuff
698 --------------------------------------------------------
701 subst a b ls = map (\ x -> if x == a then b else x) ls
705 -----------------------------------------------------------------------------
706 Path name construction
709 slash :: String -> String -> String
710 absPath, relPath :: [String] -> String
713 isSlash other = False
716 relPath xs = foldr1 slash xs
718 absPath xs = "" `slash` relPath xs
720 slash s1 s2 = s1 ++ ('/' : s2)
724 %************************************************************************
726 \subsection{Support code}
728 %************************************************************************
731 -----------------------------------------------------------------------------
732 -- Define getExecDir :: IO (Maybe String)
734 #if defined(mingw32_TARGET_OS)
735 getExecDir :: IO (Maybe String)
736 getExecDir = do let len = 2048 -- plenty, PATH_MAX is 512 under Win32.
737 buf <- mallocArray (fromIntegral len)
738 ret <- getModuleFileName nullAddr buf len
739 if ret == 0 then return Nothing
740 else do s <- peekCString buf
741 destructArray (fromIntegral len) buf
742 return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))
745 foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int32 -> IO Int32
747 getExecDir :: IO (Maybe String) = do return Nothing
750 #ifdef mingw32_TARGET_OS
751 foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
753 getProcessID :: IO Int
754 getProcessID = Posix.getProcessID