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 )
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 gcc_path is in NATIVE format
253 -- (see comments with declarations of global variables)
255 -- The quotes round the -B argument are in case TopDir has spaces in it
257 perl_path | am_installed = installed_bin cGHC_PERL
258 | otherwise = cGHC_PERL
260 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
261 ; let touch_path | am_installed = installed_bin cGHC_TOUCHY
262 | otherwise = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
264 -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
265 -- a call to Perl to get the invocation of split and mangle
266 ; let split_path = perl_path ++ " " ++ split_script
267 mangle_path = perl_path ++ " " ++ mangle_script
269 ; let mkdll_path = cMKDLL
271 -- UNIX-SPECIFIC STUFF
272 -- On Unix, the "standard" tools are assumed to be
273 -- in the same place whether we are running "in-place" or "installed"
274 -- That place is wherever the build-time configure script found them.
275 ; let gcc_path = cGCC
276 touch_path = cGHC_TOUCHY
277 mkdll_path = panic "Can't build DLLs on a non-Win32 system"
279 -- On Unix, scripts are invoked using the '#!' method. Binary
280 -- installations of GHC on Unix place the correct line on the front
281 -- of the script at installation time, so we don't want to wire-in
282 -- our knowledge of $(PERL) on the host system here.
283 ; let split_path = split_script
284 mangle_path = mangle_script
287 -- cpp is derived from gcc on all platforms
288 ; let cpp_path = gcc_path ++ " -E " ++ cRAWCPP_FLAGS
290 -- For all systems, copy and remove are provided by the host
291 -- system; architecture-specific stuff is done when building Config.hs
292 ; let cp_path = cGHC_CP
294 -- Other things being equal, as and ld are simply gcc
295 ; let as_path = gcc_path
299 -- Initialise the global vars
300 ; writeIORef v_Path_package_config pkgconfig_path
301 ; writeIORef v_Path_usage ghc_usage_msg_path
303 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
304 -- Hans: this isn't right in general, but you can
305 -- elaborate it in the same way as the others
307 ; writeIORef v_Pgm_L unlit_path
308 ; writeIORef v_Pgm_P cpp_path
309 ; writeIORef v_Pgm_c gcc_path
310 ; writeIORef v_Pgm_m mangle_path
311 ; writeIORef v_Pgm_s split_path
312 ; writeIORef v_Pgm_a as_path
313 ; writeIORef v_Pgm_l ld_path
314 ; writeIORef v_Pgm_MkDLL mkdll_path
315 ; writeIORef v_Pgm_T touch_path
316 ; writeIORef v_Pgm_CP cp_path
322 setPgm is called when a command-line option like
324 is used to override a particular program with a new onw
327 setPgm :: String -> IO ()
328 -- The string is the flag, minus the '-pgm' prefix
329 -- So the first character says which program to override
331 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
332 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
333 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
334 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
335 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
336 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
337 setPgm pgm = unknownFlagErr ("-pgm" ++ pgm)
343 -- for "installed" this is the root of GHC's support files
344 -- for "in-place" it is the root of the build tree
347 -- 1. Set proto_top_dir
348 -- a) look for (the last) -B flag, and use it
349 -- b) if there are no -B flags, get the directory
350 -- where GHC is running (only on Windows)
352 -- 2. If package.conf exists in proto_top_dir, we are running
353 -- installed; and TopDir = proto_top_dir
355 -- 3. Otherwise we are running in-place, so
356 -- proto_top_dir will be /...stuff.../ghc/compiler
357 -- Set TopDir to /...stuff..., which is the root of the build tree
359 -- This is very gruesome indeed
361 getTopDir :: [String]
362 -> IO (Bool, -- True <=> am installed, False <=> in-place
363 String) -- TopDir (in Unix format '/' separated)
366 = do { top_dir <- get_proto
367 -- Discover whether we're running in a build tree or in an installation,
368 -- by looking for the package configuration file.
369 ; am_installed <- doesFileExist (top_dir `slash` "package.conf")
371 ; return (am_installed, top_dir)
374 -- get_proto returns a Unix-format path (relying on getExecDir to do so too)
375 get_proto | not (null minusbs)
376 = return (unDosifyPath (drop 2 (last minusbs))) -- 2 for "-B"
378 = do { maybe_exec_dir <- getExecDir -- Get directory of executable
379 ; case maybe_exec_dir of -- (only works on Windows;
380 -- returns Nothing on Unix)
381 Nothing -> throwDyn (InstallationError "missing -B<dir> option")
382 Just dir -> return dir
387 %************************************************************************
389 \subsection{Running an external program}
391 %************************************************************************
395 runUnlit :: [String] -> IO ()
396 runUnlit args = do p <- readIORef v_Pgm_L
397 runSomething "Literate pre-processor" p args
399 runCpp :: [String] -> IO ()
400 runCpp args = do p <- readIORef v_Pgm_P
401 runSomething "C pre-processor" p args
403 runCc :: [String] -> IO ()
404 runCc args = do p <- readIORef v_Pgm_c
405 runSomething "C Compiler" p args
407 runMangle :: [String] -> IO ()
408 runMangle args = do p <- readIORef v_Pgm_m
409 runSomething "Mangler" p args
411 runSplit :: [String] -> IO ()
412 runSplit args = do p <- readIORef v_Pgm_s
413 runSomething "Splitter" p args
415 runAs :: [String] -> IO ()
416 runAs args = do p <- readIORef v_Pgm_a
417 runSomething "Assembler" p args
419 runLink :: [String] -> IO ()
420 runLink args = do p <- readIORef v_Pgm_l
421 runSomething "Linker" p args
423 runMkDLL :: [String] -> IO ()
424 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
425 runSomething "Make DLL" p args
427 touch :: String -> String -> IO ()
428 touch purpose arg = do p <- readIORef v_Pgm_T
429 runSomething purpose p [arg]
431 copy :: String -> String -> String -> IO ()
432 copy purpose from to = do
433 verb <- dynFlag verbosity
434 when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
436 h <- openFile to WriteMode
437 ls <- readFile from -- inefficient, but it'll do for now.
438 -- ToDo: speed up via slurping.
444 getSysMan :: IO String -- How to invoke the system manager
445 -- (parallel system only)
446 getSysMan = readIORef v_Pgm_sysman
449 %************************************************************************
451 \subsection{GHC Usage message}
453 %************************************************************************
455 Show the usage message and exit
458 showGhcUsage = do { usage_path <- readIORef v_Path_usage
459 ; usage <- readFile usage_path
461 ; exitWith ExitSuccess }
464 dump ('$':'$':s) = hPutStr stderr progName >> dump s
465 dump (c:s) = hPutChar stderr c >> dump s
467 packageConfigPath = readIORef v_Path_package_config
471 %************************************************************************
473 \subsection{Managing temporary files
475 %************************************************************************
478 GLOBAL_VAR(v_FilesToClean, [], [String] )
479 GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
480 -- v_TmpDir has no closing '/'
484 setTmpDir dir = writeIORef v_TmpDir dir
486 cleanTempFiles :: Int -> IO ()
487 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
488 removeTmpFiles verb fs
490 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
491 cleanTempFilesExcept verb dont_delete
492 = do fs <- readIORef v_FilesToClean
493 let leftovers = filter (`notElem` dont_delete) fs
494 removeTmpFiles verb leftovers
495 writeIORef v_FilesToClean dont_delete
498 -- find a temporary name that doesn't already exist.
499 newTempName :: Suffix -> IO FilePath
501 = do x <- getProcessID
502 tmp_dir <- readIORef v_TmpDir
503 findTempName tmp_dir x
505 findTempName tmp_dir x
506 = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
507 b <- doesFileExist filename
508 if b then findTempName tmp_dir (x+1)
509 else do add v_FilesToClean filename -- clean it up later
512 addFilesToClean :: [FilePath] -> IO ()
513 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
514 addFilesToClean files = mapM_ (add v_FilesToClean) files
516 removeTmpFiles :: Int -> [FilePath] -> IO ()
517 removeTmpFiles verb fs
518 = traceCmd "Deleting temp files"
519 ("Deleting: " ++ unwords fs)
522 rm f = removeFile f `catchAllIO`
525 hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
531 %************************************************************************
533 \subsection{Running a program}
535 %************************************************************************
538 GLOBAL_VAR(v_Dry_run, False, Bool)
541 setDryRun = writeIORef v_Dry_run True
543 -----------------------------------------------------------------------------
544 -- Running an external program
546 runSomething :: String -- For -v message
547 -> String -- Command name (possibly a full path)
548 -- assumed already dos-ified
549 -> [String] -- Arguments
550 -- runSomething will dos-ify them
553 runSomething phase_name pgm args
554 = traceCmd phase_name cmd_line $
555 do { exit_code <- system cmd_line
556 ; if exit_code /= ExitSuccess
557 then throwDyn (PhaseFailed phase_name exit_code)
561 cmd_line = unwords (pgm : dosifyPaths (map quote args))
562 -- The pgm is already in native format (appropriate dir separators)
563 #if defined(mingw32_TARGET_OS)
565 quote s = "\"" ++ s ++ "\""
570 traceCmd :: String -> String -> IO () -> IO ()
571 -- a) trace the command (at two levels of verbosity)
572 -- b) don't do it at all if dry-run is set
573 traceCmd phase_name cmd_line action
574 = do { verb <- dynFlag verbosity
575 ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
576 ; when (verb >= 3) $ hPutStrLn stderr cmd_line
580 ; n <- readIORef v_Dry_run
584 ; action `catchAllIO` handle_exn verb
587 handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
588 ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
589 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
593 %************************************************************************
595 \subsection{Path names}
597 %************************************************************************
599 We maintain path names in Unix form ('/'-separated) right until
600 the last moment. On Windows we dos-ify them just before passing them
601 to the Windows command.
603 The alternative, of using '/' consistently on Unix and '\' on Windows,
604 proved quite awkward. There were a lot more calls to dosifyPath,
605 and even on Windows we might invoke a unix-like utility (eg 'sh'), which
606 interpreted a command line 'foo\baz' as 'foobaz'.
609 -----------------------------------------------------------------------------
610 -- Convert filepath into MSDOS form.
612 dosifyPaths :: [String] -> [String]
613 -- dosifyPaths does two things
614 -- a) change '/' to '\'
615 -- b) remove initial '/cygdrive/'
617 unDosifyPath :: String -> String
618 -- Just change '\' to '/'
620 pgmPath :: String -- Directory string in Unix format
621 -> String -- Program name with no directory separators
623 -> String -- Program invocation string in native format
627 #if defined(mingw32_TARGET_OS)
629 --------------------- Windows version ------------------
630 dosifyPaths xs = map dosifyPath xs
632 unDosifyPath xs = subst '\\' '/' xs
634 pgmPath dir pgm = dosifyPath dir ++ '\\' : pgm
637 = subst '/' '\\' real_stuff
639 -- fully convince myself that /cygdrive/ prefixes cannot
640 -- really appear here.
641 cygdrive_prefix = "/cygdrive/"
644 | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
649 --------------------- Unix version ---------------------
652 pgmPath dir pgm = dir ++ '/' : pgm
653 --------------------------------------------------------
656 subst a b ls = map (\ x -> if x == a then b else x) ls
660 -----------------------------------------------------------------------------
661 Path name construction
664 slash :: String -> String -> String
665 absPath, relPath :: [String] -> String
668 isSlash other = False
671 relPath xs = foldr1 slash xs
673 absPath xs = "" `slash` relPath xs
675 slash s1 s2 = s1 ++ ('/' : s2)
679 %************************************************************************
681 \subsection{Support code}
683 %************************************************************************
686 -----------------------------------------------------------------------------
687 -- Define getExecDir :: IO (Maybe String)
689 #if defined(mingw32_TARGET_OS)
690 getExecDir :: IO (Maybe String)
691 getExecDir = do let len = 2048 -- plenty, PATH_MAX is 512 under Win32.
692 buf <- mallocArray (fromIntegral len)
693 ret <- getModuleFileName nullAddr buf len
694 if ret == 0 then return Nothing
695 else do s <- peekCString buf
696 destructArray (fromIntegral len) buf
697 return (Just (reverse (drop (length "/bin/ghc.exe") (reverse (unDosifyPath n)))))
700 foreign import stdcall "GetModuleFileNameA" getModuleFileName :: Addr -> CString -> Int32 -> IO Int32
702 getExecDir :: IO (Maybe String) = do return Nothing
705 #ifdef mingw32_TARGET_OS
706 foreign import "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows
708 getProcessID :: IO Int
709 getProcessID = Posix.getProcessID