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, -- [String] -> IO ()
21 runMangle, runSplit, -- [String] -> IO ()
22 runAs, runLink, -- [String] -> 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 Int
40 showGhcUsage, -- IO () Shows usage message and exits
41 getSysMan -- IO String Parallel system only
48 import Panic ( progName, GhcException(..) )
49 import Util ( global )
50 import CmdLineOpts ( dynFlag, verbosity )
52 import Exception ( throwDyn, catchAllIO )
54 import Directory ( doesFileExist, removeFile )
55 import IOExts ( IORef, readIORef, writeIORef )
56 import Monad ( when, unless )
57 import System ( system, ExitCode(..), exitWith, getEnv )
62 #include "../includes/config.h"
64 #if !defined(mingw32_TARGET_OS)
65 import qualified Posix
67 import List ( isPrefixOf )
71 #include "HsVersions.h"
76 The configuration story
77 ~~~~~~~~~~~~~~~~~~~~~~~
79 GHC needs various support files (library packages, RTS etc), plus
80 various auxiliary programs (cp, gcc, etc). It finds these in one
83 * When running as an *installed program*, GHC finds most of this support
84 stuff in the installed library tree. The path to this tree is passed
85 to GHC via the -B flag, and given to initSysTools .
87 * When running *in-place* in a build tree, GHC finds most of this support
88 stuff in the build tree. The path to the build tree is, again passed
91 GHC tells which of the two is the case by seeing whether package.conf
92 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
95 SysTools.initSysProgs figures out exactly where all the auxiliary programs
96 are, and initialises mutable variables to make it easy to call them.
97 To to this, it makes use of definitions in Config.hs, which is a Haskell
98 file containing variables whose value is figured out by the build system.
100 Config.hs contains two sorts of things
102 cGCC, The *names* of the programs
105 etc They do *not* include paths
108 cUNLIT_DIR The *path* to the directory containing unlit, split etc
109 cSPLIT_DIR *relative* to the root of the build tree,
110 for use when running *in-place* in a build tree (only)
114 ---------------------------------------------
115 NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
117 Another hair-brained scheme for simplifying the current tool location
118 nightmare in GHC: Simon originally suggested using another
119 configuration file along the lines of GCC's specs file - which is fine
120 except that it means adding code to read yet another configuration
121 file. What I didn't notice is that the current package.conf is
122 general enough to do this:
125 {name = "tools", import_dirs = [], source_dirs = [],
126 library_dirs = [], hs_libraries = [], extra_libraries = [],
127 include_dirs = [], c_includes = [], package_deps = [],
128 extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${libdir}/bin/unlit", ... etc.],
129 extra_cc_opts = [], extra_ld_opts = []}
131 Which would have the advantage that we get to collect together in one
132 place the path-specific package stuff with the path-specific tool
135 ---------------------------------------------
138 %************************************************************************
140 \subsection{Global variables to contain system programs}
142 %************************************************************************
144 All these pathnames are maintained IN THE NATIVE FORMAT OF THE HOST MACHINE.
145 (See remarks under pathnames below)
148 GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit
149 GLOBAL_VAR(v_Pgm_P, error "pgm_P", String) -- cpp
150 GLOBAL_VAR(v_Pgm_c, error "pgm_c", String) -- gcc
151 GLOBAL_VAR(v_Pgm_m, error "pgm_m", String) -- asm code mangler
152 GLOBAL_VAR(v_Pgm_s, error "pgm_s", String) -- asm code splitter
153 GLOBAL_VAR(v_Pgm_a, error "pgm_a", String) -- as
154 GLOBAL_VAR(v_Pgm_l, error "pgm_l", String) -- ld
155 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String) -- mkdll
157 GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
158 GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
160 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
161 GLOBAL_VAR(v_Path_usage, error "ghc_usage.txt", String)
163 -- Parallel system only
164 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
168 %************************************************************************
170 \subsection{Initialisation}
172 %************************************************************************
175 initSysTools :: [String] -- Command-line arguments starting "-B"
177 -> IO String -- Set all the mutable variables above, holding
178 -- (a) the system programs
179 -- (b) the package-config file
180 -- (c) the GHC usage message
184 initSysTools minusB_args
185 = do { (am_installed, top_dir) <- getTopDir minusB_args
187 -- for "installed" this is the root of GHC's support files
188 -- for "in-place" it is the root of the build tree
189 -- NB: top_dir is assumed to be in standard Unix format '/' separated
191 ; let installed, installed_bin :: FilePath -> FilePath
192 installed_bin pgm = pgmPath (top_dir `slash` "extra-bin") pgm
193 installed file = pgmPath top_dir file
194 inplace dir pgm = pgmPath (top_dir `slash` dir) pgm
197 | am_installed = installed "package.conf"
198 | otherwise = inplace cGHC_DRIVER_DIR "package.conf.inplace"
201 | am_installed = installed "ghc-usage.txt"
202 | otherwise = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
204 -- For all systems, unlit, split, mangle are GHC utilities
205 -- architecture-specific stuff is done when building Config.hs
207 | am_installed = installed_bin cGHC_UNLIT
208 | otherwise = inplace cGHC_UNLIT_DIR cGHC_UNLIT
210 -- split and mangle are Perl scripts
212 | am_installed = installed_bin cGHC_SPLIT
213 | otherwise = inplace cGHC_SPLIT_DIR cGHC_SPLIT
216 | am_installed = installed_bin cGHC_MANGLER
217 | otherwise = inplace cGHC_MANGLER_DIR cGHC_MANGLER
219 #ifndef mingw32_TARGET_OS
220 -- check whether TMPDIR is set in the environment
221 ; IO.try (do dir <- getEnv "TMPDIR" -- fails if not set
227 -- Check that the package config exists
228 ; config_exists <- doesFileExist pkgconfig_path
229 ; when (not config_exists) $
230 throwDyn (InstallationError
231 ("Can't find package.conf as " ++ pkgconfig_path))
233 #if defined(mingw32_TARGET_OS)
234 -- WINDOWS-SPECIFIC STUFF
235 -- On Windows, gcc and friends are distributed with GHC,
236 -- so when "installed" we look in TopDir/bin
237 -- When "in-place" we look wherever the build-time configure
239 -- When "install" we tell gcc where its specs file + exes are (-B)
240 -- and also some places to pick up include files. We need
241 -- to be careful to put all necessary exes in the -B place
242 -- (as, ld, cc1, etc) since if they don't get found there, gcc
243 -- then tries to run unadorned "as", "ld", etc, and will
244 -- pick up whatever happens to be lying around in the path,
245 -- possibly including those from a cygwin install on the target,
246 -- which is exactly what we're trying to avoid.
247 ; let gcc_path | am_installed = installed_bin ("gcc -B\"" ++ installed "gcc-lib/\"")
249 -- The trailing "/" is absolutely essential; gcc seems
250 -- to construct file names simply by concatenating to this
251 -- -B path with no extra slash
252 -- We use "/" rather than "\\" because otherwise "\\\" is mangled
253 -- later on; although gcc_path is in NATIVE format, gcc can cope
254 -- (see comments with declarations of global variables)
256 -- The quotes round the -B argument are in case TopDir has spaces in it
258 perl_path | am_installed = installed_bin cGHC_PERL
259 | otherwise = cGHC_PERL
261 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
262 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY
263 | otherwise = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
265 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
266 -- a call to Perl to get the invocation of split and mangle
267 ; let split_path = perl_path ++ " \"" ++ split_script ++ "\""
268 mangle_path = perl_path ++ " \"" ++ mangle_script ++ "\""
270 ; let mkdll_path = cMKDLL
272 -- UNIX-SPECIFIC STUFF
273 -- On Unix, the "standard" tools are assumed to be
274 -- in the same place whether we are running "in-place" or "installed"
275 -- That place is wherever the build-time configure script found them.
276 ; let gcc_path = cGCC
277 touch_path = cGHC_TOUCHY
278 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
280 -- On Unix, scripts are invoked using the '#!' method. Binary
281 -- installations of GHC on Unix place the correct line on the front
282 -- of the script at installation time, so we don't want to wire-in
283 -- our knowledge of $(PERL) on the host system here.
284 ; let split_path = split_script
285 mangle_path = mangle_script
288 -- cpp is derived from gcc on all platforms
289 ; let cpp_path = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
291 -- For all systems, copy and remove are provided by the host
292 -- system; architecture-specific stuff is done when building Config.hs
293 ; let cp_path = cGHC_CP
295 -- Other things being equal, as and ld are simply gcc
296 ; let as_path = gcc_path
300 -- Initialise the global vars
301 ; writeIORef v_Path_package_config pkgconfig_path
302 ; writeIORef v_Path_usage ghc_usage_msg_path
304 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
305 -- Hans: this isn't right in general, but you can
306 -- elaborate it in the same way as the others
308 ; writeIORef v_Pgm_L unlit_path
309 ; writeIORef v_Pgm_P cpp_path
310 ; writeIORef v_Pgm_c gcc_path
311 ; writeIORef v_Pgm_m mangle_path
312 ; writeIORef v_Pgm_s split_path
313 ; writeIORef v_Pgm_a as_path
314 ; writeIORef v_Pgm_l ld_path
315 ; writeIORef v_Pgm_MkDLL mkdll_path
316 ; writeIORef v_Pgm_T touch_path
317 ; writeIORef v_Pgm_CP cp_path
323 setPgm is called when a command-line option like
325 is used to override a particular program with a new onw
328 setPgm :: String -> IO ()
329 -- The string is the flag, minus the '-pgm' prefix
330 -- So the first character says which program to override
332 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
333 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
334 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
335 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
336 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
337 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
338 setPgm pgm = unknownFlagErr ("-pgm" ++ pgm)
344 -- for "installed" this is the root of GHC's support files
345 -- for "in-place" it is the root of the build tree
348 -- 1. Set proto_top_dir
349 -- a) look for (the last) -B flag, and use it
350 -- b) if there are no -B flags, get the directory
351 -- where GHC is running (only on Windows)
353 -- 2. If package.conf exists in proto_top_dir, we are running
354 -- installed; and TopDir = proto_top_dir
356 -- 3. Otherwise we are running in-place, so
357 -- proto_top_dir will be /...stuff.../ghc/compiler
358 -- Set TopDir to /...stuff..., which is the root of the build tree
360 -- This is very gruesome indeed
362 getTopDir :: [String]
363 -> IO (Bool, -- True <=> am installed, False <=> in-place
364 String) -- TopDir (in Unix format '/' separated)
367 = do { top_dir <- get_proto
368 -- Discover whether we're running in a build tree or in an installation,
369 -- by looking for the package configuration file.
370 ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
372 ; return (am_installed, top_dir)
375 -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
376 get_proto | not (null minusbs)
377 = return (unDosifyPath (drop 2 (last minusbs))) -- 2 for "-B"
379 = do { maybe_exec_dir <- getExecDir -- Get directory of executable
380 ; case maybe_exec_dir of -- (only works on Windows;
381 -- returns Nothing on Unix)
382 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
383 Just dir -> return dir
388 %************************************************************************
390 \subsection{Running an external program}
392 %************************************************************************
396 runUnlit :: [String] -> IO ()
397 runUnlit args = do p <- readIORef v_Pgm_L
398 runSomething "Literate pre-processor" p args
400 runCpp :: [String] -> IO ()
401 runCpp args = do p <- readIORef v_Pgm_P
402 runSomething "C pre-processor" p args
404 runCc :: [String] -> IO ()
405 runCc args = do p <- readIORef v_Pgm_c
406 runSomething "C Compiler" p args
408 runMangle :: [String] -> IO ()
409 runMangle args = do p <- readIORef v_Pgm_m
410 runSomething "Mangler" p args
412 runSplit :: [String] -> IO ()
413 runSplit args = do p <- readIORef v_Pgm_s
414 runSomething "Splitter" p args
416 runAs :: [String] -> IO ()
417 runAs args = do p <- readIORef v_Pgm_a
418 runSomething "Assembler" p args
420 runLink :: [String] -> IO ()
421 runLink args = do p <- readIORef v_Pgm_l
422 runSomething "Linker" p args
424 runMkDLL :: [String] -> IO ()
425 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
426 runSomething "Make DLL" p args
428 touch :: String -> String -> IO ()
429 touch purpose arg = do p <- readIORef v_Pgm_T
430 runSomething purpose p [arg]
432 copy :: String -> String -> String -> IO ()
433 copy purpose from to = do
434 verb <- dynFlag verbosity
435 when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
437 h <- openFile to WriteMode
438 ls <- readFile from -- inefficient, but it'll do for now.
439 -- ToDo: speed up via slurping.
445 getSysMan :: IO String -- How to invoke the system manager
446 -- (parallel system only)
447 getSysMan = readIORef v_Pgm_sysman
450 %************************************************************************
452 \subsection{GHC Usage message}
454 %************************************************************************
456 Show the usage message and exit
459 showGhcUsage = do { usage_path <- readIORef v_Path_usage
460 ; usage <- readFile usage_path
462 ; exitWith ExitSuccess }
465 dump ('$':'$':s) = hPutStr stderr progName >> dump s
466 dump (c:s) = hPutChar stderr c >> dump s
468 packageConfigPath = readIORef v_Path_package_config
472 %************************************************************************
474 \subsection{Managing temporary files
476 %************************************************************************
479 GLOBAL_VAR(v_FilesToClean, [], [String] )
480 GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
481 -- v_TmpDir has no closing '/'
485 setTmpDir dir = writeIORef v_TmpDir dir
487 cleanTempFiles :: Int -> IO ()
488 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
489 removeTmpFiles verb fs
491 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
492 cleanTempFilesExcept verb dont_delete
493 = do fs <- readIORef v_FilesToClean
494 let leftovers = filter (`notElem` dont_delete) fs
495 removeTmpFiles verb leftovers
496 writeIORef v_FilesToClean dont_delete
499 -- find a temporary name that doesn't already exist.
500 newTempName :: Suffix -> IO FilePath
502 = do x <- getProcessID
503 tmp_dir <- readIORef v_TmpDir
504 findTempName tmp_dir x
506 findTempName tmp_dir x
507 = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
508 b <- doesFileExist filename
509 if b then findTempName tmp_dir (x+1)
510 else do add v_FilesToClean filename -- clean it up later
513 addFilesToClean :: [FilePath] -> IO ()
514 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
515 addFilesToClean files = mapM_ (add v_FilesToClean) files
517 removeTmpFiles :: Int -> [FilePath] -> IO ()
518 removeTmpFiles verb fs
519 = traceCmd "Deleting temp files"
520 ("Deleting: " ++ unwords fs)
523 rm f = removeFile f `catchAllIO`
526 hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
532 %************************************************************************
534 \subsection{Running a program}
536 %************************************************************************
539 GLOBAL_VAR(v_Dry_run, False, Bool)
542 setDryRun = writeIORef v_Dry_run True
544 -----------------------------------------------------------------------------
545 -- Running an external program
547 runSomething :: String -- For -v message
548 -> String -- Command name (possibly a full path)
549 -- assumed already dos-ified
550 -> [String] -- Arguments
551 -- runSomething will dos-ify them
554 runSomething phase_name pgm args
555 = traceCmd phase_name cmd_line $
556 do { exit_code <- system cmd_line
557 ; if exit_code /= ExitSuccess
558 then throwDyn (PhaseFailed phase_name exit_code)
562 cmd_line = unwords (pgm : dosifyPaths (map quote args))
563 -- The pgm is already in native format (appropriate dir separators)
564 #if defined(mingw32_TARGET_OS)
566 quote s = "\"" ++ s ++ "\""
571 traceCmd :: String -> String -> IO () -> IO ()
572 -- a) trace the command (at two levels of verbosity)
573 -- b) don't do it at all if dry-run is set
574 traceCmd phase_name cmd_line action
575 = do { verb <- dynFlag verbosity
576 ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
577 ; when (verb >= 3) $ hPutStrLn stderr cmd_line
581 ; n <- readIORef v_Dry_run
585 ; action `catchAllIO` handle_exn verb
588 handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
589 ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
590 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
594 %************************************************************************
596 \subsection{Path names}
598 %************************************************************************
600 We maintain path names in Unix form ('/'-separated) right until
601 the last moment. On Windows we dos-ify them just before passing them
602 to the Windows command.
604 The alternative, of using '/' consistently on Unix and '\' on Windows,
605 proved quite awkward. There were a lot more calls to dosifyPath,
606 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
607 interpreted a command line 'foo\baz' as 'foobaz'.
610 -----------------------------------------------------------------------------
611 -- Convert filepath into MSDOS form.
613 dosifyPaths :: [String] -> [String]
614 -- dosifyPaths does two things
615 -- a) change '/' to '\'
616 -- b) remove initial '/cygdrive/'
618 unDosifyPath :: String -> String
619 -- Just change '\' to '/'
621 pgmPath :: String -- Directory string in Unix format
622 -> String -- Program name with no directory separators
624 -> String -- Program invocation string in native format
628 #if defined(mingw32_TARGET_OS)
630 --------------------- Windows version ------------------
631 dosifyPaths xs = map dosifyPath xs
633 unDosifyPath xs = subst '\\' '/' xs
635 pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm
638 = subst '/' '\\' real_stuff
640 -- fully convince myself that /cygdrive/ prefixes cannot
641 -- really appear here.
642 cygdrive_prefix = "/cygdrive/"
645 | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
650 --------------------- Unix version ---------------------
653 pgmPath dir pgm = dir ++ '/' : pgm
654 --------------------------------------------------------
657 subst a b ls = map (\ x -> if x == a then b else x) ls
661 -----------------------------------------------------------------------------
662 Path name construction
665 slash :: String -> String -> String
666 absPath, relPath :: [String] -> String
669 isSlash other = False
672 relPath xs = foldr1 slash xs
674 absPath xs = "" `slash` relPath xs
676 slash s1 s2 = s1 ++ ('/' : s2)
680 %************************************************************************
682 \subsection{Support code}
684 %************************************************************************
687 -----------------------------------------------------------------------------
688 -- Define getExecDir :: IO (Maybe String)
690 #if defined(mingw32_TARGET_OS)
691 getExecDir :: IO (Maybe String)
692 getExecDir = do let len = 2048 -- plenty, PATH_MAX is 512 under Win32.
693 buf <- mallocArray (fromIntegral len)
694 ret <- getModuleFileName nullAddr buf len
695 if ret == 0 then return Nothing
696 else do s <- peekCString buf
697 destructArray (fromIntegral len) buf
698 return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath s)))))
701 foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int32 -> IO Int32
703 getExecDir :: IO (Maybe String) = do return Nothing
706 #ifdef mingw32_TARGET_OS
707 foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
709 getProcessID :: IO Int
710 getProcessID = Posix.getProcessID