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 ()
28 -- Temporary-file management
31 cleanTempFiles, cleanTempFilesExcept, removeTmpFiles,
35 getProcessID, -- IO Int
36 system, -- String -> IO Int -- System.system
39 showGhcUsage, -- IO () Shows usage message and exits
40 getSysMan, -- IO String Parallel system only
42 runSomething -- ToDo: make private
47 import Outputable ( panic )
48 import Panic ( progName, GhcException(..) )
49 import Util ( global )
50 import CmdLineOpts ( dynFlag, verbosity )
52 import List ( intersperse )
53 import Exception ( throwDyn, catchAllIO )
54 import IO ( hPutStr, hPutChar, hPutStrLn, hFlush, stderr )
55 import Directory ( doesFileExist, removeFile )
56 import IOExts ( IORef, readIORef, writeIORef )
57 import Monad ( when, unless )
58 import qualified System
59 import System ( ExitCode(..) )
60 import qualified Posix
62 #include "../includes/config.h"
63 #include "HsVersions.h"
65 {-# DEPRECATED runSomething "runSomething should be private to SysTools" #-}
70 The configuration story
71 ~~~~~~~~~~~~~~~~~~~~~~~
73 GHC needs various support files (library packages, RTS etc), plus
74 various auxiliary programs (cp, gcc, etc). It finds these in one
77 * When running as an *installed program*, GHC finds most of this support
78 stuff in the installed library tree. The path to this tree is passed
79 to GHC via the -B flag, and given to initSysTools .
81 * When running *in-place* in a build tree, GHC finds most of this support
82 stuff in the build tree. The path to the build tree is, again passed
85 GHC tells which of the two is the case by seeing whether package.conf
86 is in TopDir [installed] or in TopDir/ghc/driver [inplace] (what a hack).
89 SysTools.initSysProgs figures out exactly where all the auxiliary programs
90 are, and initialises mutable variables to make it easy to call them.
91 To to this, it makes use of definitions in Config.hs, which is a Haskell
92 file containing variables whose value is figured out by the build system.
94 Config.hs contains two sorts of things
96 cGCC, The *names* of the programs
99 etc They do *not* include paths
102 cUNLIT_DIR The *path* to the directory containing unlit, split etc
103 cSPLIT_DIR *relative* to the root of the build tree,
104 for use when running *in-place* in a build tree (only)
108 %************************************************************************
110 \subsection{Global variables to contain system programs}
112 %************************************************************************
115 GLOBAL_VAR(v_Pgm_L, error "pgm_L", String) -- unlit
116 GLOBAL_VAR(v_Pgm_P, error "pgm_P", String) -- cpp
117 GLOBAL_VAR(v_Pgm_c, error "pgm_c", String) -- gcc
118 GLOBAL_VAR(v_Pgm_m, error "pgm_m", String) -- asm code mangler
119 GLOBAL_VAR(v_Pgm_s, error "pgm_s", String) -- asm code splitter
120 GLOBAL_VAR(v_Pgm_a, error "pgm_a", String) -- as
121 GLOBAL_VAR(v_Pgm_l, error "pgm_l", String) -- ld
122 GLOBAL_VAR(v_Pgm_MkDLL, error "pgm_dll", String) -- mkdll
124 GLOBAL_VAR(v_Pgm_PERL, error "pgm_PERL", String) -- perl
125 GLOBAL_VAR(v_Pgm_T, error "pgm_T", String) -- touch
126 GLOBAL_VAR(v_Pgm_CP, error "pgm_CP", String) -- cp
128 GLOBAL_VAR(v_Path_package_config, error "path_package_config", String)
129 GLOBAL_VAR(v_Path_usage, error "ghc_usage.txt", String)
131 -- Parallel system only
132 GLOBAL_VAR(v_Pgm_sysman, error "pgm_sysman", String) -- system manager
136 %************************************************************************
138 \subsection{Initialisation}
140 %************************************************************************
143 initSysTools :: String -- TopDir
144 -- for "installed" this is the root of GHC's support files
145 -- for "in-place" it is the root of the build tree
147 -> IO () -- Set all the mutable variables above, holding
148 -- (a) the system programs
149 -- (b) the package-config file
150 -- (c) the GHC usage message
153 = do { let installed pgm = top_dir `slash` "extra-bin" `slash` pgm
154 inplace dir pgm = top_dir `slash` dir `slash` pgm
156 installed_pkgconfig = installed "package.conf"
157 inplace_pkgconfig = inplace cGHC_DRIVER_DIR "package.conf.inplace"
159 -- Discover whether we're running in a build tree or in an installation,
160 -- by looking for the package configuration file.
161 ; am_installed <- doesFileExist installed_pkgconfig
163 -- Check that the in-place package config exists if
164 -- the installed one does not (we need at least one!)
165 ; if am_installed then return () else
166 do config_exists <- doesFileExist inplace_pkgconfig
167 if config_exists then return () else
168 throwDyn (InstallationError
169 ("Can't find package.conf in " ++
172 ; let pkgconfig_path | am_installed = installed_pkgconfig
173 | otherwise = inplace_pkgconfig
175 -- The GHC usage help message is found similarly to the package configuration
176 ; let ghc_usage_msg_path | am_installed = installed "ghc-usage.txt"
177 | otherwise = inplace cGHC_DRIVER_DIR "ghc-usage.txt"
180 #if defined(mingw32_TARGET_OS)
181 -- WINDOWS-SPECIFIC STUFF
182 -- On Windows, gcc and friends are distributed with GHC,
183 -- so when "installed" we look in TopDir/bin
184 -- When "in-place" we look wherever the build-time configure
186 ; let cpp_path | am_installed = installed cRAWCPP
187 | otherwise = cRAWCPP
188 gcc_path | am_installed = installed cGCC
190 perl_path | am_installed = installed cGHC_PERL
191 | otherwise = cGHC_PERL
193 -- 'touch' is a GHC util for Windows, and similarly unlit, mangle
194 ; let touch_path | am_installed = installed cGHC_TOUCHY
195 | otherwise = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY
197 ; let mkdll_path = cMKDLL
199 -- UNIX-SPECIFIC STUFF
200 -- On Unix, the "standard" tools are assumed to be
201 -- in the same place whether we are running "in-place" or "installed"
202 -- That place is wherever the build-time configure script found them.
203 ; let cpp_path = cRAWCPP
205 touch_path = cGHC_TOUCHY
206 perl_path = cGHC_PERL
207 mkdll_path = panic "Cant build DLLs on a non-Win32 system"
210 -- For all systems, unlit, split, mangle are GHC utilities
211 -- architecture-specific stuff is done when building Config.hs
213 -- However split and mangle are Perl scripts, and on Win32 at least
214 -- we don't want to rely on #!/bin/perl, so we prepend a call to Perl
215 ; let unlit_path | am_installed = installed cGHC_UNLIT
216 | otherwise = inplace cGHC_UNLIT_DIR cGHC_UNLIT
218 split_script | am_installed = installed cGHC_SPLIT
219 | otherwise = inplace cGHC_SPLIT_DIR cGHC_SPLIT
220 mangle_script | am_installed = installed cGHC_MANGLER
221 | otherwise = inplace cGHC_MANGLER_DIR cGHC_MANGLER
223 split_path = perl_path ++ " " ++ split_script
224 mangle_path = perl_path ++ " " ++ mangle_script
226 -- For all systems, copy and remove are provided by the host
227 -- system; architecture-specific stuff is done when building Config.hs
228 ; let cp_path = cGHC_CP
230 -- Other things being equal, as and ld are simply gcc
231 ; let as_path = gcc_path
235 -- Initialise the global vars
236 ; writeIORef v_Path_package_config pkgconfig_path
237 ; writeIORef v_Path_usage ghc_usage_msg_path
239 ; writeIORef v_Pgm_sysman (top_dir ++ "/ghc/rts/parallel/SysMan")
240 -- Hans: this isn't right in general, but you can
241 -- elaborate it in the same way as the others
243 ; writeIORef v_Pgm_L unlit_path
244 ; writeIORef v_Pgm_P cpp_path
245 ; writeIORef v_Pgm_c gcc_path
246 ; writeIORef v_Pgm_m mangle_path
247 ; writeIORef v_Pgm_s split_path
248 ; writeIORef v_Pgm_a as_path
249 ; writeIORef v_Pgm_l ld_path
250 ; writeIORef v_Pgm_MkDLL mkdll_path
251 ; writeIORef v_Pgm_T touch_path
252 ; writeIORef v_Pgm_CP cp_path
253 ; writeIORef v_Pgm_PERL perl_path
258 setPgm is called when a command-line option like
260 is used to override a particular program with a new onw
263 setPgm :: String -> IO ()
264 -- The string is the flag, minus the '-pgm' prefix
265 -- So the first character says which program to override
267 setPgm ('P' : pgm) = writeIORef v_Pgm_P pgm
268 setPgm ('c' : pgm) = writeIORef v_Pgm_c pgm
269 setPgm ('m' : pgm) = writeIORef v_Pgm_m pgm
270 setPgm ('s' : pgm) = writeIORef v_Pgm_s pgm
271 setPgm ('a' : pgm) = writeIORef v_Pgm_a pgm
272 setPgm ('l' : pgm) = writeIORef v_Pgm_l pgm
273 setPgm pgm = unknownFlagErr ("-pgm" ++ pgm)
277 %************************************************************************
279 \subsection{Running an external program}
281 %************************************************************************
285 runUnlit :: [String] -> IO ()
286 runUnlit args = do p <- readIORef v_Pgm_L
287 runSomething "Literate pre-processor" p args
289 runCpp :: [String] -> IO ()
290 runCpp args = do p <- readIORef v_Pgm_P
291 runSomething "C pre-processor" p args
293 runCc :: [String] -> IO ()
294 runCc args = do p <- readIORef v_Pgm_c
295 runSomething "C Compiler" p args
297 runMangle :: [String] -> IO ()
298 runMangle args = do p <- readIORef v_Pgm_m
299 runSomething "Mangler" p args
301 runSplit :: [String] -> IO ()
302 runSplit args = do p <- readIORef v_Pgm_s
303 runSomething "Splitter" p args
305 runAs :: [String] -> IO ()
306 runAs args = do p <- readIORef v_Pgm_a
307 runSomething "Assembler" p args
309 runLink :: [String] -> IO ()
310 runLink args = do p <- readIORef v_Pgm_l
311 runSomething "Linker" p args
313 runMkDLL :: [String] -> IO ()
314 runMkDLL args = do p <- readIORef v_Pgm_MkDLL
315 runSomething "Make DLL" p args
317 touch :: String -> String -> IO ()
318 touch purpose arg = do p <- readIORef v_Pgm_T
319 runSomething purpose p [arg]
321 copy :: String -> String -> String -> IO ()
322 copy purpose from to = do p <- readIORef v_Pgm_CP
323 runSomething purpose p [from,to]
327 getSysMan :: IO String -- How to invoke the system manager
328 -- (parallel system only)
329 getSysMan = readIORef v_Pgm_sysman
332 %************************************************************************
334 \subsection{GHC Usage message}
336 %************************************************************************
338 Show the usage message and exit
341 showGhcUsage = do { usage_path <- readIORef v_Path_usage
342 ; usage <- readFile usage_path
344 ; System.exitWith System.ExitSuccess }
347 dump ('$':'$':s) = hPutStr stderr progName >> dump s
348 dump (c:s) = hPutChar stderr c >> dump s
350 packageConfigPath = readIORef v_Path_package_config
354 %************************************************************************
356 \subsection{Managing temporary files
358 %************************************************************************
360 One reason this code is here is because SysTools.system needs to make
364 GLOBAL_VAR(v_FilesToClean, [], [String] )
365 GLOBAL_VAR(v_TmpDir, cDEFAULT_TMPDIR, String )
366 -- v_TmpDir has no closing '/'
370 setTmpDir dir = writeIORef v_TmpDir dir
372 cleanTempFiles :: Int -> IO ()
373 cleanTempFiles verb = do fs <- readIORef v_FilesToClean
374 removeTmpFiles verb fs
376 cleanTempFilesExcept :: Int -> [FilePath] -> IO ()
377 cleanTempFilesExcept verb dont_delete
378 = do fs <- readIORef v_FilesToClean
379 let leftovers = filter (`notElem` dont_delete) fs
380 removeTmpFiles verb leftovers
381 writeIORef v_FilesToClean dont_delete
384 -- find a temporary name that doesn't already exist.
385 newTempName :: Suffix -> IO FilePath
387 = do x <- getProcessID
388 tmp_dir <- readIORef v_TmpDir
389 findTempName tmp_dir x
391 findTempName tmp_dir x
392 = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
393 b <- doesFileExist filename
394 if b then findTempName tmp_dir (x+1)
395 else do add v_FilesToClean filename -- clean it up later
398 addFilesToClean :: [FilePath] -> IO ()
399 -- May include wildcards [used by DriverPipeline.run_phase SplitMangle]
400 addFilesToClean files = mapM_ (add v_FilesToClean) files
402 removeTmpFiles :: Int -> [FilePath] -> IO ()
403 removeTmpFiles verb fs
404 = traceCmd "Deleting temp files"
405 ("Deleting: " ++ concat (intersperse " " fs))
408 rm f = removeFile f `catchAllIO`
409 (\exn -> hPutStrLn stderr ("Warning: deleting non-existent " ++ f) >>
415 %************************************************************************
417 \subsection{Running a program}
419 %************************************************************************
422 GLOBAL_VAR(v_Dry_run, False, Bool)
425 setDryRun = writeIORef v_Dry_run True
427 -----------------------------------------------------------------------------
428 -- Running an external program
430 runSomething :: String -- For -v message
431 -> String -- Command name (possibly a full path)
432 -- assumed already dos-ified
433 -> [String] -- Arguments
434 -- runSomthing will dos-ify them
437 runSomething phase_name pgm args
438 = traceCmd phase_name cmd_line $
439 do { exit_code <- system cmd_line
440 ; if exit_code /= ExitSuccess
441 then throwDyn (PhaseFailed phase_name exit_code)
445 cmd_line = unwords (pgm : dosifyPaths args)
447 traceCmd :: String -> String -> IO () -> IO ()
448 -- a) trace the command (at two levels of verbosity)
449 -- b) don't do it at all if dry-run is set
450 traceCmd phase_name cmd_line action
451 = do { verb <- dynFlag verbosity
452 ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
453 ; when (verb >= 3) $ hPutStrLn stderr cmd_line
457 ; n <- readIORef v_Dry_run
461 ; action `catchAllIO` handle_exn verb
464 handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
465 ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line))
466 ; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
470 %************************************************************************
472 \subsection{Support code}
474 %************************************************************************
478 -----------------------------------------------------------------------------
479 -- Convert filepath into MSDOS form.
481 dosifyPaths :: [String] -> [String]
482 -- dosifyPath does two things
483 -- a) change '/' to '\'
484 -- b) remove initial '/cygdrive/'
486 #if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
487 dosifyPaths xs = map dosifyPath xs
489 dosifyPath :: String -> String
491 = subst '/' '\\' real_stuff
493 -- fully convince myself that /cygdrive/ prefixes cannot
494 -- really appear here.
495 cygdrive_prefix = "/cygdrive/"
498 | cygdrive_prefix `isPrefixOf` stuff = drop (length cygdrive_prefix) stuff
501 subst a b ls = map (\ x -> if x == a then b else x) ls
506 -----------------------------------------------------------------------------
507 -- Path name construction
508 -- At the moment, we always use '/' and rely on dosifyPath
509 -- to switch to DOS pathnames when necessary
511 slash :: String -> String -> String
512 absPath, relPath :: [String] -> String
514 slash s1 s2 = s1 ++ ('/' : s2)
518 relPath xs = foldr1 slash xs
520 absPath xs = "" `slash` relPath xs
522 -----------------------------------------------------------------------------
523 -- Convert filepath into MSDOS form.
525 -- Define myGetProcessId :: IO Int
527 #ifdef mingw32_TARGET_OS
528 foreign import "_getpid" getProcessID :: IO Int
530 getProcessID :: IO Int
531 getProcessID = Posix.getProcessID
536 %************************************************************************
540 %************************************************************************
542 -- This procedure executes system calls. In pre-GHC-5.00 and earlier,
543 -- the System.system implementation didn't work, so this acts as a fix-up
544 -- by passing the command line to 'sh'.
546 system :: String -> IO ExitCode
549 #if !defined(mingw32_TARGET_OS)
550 -- in the case where we do want to use an MSDOS command shell, we assume
551 -- that files and paths have been converted to a form that's
552 -- understandable to the command we're invoking.
555 tmp <- newTempName "sh"
556 h <- openFile tmp WriteMode
559 exit_code <- system ("sh - " ++ tmp) `catchAllIO`
560 (\exn -> removeFile tmp >> ioError exn)